factor functions into separate module AlsaSeq.hs

1 files changed, 3 insertions, 134 deletions

diff --git a/midi-dump.hs b/midi-dump.hs
index d463750..3de065b 100644
--- a/midi-dump.hs
+++ b/midi-dump.hs
@@ -1,139 +1,8 @@
+import AlsaSeq
+import Control.Concurrent (threadDelay)
 import qualified Sound.ALSA.Exception as AlsaExc
-import qualified Sound.ALSA.Sequencer.Address as Addr
-import qualified Sound.ALSA.Sequencer as SndSeq
-import qualified Sound.ALSA.Sequencer.Client as Client
-import qualified Sound.ALSA.Sequencer.Client.Info as ClientInfo
-import qualified Sound.ALSA.Sequencer.Port.Info as PortInfo
-import qualified Sound.ALSA.Sequencer.Connect as Connect
-import qualified Sound.ALSA.Sequencer.Event as Event
-import qualified Sound.ALSA.Sequencer.Event.RemoveMonad as Remove
-import qualified Sound.ALSA.Sequencer.Port as Port
-import qualified Sound.ALSA.Sequencer.Port.InfoMonad as PortInfoM
-import qualified Sound.ALSA.Sequencer.Queue as Queue
-import qualified Sound.ALSA.Sequencer.RealTime as RealTime
-import qualified Sound.ALSA.Sequencer.Time as Time
-import qualified System.Exit as Exit
-import qualified System.IO as IO
-import System.Environment (getArgs, )
-import Text.Printf
-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
-
-printWords [] = return () -- print nothing if no words (not an empty line)
-printWords ls = putStrLn $ joinWords ls
-
-showPitch x = 
-  let (octave, pitch) = Haskore.Basic.Pitch.fromInt $ fromIntegral x
-  in Haskore.Basic.Pitch.classFormat pitch (show octave)
-
-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
-    in
-      printf "%d(%d)" pitch vlcty
-
-showPorts ls = joinWords $ map (show . head) $ group $ sort ls
-
-showAlsaPorts h = do
-  c <- alsaClients h
-  putStrLn ""
-  printf "%15s   %s\n" "Ports" "Names"
-  printf "%15s   %s\n" "=====" "====="
-  forM c (\(name, ports) -> printf "%15s   %s\n" (showPorts ports) name)
-  putStrLn ""
-
-alsaClients h = do
-  portsNames <- ClientInfo.queryLoop h $ \cinfo -> do
-    ports <- alsaClientPorts h cinfo
-    name <- ClientInfo.getName cinfo
-    return (name, ports)
-  return portsNames
-
-alsaClientPorts h cinfo = do
-  client <- ClientInfo.getClient cinfo
-  ports <- PortInfo.queryLoop h client $ \pinfo -> do
-    c <- PortInfo.getClient pinfo
-    let (Client.Cons p) = c in
-      return p
-  return ports
-
-alsaInit k = do
-  SndSeq.withDefault SndSeq.Nonblock $ \h -> do
-
-  Client.setName (h :: SndSeq.T SndSeq.DuplexMode) "Haskell Beats" -- In imperative language MIDI sequencer, you rock beat.  In Haskell language MIDI sequencer, rock beat you!
-
-  Port.withSimple h "inout"
-     (Port.caps [Port.capRead, Port.capSubsRead, Port.capWrite, Port.capSubsWrite])
-     (Port.types [Port.typeMidiGeneric, Port.typeApplication]) $ \public -> do
-  Port.withSimple h "private"
-     (Port.caps [Port.capRead, Port.capWrite])
-     (Port.types [Port.typeMidiGeneric]) $ \private -> do
-  Queue.with h $ \q -> do
-
-  PortInfoM.modify h public $ do
-     PortInfoM.setTimestamping True
-     PortInfoM.setTimestampReal True
-     PortInfoM.setTimestampQueue q
-
-  c <- Client.getId h
-  let publicAddr  = Addr.Cons c public
-      privateAddr = Addr.Cons c private
-
-  Queue.control h q Event.QueueStart Nothing
-
-  k h public private q publicAddr privateAddr
-
-cmdlineAlsaConnect h public = do
-  args <- getArgs
-  case args of
-
-     [input, output] -> do
-        (Connect.createFrom h public =<< Addr.parse h input)
-        (Connect.createTo   h public =<< Addr.parse h output)
-        return ()
-
-     _ -> do
-        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
-      else do
-        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
 
   alsaInit $ \h public private q publicAddr privateAddr -> do
@@ -146,7 +15,7 @@ main = (do
       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'
+        printChordLn keysDown'
       go keysDown'
 
   putStrLn "Rock on!"