Sequencer.hs

module Sound.ALSA.Sequencer (
     MIDIFile.Event(..),
     isNoteOn, isNoteOff,
     createClient,
     deleteClient,
     createInputPort,
     createOutputPort,
     withMIDIEvents,
     receiveMIDIEvent,

     sendPlainEvent,
     drainOutput,

     initQueueTempo,
     withNamedQueue,

     portAddress,
     numAddress,
     numAddressEither,
     -- constructors only for internal use
     Client(sequencerHandle),
     SndSeq.Port(..),

     eventFromMIDIEvent,
  ) where

import qualified Sound.ALSA.Sequencer.FFI as SndSeq

import qualified Sound.MIDI.File  as MIDIFile
import qualified Sound.MIDI.Event as MIDIEvent

import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Utils (with)
import Foreign.Storable (peek)
-- import Foreign.Ptr (Ptr)
import Foreign.C.String (withCString)
-- import Foreign.C.Types (CInt)
import Data.IORef (IORef, newIORef, readIORef, modifyIORef)

import Control.Exception (bracket)

import System.IO.Unsafe (unsafeInterleaveIO)
import Control.Monad (liftM, liftM2)
import Data.Maybe (catMaybes)
import Data.Ix (inRange)


isNoteOn :: MIDIFile.Event -> Bool
isNoteOn  = maybe False (MIDIEvent.isNoteOn  . snd) . MIDIFile.maybeMIDIEvent

isNoteOff :: MIDIFile.Event -> Bool
isNoteOff = maybe False (MIDIEvent.isNoteOff . snd) . MIDIFile.maybeMIDIEvent


clientId :: Client -> SndSeq.ClientId
clientId = SndSeq.client_id . sequencerHandle

data Client = Client {
    sequencerHandle :: SndSeq.T,
    ports :: IORef [SndSeq.Port]
  }

portAddress :: Client -> SndSeq.Port -> SndSeq.Address
portAddress = SndSeq.Address . clientId

numAddress :: Integer -> Integer -> SndSeq.Address
numAddress client port =
   either error id $ numAddressEither client port

numAddressEither :: Integer -> Integer -> Either String SndSeq.Address
numAddressEither client port =
   if inRange (128,191) client
     then
       if inRange (0,255) port
         then Right
                 (SndSeq.Address
                     (SndSeq.ClientId $ fromInteger client)
                     (SndSeq.Port $ fromInteger port))
         else Left "port must be in range [0,255]"
     else Left "client must be in range [128,191]"


-- * Useful things

{- |
Process MIDI events from ALSA in a lazy manner.
The processing function must be strict,
in order to let the cleanup take place after abandoning the process.
-}
withMIDIEvents :: String -> String -> ([MIDIFile.Event] -> IO a) -> IO a
withMIDIEvents clientName portName act = do
   bracket
      (createClient SndSeq.openInput clientName)
      deleteClient $
      \ client -> do
         -- Why is it necessary to use a writable port for reading events?
         createOutputPort client portName
         (act . catMaybes) =<< ioToLazyList (receiveMIDIEvent client)

deleteClient :: Client -> IO ()
deleteClient ac = do
    mapM_ (deletePort ac) =<< readIORef (ports ac)
    SndSeq.close (sequencerHandle ac)
    return ()

{-
event_input tells whether more events are waiting.
Maybe we should return a list of all events rather than a Maybe.
-}
receiveMIDIEvent :: Client -> IO (Maybe MIDIFile.Event)
receiveMIDIEvent ac =
    alloca $ \eventPtrPtr ->
{- sometimes returns code -4 (Interrupted system call)
       SndSeq.check "receiveMIDIEvent" (SndSeq.event_input (sequencerHandle ac) eventPtrPtr)
         >> liftM eventToMIDIEvent (peek =<< peek eventPtrPtr)
-}
       SndSeq.event_input (sequencerHandle ac) eventPtrPtr
         >>= \(SndSeq.ReturnCode err) ->
            if err < 0
              then return Nothing
                -- fail "SndSeq.event_input failed"
              else liftM eventToMIDIEvent (peek =<< peek eventPtrPtr)

