mididump will use RSWT for main loop

1 files changed, 25 insertions, 14 deletions

diff --git a/midi-dump.hs b/midi-dump.hs
index a5a3d9c..1a331e8 100644
--- a/midi-dump.hs
+++ b/midi-dump.hs
@@ -4,30 +4,41 @@ import qualified Sound.ALSA.Exception as AlsaExc
 import qualified Data.Set as Set
 import qualified Haskore.Basic.Pitch as Pitch
 import qualified Sound.ALSA.Sequencer.Event as Event
+import Control.Monad.RWS.Strict
 
 main = main' `AlsaExc.catch` handler
   where
   handler e = putStrLn $ "alsa_exception: " ++ AlsaExc.show e
 
-data State = State {
+data LoopState = LoopState {
   keysDown :: MidiPitchSet,
   inputHistory :: [Maybe Event.T]
 }
 
+emptyLoopState = LoopState Set.empty []
+
 main' = withAlsaInit $ \h public private q publicAddr privateAddr -> do
   cmdlineAlsaConnect h public
 
-  let
-    forwardNOW = forwardNoteEvent h q publicAddr
-    go state = do
-      (events, keysDown') <- parseAlsaEvents' h (keysDown state) forwardNOW
-      if ((keysDown state) == keysDown') then
-        threadDelay 15000 -- 15ms.  Seems like a lot, but it sounds OK.  Cuts CPU down to 2%.
-      else do
-        let newHistory = if (Set.null $ keysDown state) then Nothing:newEvents else newEvents
-            newEvents = map Just events
-        printChordLn keysDown'
-        go (state { keysDown = keysDown', inputHistory = newHistory ++ inputHistory state })
-
   putStrLn "Rock on!"
-  go (State Set.empty [])
+
+  (s, ()) <- execRWST loop (h, public, private, q, publicAddr, privateAddr) emptyLoopState
+  return ()
+
+loop = do
+  (h, public, private, q, publicAddr, privateAddr) <- ask
+  loopState <- get
+  oldKeys <- gets keysDown
+  let forwardNOW = forwardNoteEvent h q publicAddr
+
+  (events, newKeys) <- liftIO $ parseAlsaEvents' h oldKeys forwardNOW
+
+  if (oldKeys == newKeys) then
+    liftIO $ threadDelay 15000 -- 15ms.  Seems like a lot, but it sounds OK.  Cuts CPU down to 2%.
+  else do
+    let newHistory = if Set.null oldKeys then Nothing:newEvents else newEvents
+        newEvents = map Just events
+    liftIO $ printChordLn newKeys
+    put loopState { keysDown = newKeys, inputHistory = newHistory ++ inputHistory loopState }
+
+  loop