alsa-seq-0.5.1: examples/melody.hs

{- |
Play a melody.
Demonstrate how to wait on the end of a performance of events,
by sending an Echo message to ourselves.
-}
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 qualified System.Exit as Exit
import qualified System.IO as IO
import System.Environment (getArgs, )

import Control.Monad (zipWithM_, )


parseAndConnect ::
   (SndSeq.AllowOutput mode) =>
   SndSeq.T mode -> Port.T -> String -> IO Addr.T
parseAndConnect h p destStr = do
  dest <- Addr.parse h destStr
  SndSeq.connectTo h p dest
  return dest

main :: IO ()
main = (do
  SndSeq.with SndSeq.defaultName SndSeq.Block $ \h -> do
  Client.setName (h :: SndSeq.T SndSeq.DuplexMode) "Haskell-Melody"
  Port.withSimple h "out"
     (Port.caps [Port.capRead, Port.capSubsRead, Port.capWrite])
     (Port.types [Port.typeMidiGeneric, Port.typeApplication]) $ \p -> do
  Queue.with h $ \q -> do
  args <- getArgs
  dest <-
     case args of
        [] -> do
           putStrLn "Enter destination or connect to a synthesizer and hit ENTER"
           destStr <- getLine
           if null destStr
             then return Addr.subscribers
             else parseAndConnect h p destStr
        [destStr] ->
           parseAndConnect h p destStr
        _ ->
           IO.hPutStrLn IO.stderr "too many arguments"
           >>
           Exit.exitFailure

  c <- Client.getId h
  let me = Addr.Cons c p
      ev t e =
         (Event.simple me e) {
             Event.queue = q,
             Event.dest = dest,
             Event.timestamp = Event.TickTime t
          }
      play t chan pitch vel =
         Event.output h (ev t $
            Event.NoteEv Event.NoteOn $ Event.simpleNote chan pitch vel)
         >>
         Event.output h (ev (t+1) $
            Event.NoteEv Event.NoteOn $ Event.simpleNote chan pitch 0)
         >>
         return ()

      echo t =
         fmap (const ()) $ Event.output h
            ((ev t $ Event.CustomEv Event.Echo $ Event.Custom 0 0 0){
               Event.dest = me
            })

  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 64)) [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
  _ <- Event.outputPending h

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

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