factor out new function: parseAlsaEvents

1 files changed, 27 insertions, 19 deletions

diff --git a/midi-dump.hs b/midi-dump.hs
index 50f0020..b94b178 100644
--- a/midi-dump.hs
+++ b/midi-dump.hs
@@ -21,6 +21,7 @@ import Control.Monad (when, forM_, forM)
 import qualified Data.Set as Set
 import Data.List (group, sort)
 import Haskore.Basic.Pitch
+import Control.Concurrent (threadDelay)
 
 joinWords [] = ""
 joinWords ls = foldr1 (\a b -> a ++ " " ++ b) ls
@@ -106,37 +107,44 @@ cmdlineAlsaConnect h public = do
         IO.hPutStrLn IO.stderr "need arguments: input-port output-port"
         Exit.exitFailure
 
+parseAlsaEvents h keysDown immediate = loop keysDown
+  where
+    loop keysDown = do
+      pending <- Event.inputPending h True
+      if (pending == 0) then
+        return keysDown
+      else do
+        ev <- Event.input h
+        case Event.body ev of
+           Event.NoteEv Event.NoteOn n  -> do
+             immediate Event.NoteEv Event.NoteOn n
+             loop (Set.insert (Event.noteNote n) keysDown)
+           Event.NoteEv Event.NoteOff n -> do
+             immediate Event.NoteEv Event.NoteOff n
+             loop (Set.delete (Event.noteNote n) keysDown)
+           _ -> loop keysDown
+
 main :: IO ()
 main = (do
 
   alsaInit $ \h public private q publicAddr privateAddr -> do
   cmdlineAlsaConnect h public
 
-  let wait keysDown = do
-      pending <- Event.inputPending h True
-      if (pending > 0)
-      then do
-        ev <- Event.input h
-        case Event.body ev of
-           Event.NoteEv Event.NoteOn n  -> return (Event.NoteOn,  n, Set.insert (Event.noteNote n) keysDown)
-           Event.NoteEv Event.NoteOff n -> return (Event.NoteOff, n, Set.delete (Event.noteNote n) keysDown)
-           _ -> wait keysDown
-      else
-        wait keysDown
-
   let mkEv e =
          (Event.simple publicAddr e) {
              Event.queue = q,
              Event.time = Time.consAbs $ Time.Real $ RealTime.fromDouble 0
          }
 
-  let go keysDown = do
-      (onoff, note, down) <- wait keysDown
-      --putStrLn $ prettyNote note
-      printWords $ pitchWords down
-      Event.output h $ mkEv $ Event.NoteEv onoff note
-      _ <- Event.drainOutput h
-      go down
+  let
+    go keysDown = do
+      let immediate = \a b c -> do { Event.output h $ mkEv $ a b c; _ <- Event.drainOutput h; return (); }
+      keysDown' <- parseAlsaEvents h keysDown immediate
+      if (keysDown == keysDown') then
+        threadDelay 15000 -- 15ms.  Seems like a lot, but it sounds OK.  Cuts CPU down to 2%.
+      else do
+        printWords $ pitchWords keysDown'
+      go keysDown'
 
   putStrLn "Rock on!"
   go Set.empty)