midimory-0.0.1: src/MIDI.hs

module MIDI where

import qualified Sound.ALSA.Sequencer.Connect as Connect
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.Time as Time
import qualified Sound.ALSA.Sequencer.RealTime as RealTime
import qualified Sound.ALSA.Sequencer as SndSeq
import qualified Sound.ALSA.Exception as AlsaExc

import qualified System.IO as IO

import Control.Monad.HT ((<=<))


{-
The queue is required by the ANote event type.
-}
data Sequencer =
   Sequencer (SndSeq.T SndSeq.OutputMode) Queue.T Port.T Event.Channel


sendNote :: Sequencer -> Event.Pitch -> IO ()
sendNote h@(Sequencer _ _ _ chan) p = do
   sendEvent h $
      Event.NoteEv Event.ANote $ Event.Note {
         Event.noteChannel = chan,
         Event.noteNote = p,
         Event.noteVelocity = Event.normalVelocity,
         Event.noteOffVelocity = Event.normalVelocity,
         Event.noteDuration = Event.Duration 1000
      }


sendEvent ::
   Sequencer -> Event.Data -> IO ()
sendEvent (Sequencer h q p _) ev = do
   c <- Client.getId h
   _ <-
      Event.outputDirect h $
      (Event.simple (Addr.Cons c p) ev) {
         Event.queue = q,
         Event.time = Time.consRel $ Time.Real $ RealTime.fromDouble 0
       }
   return ()

parseAndConnect :: Sequencer -> String -> IO Connect.T
parseAndConnect (Sequencer h _ p _) =
   Connect.createTo h p <=< Addr.parse h


withSequencer ::
   String -> Event.Channel -> (Sequencer -> IO ()) -> IO ()
withSequencer name chan act =
   flip AlsaExc.catch
      (\e -> IO.hPutStrLn IO.stderr $ "alsa_exception: " ++ AlsaExc.show e) $ do
   SndSeq.with SndSeq.defaultName SndSeq.Block $ \h -> do
   Client.setName h name
   Queue.with h $ \q -> do
   Queue.control h q Event.QueueStart Nothing
   _ <- Event.drainOutput h
   Port.withSimple h "inout"
      (Port.caps [Port.capRead, Port.capSubsRead,
                  Port.capWrite, Port.capSubsWrite]) Port.typeApplication $ \ port -> do
   act $ Sequencer h q port chan