move threadDelay mechanism to main loop

1 files changed, 37 insertions, 30 deletions

diff --git a/midi-dump.hs b/midi-dump.hs
index 5e0859b..0adef56 100644
--- a/midi-dump.hs
+++ b/midi-dump.hs
@@ -187,13 +187,28 @@ main' = withAlsaInit $ \h public private q publicAddr privateAddr -> do
 
 mainLoop :: MidiController ()
 mainLoop = do
+  tick <- getAbsTime
+  modify $ \s -> s { _lastTick = tick }
+
   maybeReadLine >>= maybe processMidi processCommand
   wantExit <- gets _wantExit
   metronome
   playScheduled
+
   if wantExit
     then waitThreads
-    else mainLoop
+    else delay >> mainLoop
+
+  where
+    tickDuration = 5000 -- 5ms
+    delay = do
+      before <- gets _lastTick
+      after <- getAbsTime
+      if after - before < fromIntegral (10^(6::Int) * tickDuration) then
+        liftIO $ threadDelay $ tickDuration - fromIntegral (nsec after - nsec before) `div` 1000
+      else
+        liftIO $ putStrLn "Uh oh!  Dropped frame!"
+      mainLoop
 
 waitThreads :: MidiController ()
 waitThreads = gets _waitThreads >>= mapM_ liftIO
@@ -375,43 +390,35 @@ getMidiSender = do
 
 processMidi :: MidiController ()
 processMidi = do
-  h                 <- asks _h
-  oldKeys           <- gets _keysDown
-  forwardNOW        <- getMidiSender
+  h <- asks _h
+  oldKeys <- gets _keysDown
+  forwardNOW <- getMidiSender
   (events, newKeys) <- liftIO $ parseAlsaEvents'' h oldKeys forwardNOW
 
+  when (oldKeys /= newKeys) $ do
+    now <- gets _lastTick
+    let newEvents = map ((,) now . Event.body) events
 
-  if oldKeys == newKeys
-    then liftIO $ threadDelay 15000 -- 15ms. Seems like a lot, but it sounds OK. Cuts CPU down to 2%.
-    else do
-      now <- getAbsTime
-      let newEvents = map ((,) now . Event.body) events
-
-      modify $ \s ->
-        s
-          { _keysDown = newKeys
-          , _recording = recordEvents (_recording s) newEvents
-          , _lastTick = now
-          }
+    modify $ \s -> s { _keysDown = newKeys, _recording = recordEvents (_recording s) newEvents }
 
-      whenFlag _printChordKeys $ liftIO $ printChordLn' newKeys
+    whenFlag _printChordKeys $ liftIO $ printChordLn' newKeys
 
-      filterTriads newKeys
+    filterTriads newKeys
 
-      -- Whenever no keys are pressed, flush any buffered events to the database
-      when (Map.null newKeys) $ do
-        doSave <- asks _doSave
-        when doSave $ gets _recording >>= saveMidi >> return ()
-        modify $ \s -> s { _recording = StartRecording now }
+    -- Whenever no keys are pressed, flush any buffered events to the database
+    when (Map.null newKeys) $ do
+      doSave <- asks _doSave
+      when doSave $ gets _recording >>= saveMidi >> return ()
+      modify $ \s -> s { _recording = StartRecording now }
 
-      -- When a key is pressed after 3+ seconds of silence, overwrite the replay buffer with the new keys
-      when (Map.null oldKeys) $ do
-        replay <- gets _replay
-        when (latestEvent replay < (now - TimeSpec 3 0)) $ do
-          modify $ \s -> s { _replay = StartRecording now }
-          return ()
+    -- When a key is pressed after 3+ seconds of silence, overwrite the replay buffer with the new keys
+    when (Map.null oldKeys) $ do
+      replay <- gets _replay
+      when (latestEvent replay < (now - TimeSpec 3 0)) $ do
+        modify $ \s -> s { _replay = StartRecording now }
+        return ()
 
-      modify $ \s -> s { _replay = recordEvents (_replay s) newEvents }
+    modify $ \s -> s { _replay = recordEvents (_replay s) newEvents }
 
 filterTriads :: MidiPitchMap -> MidiController ()
 filterTriads newKeys = do