diff options
author | Andrew Cady <d@jerkface.net> | 2015-12-06 04:01:46 -0500 |
---|---|---|
committer | Andrew Cady <d@jerkface.net> | 2015-12-06 04:01:46 -0500 |
commit | 71b8dea17e015d3266bda8705868184bb1fe4e5a (patch) | |
tree | db66640e1d3e4f414405c36b6673fd8174724287 | |
parent | f8ac45371bff74034205fec65a9e69c0a527e8a4 (diff) |
use the MidiController type alias in all type signatures
-rw-r--r-- | midi-dump.hs | 22 |
1 files changed, 11 insertions, 11 deletions
diff --git a/midi-dump.hs b/midi-dump.hs index 536d78d..b68a790 100644 --- a/midi-dump.hs +++ b/midi-dump.hs | |||
@@ -67,7 +67,7 @@ data LoopEnv = LoopEnv { | |||
67 | _lineReader :: MVar String | 67 | _lineReader :: MVar String |
68 | } | 68 | } |
69 | 69 | ||
70 | getAbsTime :: RWST LoopEnv () LoopState IO TimeSpec | 70 | getAbsTime :: MidiController TimeSpec |
71 | getAbsTime = do | 71 | getAbsTime = do |
72 | startTime <- asks _startTime | 72 | startTime <- asks _startTime |
73 | startTimeReal <- asks _startTimeReal | 73 | startTimeReal <- asks _startTimeReal |
@@ -128,7 +128,7 @@ main' = withAlsaInit $ \h public private q publicAddr privateAddr -> do | |||
128 | (_, ()) <- execRWST mainLoop env $ initializeState startTimeReal | 128 | (_, ()) <- execRWST mainLoop env $ initializeState startTimeReal |
129 | return () | 129 | return () |
130 | 130 | ||
131 | mainLoop :: RWST LoopEnv () LoopState IO () | 131 | mainLoop :: MidiController () |
132 | mainLoop = do | 132 | mainLoop = do |
133 | maybeReadLine >>= maybe processMidi processCommand | 133 | maybeReadLine >>= maybe processMidi processCommand |
134 | wantExit <- gets _wantExit | 134 | wantExit <- gets _wantExit |
@@ -150,7 +150,7 @@ playImmediates = do | |||
150 | -- TODO: flush ALSA output here (and remove flush from playNoteEv) | 150 | -- TODO: flush ALSA output here (and remove flush from playNoteEv) |
151 | modify $ \s -> s { _playNOW = [] } | 151 | modify $ \s -> s { _playNOW = [] } |
152 | 152 | ||
153 | _playNote :: Bool -> Event.Note -> RWST LoopEnv () LoopState IO () | 153 | _playNote :: Bool -> Event.Note -> MidiController () |
154 | _playNote noteOn note = | 154 | _playNote noteOn note = |
155 | playNoteEv $ Event.NoteEv onoff note | 155 | playNoteEv $ Event.NoteEv onoff note |
156 | where onoff = if noteOn then Event.NoteOn else Event.NoteOff | 156 | where onoff = if noteOn then Event.NoteOn else Event.NoteOff |
@@ -159,21 +159,22 @@ delayEvent :: Event.T -> TimeSpec -> Event.T | |||
159 | delayEvent evt ts = evt {Event.time = Time.consRel $ Time.Real (RealTime.fromInteger nanosecs)} | 159 | delayEvent evt ts = evt {Event.time = Time.consRel $ Time.Real (RealTime.fromInteger nanosecs)} |
160 | where nanosecs = timeSpecAsNanoSecs ts | 160 | where nanosecs = timeSpecAsNanoSecs ts |
161 | 161 | ||
162 | playNoteEv :: Event.Data -> RWST LoopEnv () LoopState IO () | 162 | playNoteEv :: Event.Data -> MidiController () |
163 | playNoteEv = alsaDelayNoteEv (TimeSpec 0 0) | 163 | playNoteEv = alsaDelayNoteEv (TimeSpec 0 0) |
164 | 164 | ||
165 | alsaDelayNoteEv :: TimeSpec -> Event.Data -> RWST LoopEnv () LoopState IO () | 165 | alsaDelayNoteEv :: TimeSpec -> Event.Data -> MidiController () |
166 | alsaDelayNoteEv delay nevdata = do | 166 | alsaDelayNoteEv delay nevdata = do |
167 | ms <- getMidiSender | 167 | ms <- getMidiSender |
168 | publicAddr <- asks _publicAddr | 168 | publicAddr <- asks _publicAddr |
169 | liftIO $ ms $ Event.simple publicAddr nevdata `delayEvent` delay | 169 | liftIO $ ms $ Event.simple publicAddr nevdata `delayEvent` delay |
170 | 170 | ||
171 | |||
171 | queueAction :: (Queue Event.Data -> MidiController (Queue Event.Data)) -> MidiController () | 172 | queueAction :: (Queue Event.Data -> MidiController (Queue Event.Data)) -> MidiController () |
172 | queueAction act = do | 173 | queueAction act = do |
173 | q <- gets _scheduled | 174 | q <- gets _scheduled |
174 | act q >>= \q' -> modify $ \s -> s { _scheduled = q' } | 175 | act q >>= \q' -> modify $ \s -> s { _scheduled = q' } |
175 | 176 | ||
176 | delayNoteEv :: TimeSpec -> Event.Data -> RWST LoopEnv () LoopState IO () | 177 | delayNoteEv :: TimeSpec -> Event.Data -> MidiController () |
177 | delayNoteEv delay nevdata = queueAction $ scheduleEventIO (delay, nevdata) | 178 | delayNoteEv delay nevdata = queueAction $ scheduleEventIO (delay, nevdata) |
178 | 179 | ||
179 | _whenFlag :: forall (m :: * -> *) s. MonadState s m => (s -> Bool) -> m () -> m () | 180 | _whenFlag :: forall (m :: * -> *) s. MonadState s m => (s -> Bool) -> m () -> m () |
@@ -182,7 +183,7 @@ _whenFlag flag f = gets flag >>= flip when f | |||
182 | mkNote :: Word8 -> Event.Note | 183 | mkNote :: Word8 -> Event.Note |
183 | mkNote pitch = Event.simpleNote (Event.Channel 0) (Event.Pitch pitch) (Event.Velocity 128) | 184 | mkNote pitch = Event.simpleNote (Event.Channel 0) (Event.Pitch pitch) (Event.Velocity 128) |
184 | 185 | ||
185 | processCommand :: String -> RWST LoopEnv () LoopState IO () | 186 | processCommand :: String -> MidiController () |
186 | processCommand "exit" = modify $ \s -> s { _wantExit = True } | 187 | processCommand "exit" = modify $ \s -> s { _wantExit = True } |
187 | -- processCommand "" = return () | 188 | -- processCommand "" = return () |
188 | processCommand "" = gets _replay >>= playRecording | 189 | processCommand "" = gets _replay >>= playRecording |
@@ -205,21 +206,20 @@ processCommand str = liftIO $ putStrLn $ "Unknown command: " ++ str | |||
205 | type MidiControllerT m = RWST LoopEnv () LoopState m | 206 | type MidiControllerT m = RWST LoopEnv () LoopState m |
206 | type MidiController = MidiControllerT IO | 207 | type MidiController = MidiControllerT IO |
207 | 208 | ||
208 | -- playRecording :: Recording -> RWST LoopEnv () LoopState IO () | ||
209 | playRecording :: Recording -> MidiController () | 209 | playRecording :: Recording -> MidiController () |
210 | playRecording (RecordingInProgress _ _ evts@(_:_)) = | 210 | playRecording (RecordingInProgress _ _ evts@(_:_)) = |
211 | mapM_ (uncurry delayNoteEv) (zip (subtract (head delays) <$> delays) events) | 211 | mapM_ (uncurry delayNoteEv) (zip (subtract (head delays) <$> delays) events) |
212 | where (delays, events) = unzip $ fmap Event.body <$> reverse evts | 212 | where (delays, events) = unzip $ fmap Event.body <$> reverse evts |
213 | playRecording _ = return () | 213 | playRecording _ = return () |
214 | 214 | ||
215 | getMidiSender :: RWST LoopEnv () LoopState IO MidiHook | 215 | getMidiSender :: MidiController MidiHook |
216 | getMidiSender = do | 216 | getMidiSender = do |
217 | h <- asks _h | 217 | h <- asks _h |
218 | q <- asks _q | 218 | q <- asks _q |
219 | publicAddr <- asks _publicAddr | 219 | publicAddr <- asks _publicAddr |
220 | return $ forwardNoteEvent h q publicAddr | 220 | return $ forwardNoteEvent h q publicAddr |
221 | 221 | ||
222 | processMidi :: RWST LoopEnv () LoopState IO () | 222 | processMidi :: MidiController () |
223 | processMidi = do | 223 | processMidi = do |
224 | h <- asks _h | 224 | h <- asks _h |
225 | oldKeys <- gets keysDown | 225 | oldKeys <- gets keysDown |
@@ -256,7 +256,7 @@ latestEvent (StartRecording x) = x | |||
256 | latestEvent (RecordingInProgress _ x []) = x | 256 | latestEvent (RecordingInProgress _ x []) = x |
257 | latestEvent (RecordingInProgress _ _ ((x,_):_)) = x | 257 | latestEvent (RecordingInProgress _ _ ((x,_):_)) = x |
258 | 258 | ||
259 | maybeReadLine :: RWST LoopEnv () LoopState IO (Maybe String) | 259 | maybeReadLine :: MidiController (Maybe String) |
260 | maybeReadLine = asks _lineReader >>= liftIO . tryTakeMVar | 260 | maybeReadLine = asks _lineReader >>= liftIO . tryTakeMVar |
261 | 261 | ||
262 | startLineReader :: IO (MVar String) | 262 | startLineReader :: IO (MVar String) |