add facility to queue midi output to synth

2 files changed, 39 insertions, 12 deletions

diff --git a/AlsaSeq.hs b/AlsaSeq.hs
index 7fff575..5b65967 100644
--- a/AlsaSeq.hs
+++ b/AlsaSeq.hs
@@ -193,6 +193,7 @@ forwardNoteEvent h q publicAddr ev = do
 
 -- data T = Cons { highPriority :: !Bool , tag :: !Tag , queue :: !Queue.T , time :: !Time.T , source :: !Addr.T , dest :: !Addr.T , body :: !Data } deriving Show
 
-  let (Event.Cons highPriority tag _ time _ _ body) = ev in Event.output h (Event.Cons highPriority tag q time publicAddr Addr.subscribers body)
+  let (Event.Cons highPriority tag _ time _ _ body) = ev
+  Event.output h (Event.Cons highPriority tag q time publicAddr Addr.subscribers body)
   Event.drainOutput h
   return ()
diff --git a/midi-dump.hs b/midi-dump.hs
index 747ae28..dd59a96 100644
--- a/midi-dump.hs
+++ b/midi-dump.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE FlexibleInstances  #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 import           AlsaSeq
@@ -48,11 +48,12 @@ recordEvents (Recording s orig) new = Recording s (new ++ orig)
 data LoopState = LoopState {
   _wantExit  :: Bool,
   keysDown   :: MidiPitchSet,
+  _playNOW   :: [Event.Data],
   _recording :: Recording,
   lastTick   :: TimeSpec
 }
 
-initializeState now = LoopState False Set.empty (emptyRecording now) now
+initializeState now = LoopState False Set.empty [] (emptyRecording now) now
 
 data LoopEnv = LoopEnv {
   _saver         :: Chan FinishedRecording,
@@ -101,25 +102,50 @@ main' = withAlsaInit $ \h public private q publicAddr privateAddr -> do
 
   let env = LoopEnv saver sqlite startTime startTimeReal h public private q publicAddr privateAddr doSave lineReader
 
-  (_, ()) <- execRWST loop env $ initializeState startTimeReal
+  (_, ()) <- execRWST mainLoop env $ initializeState startTimeReal
   return ()
-  where
-    loop = do
-      maybeReadLine >>= maybe processMidi processCommand
-      wantExit <- gets _wantExit
-      unless wantExit loop
+
+mainLoop = do
+  maybeReadLine >>= maybe processMidi processCommand
+  wantExit <- gets _wantExit
+
+  scheduled <- gets _playNOW
+  unless (null scheduled) $ do
+    forM_ scheduled playNoteEv
+    -- TODO: flush ALSA output here
+    modify $ \s -> s { _playNOW = [] }
+
+  unless wantExit mainLoop
+
+playNote noteOn note =
+  playNoteEv $ Event.NoteEv onoff note
+  where onoff = if noteOn then Event.NoteOn else Event.NoteOff
+
+playNoteEv nevdata = do
+  ms <- getMidiSender
+  publicAddr <- asks _publicAddr
+  liftIO $ ms $ Event.simple publicAddr nevdata
+
+whenFlag flag f = gets flag >>= flip when f
 
 processCommand "exit" = modify $ \s -> s { _wantExit = True }
 processCommand "" = return ()
+processCommand "C" = do
+  let mkNote pitch = Event.simpleNote (Event.Channel 0) (Event.Pitch pitch) (Event.Velocity 128)
+  let notes = (Event.NoteEv Event.NoteOn . mkNote) <$> [60, 64, 67]
+  modify $ \s -> s { _playNOW = notes }
 processCommand str = liftIO $ putStrLn $ "Unknown command: " ++ str
 
-processMidi = do
+getMidiSender = do
   h <- asks _h
   q <- asks _q
   publicAddr <- asks _publicAddr
+  return $ forwardNoteEvent h q publicAddr
 
+processMidi = do
+  h <- asks _h
   oldKeys <- gets keysDown
-  let forwardNOW = forwardNoteEvent h q publicAddr
+  forwardNOW <- getMidiSender
   (events, newKeys) <- liftIO $ parseAlsaEvents' h oldKeys forwardNOW
 
 
@@ -166,7 +192,7 @@ saveMidi recording = do
 
 startSaver sqlite = do
   chan <- liftIO newChan
-  thread <- liftIO $ forkIO (saver chan)
+  _thread <- liftIO $ forkIO (saver chan)
   return chan
   where
     saver chan = forever $ do