Implement replay functionality

(Replay last MIDI input, divided by 3 second periods of silence.)

This has a bug where if there is too much input to replay, the program
exits.  (Oddly, there is no exit failure code.)

I think this is because the kernel ALSA buffer is full.  The solution is
to implement in-application queueing.

1 files changed, 37 insertions, 16 deletions

diff --git a/midi-dump.hs b/midi-dump.hs
index 07281f5..07dfb1c 100644
--- a/midi-dump.hs
+++ b/midi-dump.hs
@@ -14,7 +14,6 @@ import qualified Sound.ALSA.Sequencer.Event     as Event
 import           System.Clock
 
 import           Control.Applicative
-import           Data.Int
 import           Database.SQLite.Simple
 import           Database.SQLite.Simple.FromRow ()
 
@@ -145,33 +144,51 @@ _playNote noteOn note =
   playNoteEv $ Event.NoteEv onoff note
   where onoff = if noteOn then Event.NoteOn else Event.NoteOff
 
-delayEvent :: Event.T -> Integer -> Event.T
-delayEvent evt nanosecs = evt {Event.time = Time.consRel $ Time.Real (RealTime.fromInteger nanosecs)}
+delayEvent :: Event.T -> TimeSpec -> Event.T
+delayEvent evt ts = evt {Event.time = Time.consRel $ Time.Real (RealTime.fromInteger nanosecs)}
+  where nanosecs = timeSpecAsNanoSecs ts
 
 playNoteEv :: Event.Data -> RWST LoopEnv () LoopState IO ()
-playNoteEv nevdata = do
+playNoteEv = delayNoteEv (TimeSpec 0 0)
+
+delayNoteEv :: TimeSpec -> Event.Data -> RWST LoopEnv () LoopState IO ()
+delayNoteEv delay nevdata = do
   ms <- getMidiSender
   publicAddr <- asks _publicAddr
-  liftIO $ ms $ Event.simple publicAddr nevdata `delayEvent` (2 * 10^(9::Int))
+  liftIO $ ms $ Event.simple publicAddr nevdata `delayEvent` delay
 
 _whenFlag :: forall (m :: * -> *) s. MonadState s m => (s -> Bool) -> m () -> m ()
 _whenFlag flag f = gets flag >>= flip when f
 
-processCommand :: forall (m :: * -> *). (MonadIO m, MonadState LoopState m) => String -> m ()
+mkNote :: Word8 -> Event.Note
+mkNote pitch = Event.simpleNote (Event.Channel 0) (Event.Pitch pitch) (Event.Velocity 128)
+
+processCommand :: String -> RWST LoopEnv () LoopState IO ()
 processCommand "exit" = modify $ \s -> s { _wantExit = True }
-processCommand "" = return ()
+-- processCommand "" = return ()
+processCommand "" = gets _replay >>= playRecording
 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 "C'" = do
+  let notes = (Event.NoteEv Event.NoteOn . mkNote) <$> [60, 64, 67]
+  forM_ notes (delayNoteEv (TimeSpec 2 0))
+{-
+processCommand "C'" = do
   -- changing the duration seems to do nothing
   let mkNote pitch = Event.simpleNote (Event.Channel 0) (Event.Pitch pitch) (Event.Velocity 128)
       setDuration d note = note { Event.noteDuration = Event.Duration d }
   let notes = (Event.NoteEv Event.NoteOn . setDuration 4290000000 . mkNote) <$> [60, 64, 67]
   modify $ \s -> s { _playNOW = notes }
+-}
 processCommand str = liftIO $ putStrLn $ "Unknown command: " ++ str
 
+playRecording :: Recording -> RWST LoopEnv () LoopState IO ()
+playRecording (RecordingInProgress _ _ evts@(_:_)) =
+  mapM_ (uncurry delayNoteEv) (zip (subtract (head delays) <$> delays) events)
+  where (delays, events) = unzip $ fmap Event.body <$> reverse evts
+playRecording  _ = return ()
+
 getMidiSender :: RWST LoopEnv () LoopState IO MidiHook
 getMidiSender = do
   h <- asks _h
@@ -196,21 +213,25 @@ processMidi = do
     liftIO $ printChordLn newKeys
     modify $ \s -> s { keysDown = newKeys, _recording = recordEvents (_recording s) newEvents, lastTick = now }
 
-{-
+    when (Set.null newKeys) $ do
+
+      doSave <- asks _doSave
+      when doSave $ gets _recording >>= saveMidi >> return ()
+      modify $ \s -> s { _recording = StartRecording now }
 
     when (Set.null oldKeys) $ do
 
       replay <- gets _replay
-
-      when (lastEventTime replay < now - 10*10^9) $ do
+      when (latestEvent replay < (now - TimeSpec 3 0)) $ do
         modify $ \s -> s { _replay = StartRecording now }
--}
+        return ()
 
-    when (Set.null newKeys) $ do
+    modify $ \s -> s { _replay = recordEvents (_replay s) newEvents }
 
-      doSave <- asks _doSave
-      when doSave $ gets _recording >>= saveMidi >> return ()
-      modify $ \s -> s { _recording = StartRecording now }
+latestEvent :: Recording -> TimeSpec
+latestEvent (StartRecording x) = x
+latestEvent (RecordingInProgress _ x []) = x
+latestEvent (RecordingInProgress _ _ ((x,_):_)) = x
 
 maybeReadLine :: RWST LoopEnv () LoopState IO (Maybe String)
 maybeReadLine = asks _lineReader >>= liftIO . tryTakeMVar