{- |
NoteOn events with zero velocity are automatically converted to NoteOff events,
which is equivalent according to the MIDI standard.
-}
eventToMIDIEvent :: SndSeq.Event -> Maybe MIDIFile.Event
eventToMIDIEvent ev =
   case SndSeq.eventData ev of
      SndSeq.Connect _ _ -> Nothing
      SndSeq.Fixed -> Nothing
      SndSeq.Note
          {SndSeq.noteVelocity = v0,
           SndSeq.notePitch = p0,
           SndSeq.noteChannel = c0} ->
         let p = MIDIEvent.toPitch    $ fromIntegral p0
             v = MIDIEvent.toVelocity $ fromIntegral v0
             c = MIDIEvent.toChannel  $ fromIntegral c0
         in  Just $ MIDIFile.MIDIEvent c $
             case SndSeq.typ ev of
                SndSeq.EventNoteOn  ->
                   if v0==0
                     then MIDIEvent.NoteOff p (MIDIEvent.toVelocity 64)
                     else MIDIEvent.NoteOn  p v
                SndSeq.EventNoteOff -> MIDIEvent.NoteOff p v
                SndSeq.EventKeyPressure -> MIDIEvent.PolyAfter p $ fromIntegral v0
                _ -> error ("eventToMIDIEvent: note typ " ++ show ev)
      SndSeq.Control
          {SndSeq.controlChannel = c,
           SndSeq.controlParameter = p,
           SndSeq.controlValue = x} ->
         Just $ MIDIFile.MIDIEvent (MIDIEvent.toChannel  $ fromIntegral c) $
         case SndSeq.typ ev of
            SndSeq.EventController ->
               MIDIEvent.Control
                  (toEnum $ fromIntegral p)
                  (fromIntegral x)
            SndSeq.EventProgramChange ->
               MIDIEvent.ProgramChange
                  (MIDIEvent.toProgram $ fromIntegral x)
            SndSeq.EventChannelPressure ->
               MIDIEvent.MonoAfter (fromIntegral x)
            SndSeq.EventPitchBend ->
               MIDIEvent.PitchBend (fromIntegral x)
            _ -> error ("eventToMIDIEvent: cannot convert controller message " ++ show ev)
      _ -> error ("eventToMIDIEvent: " ++ show ev)

ioToLazyList :: IO a -> IO [a]
ioToLazyList m =
    unsafeInterleaveIO $
       liftM2 (:) m (ioToLazyList m)


mkNote ::
   MIDIEvent.Channel ->
   MIDIEvent.Pitch ->
   MIDIEvent.Velocity ->
   SndSeq.EventDataUnion
mkNote c p v =
   let v1 = fromIntegral $ MIDIEvent.fromVelocity v
   in  SndSeq.Note {
          SndSeq.noteChannel = fromIntegral $ MIDIEvent.fromChannel c,
          SndSeq.notePitch   = fromIntegral $ MIDIEvent.fromPitch p,
          SndSeq.noteVelocity = v1,
          SndSeq.noteOffVelocity = v1,
          SndSeq.noteDuration = 0}

eventFromMIDIEvent ::
   SndSeq.Queue -> MIDIFile.Event -> (SndSeq.EventType, SndSeq.EventDataUnion)
eventFromMIDIEvent _ (MIDIFile.MIDIEvent c ev) =
   case ev of
      MIDIEvent.NoteOn  p v -> (SndSeq.EventNoteOn,  mkNote c p v)
      MIDIEvent.NoteOff p v -> (SndSeq.EventNoteOff, mkNote c p v)
      MIDIEvent.ProgramChange p -> (SndSeq.EventProgramChange,
         SndSeq.Control {
            SndSeq.controlChannel = fromIntegral $ MIDIEvent.fromChannel c,
            SndSeq.controlValue   = fromIntegral $ MIDIEvent.fromProgram p,
            SndSeq.controlParameter = 0
           })
      _ -> error ("eventFromMIDIEvent: event type not supported, " ++ show ev)
eventFromMIDIEvent q (MIDIFile.MetaEvent ev) =
   case ev of
      MIDIFile.SetTempo t -> (SndSeq.EventTempo, SndSeq.QueueEv {
          SndSeq.queueId = q,
          SndSeq.queueControl = SndSeq.QueueControlValue $ fromIntegral t})
      _ -> error ("eventFromMIDIEvent: event type not supported, " ++ show ev)
eventFromMIDIEvent _ ev =
   error ("eventFromMIDIEvent: event type not supported, " ++ show ev)


sendPlainEvent :: Client -> SndSeq.Event -> IO ()
sendPlainEvent client ev =
   with ev $ \evPtr ->
      liftM (const ()) $
      SndSeq.check "sendPlainEvent" $
      SndSeq.event_output (sequencerHandle client) evPtr


{- |
Strangly ALSA returns error code 2 (No such file or directory)
if the destination port does not exist.
-}
drainOutput :: Client -> IO ()
drainOutput =
   liftM (const ()) .
   SndSeq.check "drainOutput" .
   SndSeq.drain_output . sequencerHandle


withNamedQueue :: Client -> String -> (SndSeq.Queue -> IO a) -> IO a
withNamedQueue client name =
   bracket
      (liftM
          (SndSeq.Queue . fromIntegral)
          (SndSeq.check "withNamedQueue" (withCString name
              (SndSeq.alloc_named_queue (sequencerHandle client)))))
      (SndSeq.free_queue (sequencerHandle client))


initQueueTempo :: Client -> SndSeq.Queue -> Int -> Int -> IO ()
initQueueTempo client q ppq tempo =
   bracket
      (alloca $ \t ->
          SndSeq.check "initQueueTempo.malloc" (SndSeq.queue_tempo_malloc t) >>
          peek t)
      SndSeq.queue_tempo_free
      (\t ->
          do SndSeq.queue_tempo_set_tempo t (fromIntegral tempo)
             SndSeq.queue_tempo_set_ppq   t (fromIntegral ppq)

             SndSeq.check "initQueueTempo.set_tempo"
                (SndSeq.set_queue_tempo (sequencerHandle client) q t)
             return ())


-- create a new client
createClient :: SndSeq.OpenMode -> String -> IO Client
createClient mode name = alloca $ \handlePtr -> do
    SndSeq.check "createClient" $
       withCString "default" $ \defaultS ->
       SndSeq.open handlePtr defaultS mode 0

    hdl <- peek handlePtr
    withCString name (SndSeq.set_client_name hdl)
    liftM (Client hdl) (newIORef [])



createPort :: SndSeq.PortCapabilitySet -> Client -> String -> IO SndSeq.Port
createPort cap client name = do
    port <-
       SndSeq.check "createPort" $
       withCString name $ \cname ->
       SndSeq.create_simple_port
         (sequencerHandle client)
         cname
         cap
         SndSeq.portTypeMIDIGeneric -- TODO

    let p = SndSeq.Port $ fromIntegral port
    modifyIORef (ports client) (p :)
    return p


createInputPort :: Client -> String -> IO SndSeq.Port
createInputPort =
   createPort (SndSeq.flagsToWord [SndSeq.PortCapRead, SndSeq.PortCapSubsRead])

createOutputPort :: Client -> String -> IO SndSeq.Port
createOutputPort =
   createPort (SndSeq.flagsToWord [SndSeq.PortCapWrite, SndSeq.PortCapSubsWrite])

deletePort :: Client -> SndSeq.Port -> IO ()
deletePort client =
   liftM (const ()) .
   SndSeq.check "deletePort" .
   SndSeq.delete_simple_port (sequencerHandle client)