From e19c35c8a7125b53688d056bfd5cf8a276590228 Mon Sep 17 00:00:00 2001
From: Andrew Cady <d@jerkface.net>
Date: Wed, 15 Jan 2014 07:32:00 -0500
Subject: add list of alsa clients to usage error

TODO: make it default to AXiS -> FluidSynth, if available.
---
 midi-dump.hs | 55 +++++++++++++++++++++++++++++++++++++++++++++----------
 1 file changed, 45 insertions(+), 10 deletions(-)

(limited to 'midi-dump.hs')

diff --git a/midi-dump.hs b/midi-dump.hs
index 436644c..2c8d430 100644
--- a/midi-dump.hs
+++ b/midi-dump.hs
@@ -2,11 +2,13 @@ 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 PortInfo
+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
@@ -14,11 +16,16 @@ 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)
 
-printWords [] = return ()
-printWords ls = putStrLn $ foldr1 (\a b -> a ++ " " ++ b) ls
+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
 
 pitchWords set = map (show . Event.unPitch) $ Set.toList set
 
@@ -29,9 +36,36 @@ prettyNote (Event.Note noteChannel noteNote noteVelocity noteOffVelocity noteDur
     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-Beat"
+
+  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
@@ -40,10 +74,10 @@ alsaInit k = do
      (Port.types [Port.typeMidiGeneric]) $ \private -> do
   Queue.with h $ \q -> do
 
-  PortInfo.modify h public $ do
-     PortInfo.setTimestamping True
-     PortInfo.setTimestampReal True
-     PortInfo.setTimestampQueue q
+  PortInfoM.modify h public $ do
+     PortInfoM.setTimestamping True
+     PortInfoM.setTimestampReal True
+     PortInfoM.setTimestampQueue q
 
   c <- Client.getId h
   let publicAddr  = Addr.Cons c public
@@ -67,8 +101,9 @@ main = (do
         return ()
 
      _ -> do
-       IO.hPutStrLn IO.stderr "need arguments: input-client output-client"
-       Exit.exitFailure
+	showAlsaPorts h
+	IO.hPutStrLn IO.stderr "need arguments: input-port output-port"
+	Exit.exitFailure
 
   let wait keysDown = do
       pending <- Event.inputPending h True
-- 
cgit v1.2.3