use RealTimeQueue for queuing midi output to ALSA

2 files changed, 31 insertions, 11 deletions

diff --git a/axis-of-eval.cabal b/axis-of-eval.cabal
index 7a879dd..fa1049d 100644
--- a/axis-of-eval.cabal
+++ b/axis-of-eval.cabal
@@ -36,7 +36,8 @@ executable midi-dump
   hs-source-dirs: .
   build-depends:
     base, time, containers, haskore, alsa-seq, alsa-core, mtl, clock,
-    sqlite-simple, bytestring, base-prelude, midi-alsa, midi
+    sqlite-simple, bytestring, base-prelude, midi-alsa, midi, psqueues,
+    transformers, semigroups
   main-is: midi-dump.hs
-  other-modules: AlsaSeq
+  other-modules: AlsaSeq, Midi, RealTimeQueue
   ghc-options: -threaded -W -Wall -O2
diff --git a/midi-dump.hs b/midi-dump.hs
index f332482..536d78d 100644
--- a/midi-dump.hs
+++ b/midi-dump.hs
@@ -29,6 +29,7 @@ import qualified Sound.ALSA.Sequencer.Time as Time
 import qualified Sound.ALSA.Sequencer.RealTime as RealTime
 
 import Midi
+import RealTimeQueue as Q hiding (null)
 
 verbose :: Bool
 verbose = False
@@ -42,13 +43,14 @@ data LoopState = LoopState {
   _wantExit  :: Bool,
   keysDown   :: MidiPitchSet,
   _playNOW   :: [Event.Data],
+  _scheduled :: Q.Queue Event.Data,
   _recording :: Recording,
   _replay    :: Recording,
   _lastTick   :: TimeSpec
 }
 
 initializeState :: TimeSpec -> LoopState
-initializeState now = LoopState False Set.empty [] (StartRecording now) (StartRecording now) now
+initializeState now = LoopState False Set.empty [] createQueue (StartRecording now) (StartRecording now) now
 
 data LoopEnv = LoopEnv {
   _saver         :: Chan CompleteRecording,
@@ -131,14 +133,23 @@ mainLoop = do
   maybeReadLine >>= maybe processMidi processCommand
   wantExit <- gets _wantExit
 
-  scheduled <- gets _playNOW
-  unless (null scheduled) $ do
-    forM_ scheduled playNoteEv
-    -- TODO: flush ALSA output here (and remove flush from playNoteEv)
-    modify $ \s -> s { _playNOW = [] }
+  playImmediates
+  playScheduled
 
   unless wantExit mainLoop
 
+playScheduled :: MidiController ()
+playScheduled = queueAction $ runScheduledIO (TimeSpec 1 0) $ uncurry alsaDelayNoteEv
+-- TODO: flush ALSA output here (and remove flush from playNoteEv)
+
+playImmediates :: MidiController ()
+playImmediates = do
+  immediate <- gets _playNOW
+  unless (null immediate) $ do
+    forM_ immediate playNoteEv
+    -- TODO: flush ALSA output here (and remove flush from playNoteEv)
+    modify $ \s -> s { _playNOW = [] }
+
 _playNote :: Bool -> Event.Note -> RWST LoopEnv () LoopState IO ()
 _playNote noteOn note =
   playNoteEv $ Event.NoteEv onoff note
@@ -149,14 +160,22 @@ delayEvent evt ts = evt {Event.time = Time.consRel $ Time.Real (RealTime.fromInt
   where nanosecs = timeSpecAsNanoSecs ts
 
 playNoteEv :: Event.Data -> RWST LoopEnv () LoopState IO ()
-playNoteEv = delayNoteEv (TimeSpec 0 0)
+playNoteEv = alsaDelayNoteEv (TimeSpec 0 0)
 
-delayNoteEv :: TimeSpec -> Event.Data -> RWST LoopEnv () LoopState IO ()
-delayNoteEv delay nevdata = do
+alsaDelayNoteEv :: TimeSpec -> Event.Data -> RWST LoopEnv () LoopState IO ()
+alsaDelayNoteEv delay nevdata = do
   ms <- getMidiSender
   publicAddr <- asks _publicAddr
   liftIO $ ms $ Event.simple publicAddr nevdata `delayEvent` delay
 
+queueAction :: (Queue Event.Data -> MidiController (Queue Event.Data)) -> MidiController ()
+queueAction act = do
+    q <- gets _scheduled
+    act q >>= \q' -> modify $ \s -> s { _scheduled = q' }
+
+delayNoteEv :: TimeSpec -> Event.Data -> RWST LoopEnv () LoopState IO ()
+delayNoteEv delay nevdata = queueAction $ scheduleEventIO (delay, nevdata)
+
 _whenFlag :: forall (m :: * -> *) s. MonadState s m => (s -> Bool) -> m () -> m ()
 _whenFlag flag f = gets flag >>= flip when f