Commit 1e3f6286 by Henrik Nilsson

Changes to make Arpeggigon compile and run with GHC 7.8.3 and base 4.7.

parent bef57335
......@@ -27,7 +27,8 @@ executable arpeggigon
, TypeSynonymInstances
, FlexibleContexts
, GeneralizedNewtypeDeriving
build-depends: base >=4.8 && <4.10
build-depends: base >=4.7 && <4.10
, bifunctors >= 5.4.1 && < 6
, array >=0.5 && <0.6
, keera-hails-reactivevalues >=0.2 && <0.3
, Yampa >=0.10 && <0.11
......@@ -127,4 +128,4 @@ executable arpeggigon
-- -Wall
-- -fno-warn-name-shadowing
-- -fno-warn-unused-do-bind
-- -debug
\ No newline at end of file
-- -debug
......@@ -6,6 +6,7 @@ import FRP.Yampa
-- |= General functions
{-
-- | Reversed version of '(\<$\>)'.
(<$$>) :: (Functor f) => f a -> (a -> b) -> f b
(<$$>) = flip (<$>)
......@@ -13,6 +14,7 @@ import FRP.Yampa
-- | Reversed version of '(<$)'.
($>) :: (Functor f) => f a -> b -> f b
($>) = flip (<$)
-}
-- | @bound (min,max)@ behaves like identity if the supplied value is between @min@ and @max@, otherwise it is replaced either by @min@ or by @max@.
bound :: (Ord a) => (a, a) -> a -> a
......
......@@ -18,6 +18,18 @@ countTo n = count >>^ filterE (== n)
-- Event b => . a . . . b . . . c . . . . . . d . e . f . . . . . g . .
-- wairFor => . . . . . 1 . . . 2 . . . . . . 4 . . . 5 . . . . . 6 . .
-- A more direct approach, and without any use of *> to avoid depending
-- on applicatives.
waitForEvent :: SF (Event a, Event b) (Event a)
waitForEvent = sscanPrim procEvts NoEvent NoEvent
where
procEvts eaPrev (NoEvent, NoEvent) = Just (eaPrev, NoEvent)
procEvts _ (ea@(Event _), NoEvent) = Just (ea, NoEvent)
procEvts eaPrev (NoEvent, Event _) = Just (NoEvent, eaPrev)
procEvts _ (ea@(Event _), Event _) = Just (NoEvent, ea)
{-
waitForEvent :: SF (Event a, Event b) (Event a)
waitForEvent = proc (ea,eb) -> do
em <- arr $ uncurry $ mapMerge Left Right (\_ b -> Right b) -< (ea,eb)
......@@ -27,6 +39,7 @@ waitForEvent = proc (ea,eb) -> do
accumulator _ (Left a) = Event a
accumulator _ (Right _) = NoEvent
--accumulator _ (Right b) =
-}
{-
waitForEvent :: SF (Event b, Event a) (Event b)
......@@ -81,7 +94,7 @@ integralMod x = intMod' 0
where intMod' x0 = switch (intMod'' x0) (\y -> intMod' (y - x))
intMod'' x0 = proc t -> do
it <- (+ x0) ^<< integral -< t
es <- edgeBy (\_ y -> maybeIf (y > x) $> y) 0 -< it
es <- edgeBy (\_ y -> if y > x then Just y else Nothing) 0 -< it
returnA -< (it,es)
......@@ -92,7 +105,7 @@ varFreqSine = sin ^<< (2*pi*) ^<< integralMod 1 <<^ (1/)
-- | Generates an 'Event' with a regular period, which is given as an input to the signal function.
repeatedlyS :: a -> SF DTime (Event a)
repeatedlyS x = edgeBy (\a b -> maybeIf (a * b < 0) $> x) 0
repeatedlyS x = edgeBy (\a b -> if a * b < 0 then Just x else Nothing) 0
<<< varFreqSine <<^ (2*)
repeatedlyS' :: a -> SF DTime (Event a)
......
......@@ -37,7 +37,7 @@ toggleButtonNewFromStock s = do
buttonBox <- hBoxNew False 0
buttonImg <- imageNewFromStock s IconSizeButton
stockTxt <- stockLookupItem s
buttonLabel <- labelNew (siLabel <$> stockTxt)
buttonLabel <- labelNew (fmap siLabel stockTxt)
labelSetUseUnderline buttonLabel True
packButton button buttonBox buttonLabel buttonImg
......
......@@ -94,12 +94,13 @@ createNotebook boardQueue tc addLayerRV rmLayerRV
when (button == LeftButton && isJust nmp) $ do
let nCell = snd $ fromJust nmp
mOHid <- tryTakeMVar guiCellHidMVar
forM_ mOHid $ removeCallbackMCBMVar guiCellMCBMVar
maybe (return ()) (removeCallbackMCBMVar guiCellMCBMVar) mOHid
reactiveValueWrite guiCellMCBMVar nCell
nHid <- installCallbackMCBMVar guiCellMCBMVar $ do
cp <- reactiveValueRead curChanRV
guiVal <- reactiveValueRead guiCellMCBMVar
mChanRV <- M.lookup cp <$> reactiveValueRead chanMapRV
mChanRV <- fmap (M.lookup cp)
(reactiveValueRead chanMapRV)
when (isNothing mChanRV) $ error "Can't get piece array!"
let (_,pieceArrRV,_) = fromJust mChanRV
reactiveValueWrite (pieceArrRV ! fPos) guiVal
......@@ -126,8 +127,8 @@ createNotebook boardQueue tc addLayerRV rmLayerRV
layerMapRV <- newCBRef $ M.insert fstP defaultLayerConf M.empty
reactiveValueOnCanRead layerMapRV $ do
synth <- fmap (\(_,_,s) -> s) <$> reactiveValueRead layerMapRV
sequence_ $ M.mapWithKey
synth <- fmap (fmap (\(_,_,s) -> s)) (reactiveValueRead layerMapRV)
sequence_ $ M.elems $ M.mapWithKey
(\chan mess -> reactiveValueAppend boardQueue $
M.singleton chan $ ([],) $ synthMessage chan mess) synth
......@@ -252,9 +253,21 @@ createNotebook boardQueue tc addLayerRV rmLayerRV
boardMapRV = ReactiveFieldRead getter notifier
where notifier io = do
chanMap <- reactiveValueRead chanMapRV
mapM_ ((`reactiveValueOnCanRead` io) . \(b,_,_) -> b) chanMap
intMapMapM_ ((`reactiveValueOnCanRead` io) . \(b,_,_) -> b) chanMap
getter = do
chanMap <- reactiveValueRead chanMapRV
mapM (reactiveValueRead . \(b,_,_) -> b) chanMap
intMapMapM (reactiveValueRead . \(b,_,_) -> b) chanMap
return (n, boardMapRV, layerMapRV, phMapRV)
------------------------------------------------------------------------------
-- IntMap versions of mapM etc. to make code work with GHC 7.8.3
------------------------------------------------------------------------------
intMapMapM_ :: (Functor m, Monad m) => (a -> m b) -> M.IntMap a -> m ()
intMapMapM_ f im = mapM_ f (M.elems im)
intMapMapM :: (Functor m, Monad m) => (a -> m b) -> M.IntMap a -> m (M.IntMap b)
intMapMapM f im = fmap (M.fromList . zip ks) (mapM f es)
where
(ks, es) = unzip (M.toList im)
......@@ -120,7 +120,8 @@ noteSettingsBox = do
\for the duration.") $ lookup d noteDurIndex
noteDurRV = bijection (indexToDur, durToIndex) `liftRW`
comboBoxIndexRV noteDurCombo
noteDurLabel <- labelNew =<< (`lookup` symbolString) <$> reactiveValueRead noteDurRV
noteDurLabel <- labelNew =<< fmap (`lookup` symbolString)
(reactiveValueRead noteDurRV)
let noteDurLabelRV = labelTextReactive noteDurLabel
boxPackStart naBox noteDurBox PackNatural 0
boxPackStart noteDurBox noteDurCombo PackNatural 0
......@@ -140,14 +141,15 @@ noteSettingsBox = do
nDur <- reactiveValueRead noteDurRV
oCell <- reactiveValueRead setRV
let nCa :: Maybe NoteAttr
nCa = (\na -> na { naDur = nDur }) <$> getNAttr (cellAction oCell)
nCa = fmap (\na -> na { naDur = nDur }) (getNAttr (cellAction oCell))
nCell :: GUICell
nCell = if isJust nCa
then oCell { cellAction =
setNAttr (fromJust nCa) (cellAction oCell) }
else oCell
reactiveValueWriteOnNotEq setRV nCell
fromMaybeM_ $ reactiveValueWrite noteDurLabelRV <$> lookup nDur symbolString
fromMaybeM_ $ fmap (reactiveValueWrite noteDurLabelRV)
(lookup nDur symbolString)
reactiveValueOnCanRead rCountRV $ do
......@@ -160,8 +162,8 @@ noteSettingsBox = do
nSlide <- reactiveValueRead slideComboRV
oCell <- reactiveValueRead setRV
let nCa :: Maybe NoteAttr
nCa = (\na -> na { naOrn = (naOrn na) { ornSlide = nSlide } }) <$>
getNAttr (cellAction oCell)
nCa = fmap (\na -> na { naOrn = (naOrn na) { ornSlide = nSlide } })
(getNAttr (cellAction oCell))
nCell :: GUICell
nCell = if isJust nCa
then oCell { cellAction =
......@@ -174,7 +176,7 @@ noteSettingsBox = do
nArt <- reactiveValueRead artComboRV
oCell <- reactiveValueRead setRV
let nCa :: Maybe NoteAttr
nCa = (\na -> na { naArt = nArt }) <$> getNAttr (cellAction oCell)
nCa = fmap (\na -> na { naArt = nArt }) (getNAttr (cellAction oCell))
nCell :: GUICell
nCell = if isJust nCa
then oCell { cellAction =
......@@ -200,13 +202,14 @@ noteSettingsBox = do
reactiveValueOnCanRead setRV $ postGUIAsync $ do
nCell <- reactiveValueRead setRV
fromMaybeM_ (reactiveValueWriteOnNotEq artComboRV . naArt <$>
getNAttr (cellAction nCell))
fromMaybeM_ (reactiveValueWriteOnNotEq slideComboRV . ornSlide . naOrn <$>
getNAttr (cellAction nCell))
fromMaybeM_ (fmap (reactiveValueWriteOnNotEq artComboRV . naArt)
(getNAttr (cellAction nCell)))
fromMaybeM_ (fmap (reactiveValueWriteOnNotEq slideComboRV
. ornSlide . naOrn)
(getNAttr (cellAction nCell)))
reactiveValueWriteOnNotEq rCountRV $ repeatCount nCell
fromMaybeM_ (reactiveValueWriteOnNotEq noteDurRV . naDur <$>
getNAttr (cellAction nCell))
fromMaybeM_ (fmap (reactiveValueWriteOnNotEq noteDurRV . naDur)
(getNAttr (cellAction nCell)))
updateNaBox nCell
widgetShow pieceBox
......
......@@ -50,7 +50,7 @@ stopIOMetronome (IOMetronome (_,tid)) = killThread tid
newtype IOTick = IOTick (MVar [IO ()])
newIOTick :: IO IOTick
newIOTick = IOTick <$> newMVar []
newIOTick = fmap IOTick (newMVar [])
tickIOTick :: IOTick -> IO ()
tickIOTick (IOTick mvar) = readMVar mvar >>= sequence_
......
......@@ -18,7 +18,8 @@ layerMetronome StaticLayerConf { beatsPerBar = bpb
} =
proc (eb, DynLayerConf { layerBeat = r
}) -> do
ewbno <- accumFilter (\_ (ab,r) -> ((),selectBeat (ab,r))) () -< (,r) <$> eb
ewbno <- accumFilter (\_ (ab,r) -> ((),selectBeat (ab,r))) ()
-< fmap (,r) eb
accumBy (flip nextBeatNo) 0 -< ewbno `tag` bpb
where selectBeat (absBeat, layBeat) =
maybeIf ((absBeat - 1) `mod`
......@@ -84,8 +85,8 @@ layers imap = proc (t,erun,map) -> do
(Stopped,_) -> (nRS,Just nRS)
(Running, Stopped) -> (Stopped,Just Stopped)
_ -> (oRS,Nothing)) Stopped -< erun
eabs <- rSwitch metronome -< (t, newMetronome <$> erun')
rpSwitch routing (imap $> layer) -< ((eabs,erun,map),e)
eabs <- rSwitch metronome -< (t, fmap newMetronome erun')
rpSwitch routing (fmap (const layer) imap) -< ((eabs,erun,map),e)
where routing (eabs,erun,map) sfs = M.intersectionWith (,)
(fmap (\(b,l,er) -> (eabs,b,l,erun `lMerge` er)) map) sfs
......
......@@ -32,13 +32,13 @@ newtype HandlerId a = HandlerId Integer deriving(Eq, Show, Ord)
newtype MCBMVar a = MCBMVar (MVar (a, (HandlerId a,CallbackMap)))
newMCBMVar :: a -> IO (MCBMVar a)
newMCBMVar = (MCBMVar <$>) . newMVar . (,(HandlerId 0,M.empty))
newMCBMVar = (fmap MCBMVar) . newMVar . (,(HandlerId 0,M.empty))
readMCBMVar :: MCBMVar a -> IO a
readMCBMVar (MCBMVar x) = fst <$> readMVar x
readMCBMVar (MCBMVar x) = fmap fst (readMVar x)
runCallBacks :: MCBMVar a -> IO ()
runCallBacks (MCBMVar x) = readMVar x >>= sequence_ . snd . snd
runCallBacks (MCBMVar x) = readMVar x >>= sequence_ . M.elems . snd . snd
writeMCBMVar :: MCBMVar a -> a -> IO ()
writeMCBMVar w@(MCBMVar x) y = do
......
......@@ -3,6 +3,7 @@
module Main where
import Control.Concurrent
import Data.Monoid
import qualified Data.IntMap as M
import Data.ReactiveValue
import FRP.Yampa
......@@ -96,9 +97,9 @@ main = do
let noteMap = M.map fromEvent $ M.filter isEvent $ M.map fst out
writePh chan val =
fromMaybeM_ $ (`reactiveValueWrite` val) <$>
M.lookup chan phRVMap
sequence_ $ M.mapWithKey writePh $ M.map snd out
fromMaybeM_ $ fmap (`reactiveValueWrite` val)
(M.lookup chan phRVMap)
sequence_ $ M.elems $ M.mapWithKey writePh $ M.map snd out
reactiveValueAppend boardQueue $ M.map (,[]) noteMap
putStrLn "Board started."
......
......@@ -3,7 +3,7 @@
module RMCA.ReactiveValueAtomicUpdate where
import Control.Monad
import Data.Monoid
import Data.CBRef
import Data.ReactiveValue
......@@ -19,7 +19,7 @@ class (ReactiveValueReadWrite a b m) => ReactiveValueAtomicUpdate a b m where
reactiveValueUpdate_ :: (ReactiveValueAtomicUpdate a b m) =>
a -> (b -> b) -> m ()
reactiveValueUpdate_ rv f = void $ reactiveValueUpdate rv f
reactiveValueUpdate_ rv f = reactiveValueUpdate rv f >> return ()
reactiveValueAppend :: (Monoid b, ReactiveValueAtomicUpdate a b m) =>
a -> b -> m ()
......
......@@ -9,7 +9,7 @@ import Control.Arrow
import qualified Control.Monad.Exception.Synchronous as Sync
import qualified Control.Monad.Trans.Class as Trans
import Data.CBRef
import Data.Foldable
import Data.Foldable hiding (mapM_,concat)
import qualified Data.IntMap as M
import Data.Maybe
import Data.ReactiveValue
......@@ -109,10 +109,10 @@ jackCallBack tc input output toProcessRV boardQueue tempoRV layerMapRV
mapM_ ((\(Instrument c p) -> reactiveValueUpdate layerMapRV
(M.adjust (\(st,d,s) -> (st,d,s { instrument = fromProgram p }))
(fromChannel c))) . snd) instruments
concat . toList . gatherMessages tempo nframesInt <$>
reactiveValueEmpty boardQueue >>=
fmap (concat . toList . gatherMessages tempo nframesInt)
(reactiveValueEmpty boardQueue) >>=
reactiveValueAppend toProcessRV
(go, old') <- schedule nframesInt <$> reactiveValueRead toProcessRV
(go, old') <- fmap (schedule nframesInt) (reactiveValueRead toProcessRV)
let old = map (first (+ (- nframesInt))) old'
--putStrLn ("Out: " ++ show (map fst go))
reactiveValueWrite outMIDIRV go
......
......@@ -3,6 +3,7 @@
module RMCA.Translator.RV where
import Control.Monad.Exception.Synchronous (ExceptionalT, resolveT)
import Data.Monoid hiding (All)
import qualified Data.Bifunctor as BF
import qualified Data.EventList.Absolute.TimeBody as EventListAbs
import qualified Data.List as L
......@@ -24,8 +25,8 @@ inMIDIEvent :: JMIDI.Port Jack.Input
-> ReactiveFieldRead IO [(Frames,RawMessage)]
inMIDIEvent input nframes = ReactiveFieldRead getter notifier
where getter :: IO [(Frames, RawMessage)]
getter = handleError $ transform <$>
JMIDI.readEventsFromPort input nframes
getter = handleError $
fmap transform (JMIDI.readEventsFromPort input nframes)
transform :: EventListAbs.T Jack.NFrames t -> [(Frames, t)]
transform = map (BF.first (\(Jack.NFrames n) -> fromIntegral n)) .
......
......@@ -53,12 +53,20 @@ sortRawMessages = sortRawMessages' ([],[])
where nm = fromRawMessage xm
-- Direct each message to a specific channel.
-- (Simplified version not using <$> or <*>
sortChannel :: [Message] -> [(Int,[Message])]
sortChannel ms = [ (getChannel (head ms'), ms')
| ms' <- groupBy ((==) `on` getChannel) ms ]
{-
-- Direct each message to a specific channel.
-- /!\ To be modified.
sortChannel :: [Message] -> [(Int,[Message])]
sortChannel = map ((,) <$> (fst . head) <*> map snd)
. groupBy ((==) `on` fst) . map sortChannel'
where sortChannel' :: Message -> (Int, Message)
sortChannel' m = let c = getChannel m in (c,m)
-}
-- NoteOn messages are on the right, other Control messages are on the
-- left. For now we throw away NoteOff messages.
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment