factor out new function: forwardNoteEvent

1 files changed, 27 insertions, 24 deletions

diff --git a/midi-dump.hs b/midi-dump.hs
index b94b178..d463750 100644
--- a/midi-dump.hs
+++ b/midi-dump.hs
@@ -38,7 +38,7 @@ pitchWords set = map (showPitch . Event.unPitch) $ Set.toList set
 prettyNote :: Event.Note -> String
 prettyNote (Event.Note noteChannel noteNote noteVelocity noteOffVelocity noteDuration) =
     let pitch = Event.unPitch noteNote
-        vlcty = Event.unVelocity noteVelocity
+        vlcty = Event.unVelocity noteVelocity
     in
       printf "%d(%d)" pitch vlcty
 
@@ -103,26 +103,35 @@ cmdlineAlsaConnect h public = do
         return ()
 
      _ -> do
-        showAlsaPorts h
-        IO.hPutStrLn IO.stderr "need arguments: input-port output-port"
-        Exit.exitFailure
+        showAlsaPorts h
+        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
+        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
+        ev <- Event.input h
+        case Event.body ev of
+           Event.NoteEv Event.NoteOn n  -> do
+             immediate ev
+             loop (Set.insert (Event.noteNote n) keysDown)
+           Event.NoteEv Event.NoteOff n -> do
+             immediate ev
+             loop (Set.delete (Event.noteNote n) keysDown)
+           _ -> loop keysDown
+
+forwardNoteEvent h q publicAddr ev = do
+  let mkEv e = (Event.simple publicAddr e) { Event.queue = q, Event.time = Time.consAbs $ Time.Real $ RealTime.fromDouble 0 }
+  let immediate = \a b c -> do { Event.output h $ mkEv $ a b c; _ <- Event.drainOutput h; return (); }
+  case Event.body ev of
+     Event.NoteEv Event.NoteOn  n -> immediate Event.NoteEv Event.NoteOn n
+     Event.NoteEv Event.NoteOff n -> immediate Event.NoteEv Event.NoteOff n
+     -- TODO: forward other event types?
+     _ -> return ()
 
 main :: IO ()
 main = (do
@@ -130,20 +139,14 @@ main = (do
   alsaInit $ \h public private q publicAddr privateAddr -> do
   cmdlineAlsaConnect h public
 
-  let mkEv e =
-         (Event.simple publicAddr e) {
-             Event.queue = q,
-             Event.time = Time.consAbs $ Time.Real $ RealTime.fromDouble 0
-         }
-
   let
+    forwardNOW = forwardNoteEvent h q publicAddr
     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
+      keysDown' <- parseAlsaEvents h keysDown forwardNOW
       if (keysDown == keysDown') then
-        threadDelay 15000 -- 15ms.  Seems like a lot, but it sounds OK.  Cuts CPU down to 2%.
+        threadDelay 15000 -- 15ms.  Seems like a lot, but it sounds OK.  Cuts CPU down to 2%.
       else do
-        printWords $ pitchWords keysDown'
+        printWords $ pitchWords keysDown'
       go keysDown'
 
   putStrLn "Rock on!"