alsa-seq-0.5: examples/test5.hs

import qualified Sound.ALSA.Sequencer.Address as Addr
import qualified Sound.ALSA.Sequencer.Client as Client
import qualified Sound.ALSA.Sequencer.Port as Port
import qualified Sound.ALSA.Sequencer.Event as Event
import qualified Sound.ALSA.Sequencer.Queue as Queue
import qualified Sound.ALSA.Sequencer as SndSeq
import qualified Sound.ALSA.Exception as AlsaExc

import Control.Monad (zipWithM_, )


main :: IO ()
main = (do
  SndSeq.with SndSeq.defaultName SndSeq.Block $ \h -> do
  Client.setName (h :: SndSeq.T SndSeq.DuplexMode) "HS5"
  Port.withSimple h "1"
     (Port.caps [Port.capRead, Port.capSubsRead, Port.capWrite])
     (Port.types [Port.typeMidiGeneric, Port.typeApplication]) $ \p -> do
  c <- Client.getId h
  Queue.with h $ \q -> do
  let ev t e = Event.Cons
                 { Event.highPriority = False
                 , Event.tag = 0
                 , Event.queue = q
                 , Event.timestamp = Event.TickTime t
                 , Event.source = Addr.Cons { Addr.client = c, Addr.port = p }
                 , Event.dest = Addr.subscribers
                 , Event.body = e
                 }
      play t chan pitch vel =
           do print =<< Event.output h (ev t $
                 Event.NoteEv Event.NoteOn $ Event.simpleNote chan pitch vel)

              print =<< Event.output h (ev (t+1) $
                 Event.NoteEv Event.NoteOn $ Event.simpleNote chan pitch 0)

      echo t =
         print =<< Event.output h
            ((ev t $ Event.CustomEv Event.Echo $ Event.Custom 0 0 0){
               Event.dest = Addr.Cons { Addr.client = c, Addr.port = p }
            })

  putStrLn "Please connect me to a synth"
  getChar
  Queue.control h q Event.QueueStart 0 Nothing
  Queue.control h q Event.QueueTempo 10000000 Nothing
  zipWithM_ (\t ->
        maybe (echo t) (\n -> play t 0 n 127)) [0..] $
     (++[Nothing]) $
     concat $ concatMap (replicate 4 . map Just) $
        [57, 59, 60, 64] :
        [57, 59, 60, 65] :
        [57, 62, 64, 65] :
        [57, 59, 60, 64] :
        []
  Event.drainOutput h
  print =<< Event.outputPending h

--          threadDelay 10000000
  let waitForEcho = do
         event <- Event.input h
         print event
         case Event.body event of
            Event.CustomEv Event.Echo _d -> return ()
            _ -> waitForEcho
  waitForEcho)

  `AlsaExc.catch` \e ->
     putStrLn $ "alsa_exception: " ++ AlsaExc.show e