alsa-midi-0.3: examples/PlayMIDI.hs

module Main where

import qualified Sound.ALSA.Sequencer    as SndSeq
import qualified Sound.ALSA.SequencerFFI as SndSeqFFI

import qualified Sound.MIDI.File      as MIDIFile
import qualified Sound.MIDI.File.Load as MIDILoad

import qualified Data.EventList.Relative.TimeBody as EventList
import qualified Numeric.NonNegative.Wrapper as NonNeg

import Control.Concurrent (threadDelay)
import Control.Exception (bracket)
-- import Control.Monad.Error ()  -- Monad instance for Either
import Control.Monad (when)

import System.Console.GetOpt (getOpt, ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo)
import System.Environment (getArgs)


mkEvent ::
   SndSeqFFI.Queue ->
   SndSeqFFI.Address -> SndSeqFFI.Address ->
   MIDIFile.Event -> SndSeqFFI.Event
mkEvent queue srcAddress dstAddress ev =
   let (typ, dat) = SndSeq.eventFromMIDIEvent queue ev
   in  SndSeqFFI.Event {
          SndSeqFFI.typ = typ,
          SndSeqFFI.tag = 0,
          SndSeqFFI.queue = SndSeqFFI.queueDirect,
          SndSeqFFI.time  = SndSeqFFI.TimeStampTick (SndSeqFFI.TickTime 0),
          SndSeqFFI.timeMode = SndSeqFFI.TimeModeRelative,
          SndSeqFFI.eventLength = SndSeqFFI.EventLengthFixed,
          SndSeqFFI.priority = SndSeqFFI.PriorityNormal,
          SndSeqFFI.source = srcAddress,
          SndSeqFFI.dest   = dstAddress,
          SndSeqFFI.eventData = dat}


play :: SndSeqFFI.Address -> FilePath -> IO ()
play dstAddress fileName =
   do MIDIFile.Cons typ _div tracks <- MIDILoad.fromFile fileName
      -- print midi

      let track =
             case typ of
                MIDIFile.Parallel -> foldl EventList.merge EventList.empty tracks
                MIDIFile.Serial   -> EventList.concat tracks
                MIDIFile.Mixed    -> EventList.concat tracks

      bracket
         (SndSeq.createClient SndSeqFFI.openOutput "midi player")
         SndSeq.deleteClient $
         \ client ->
         SndSeq.withNamedQueue client "playmidi out queue" $
         \ queue ->
             do putStrLn "playing"
                port <- SndSeq.createOutputPort client "player output"
                let srcAddress = SndSeq.portAddress client port
                EventList.mapM_
                   (threadDelay . (5000*) . fromInteger . NonNeg.toNumber)
                   (\ev ->
                       (SndSeq.sendPlainEvent client $
                          let seqEv = mkEvent queue srcAddress dstAddress ev
                          in  case ev of
                                 MIDIFile.MetaEvent (MIDIFile.SetTempo _) ->
                                      seqEv{SndSeqFFI.dest = SndSeqFFI.addressTimer}
                                 _ -> seqEv)
                         >> SndSeq.drainOutput client)
                   track



parseAddress :: String -> Either String SndSeqFFI.Address
parseAddress str0 =
   let addrs =
          do (client, ':':str1) <- reads str0
             (port, [])         <- reads str1
             return $ SndSeq.numAddressEither client port
   in  case addrs of
          [addr] -> addr
          _      -> Left "address must be a string like '128:0'"

{-
parseAddressNaive :: String -> SndSeqFFI.Address
parseAddressNaive str =
   let (client, ':':port) = break (':'==) str
   in  SndSeqFFI.Address (read client) (read port)
-}


data Flags =
   Flags {
      optHelp :: Bool,
      optPort :: Either String SndSeqFFI.Address
     }

options :: [OptDescr (Flags -> Flags)]
options =
   Option ['h']     ["help"]    (NoArg (\ flags -> flags{optHelp = True}))  "show options" :
   Option ['p']     ["port"]    (ReqArg (\str flags -> flags{optPort = parseAddress str}) "PORT")  "destination PORT" :
   []

main :: IO ()
main =
   do argv <- getArgs
      let (opts, files, errors) = getOpt RequireOrder options argv
      when (not (null errors))
         (ioError . userError . concat $ errors)
      let flags = foldr ($)
            (Flags {optHelp = False,
                    optPort = Left "no port specified"}) opts
      when (optHelp flags)
         (putStrLn (usageInfo "Usage: playmidi [OPTIONS] FILES ..." options))
      port <-
         either
            (ioError . userError)
            return
            (optPort flags)
      mapM_ (play port) files