module Sound.ALSA.Sequencer ( createClient, deleteClient, createInputPort, createOutputPort, withEvents, receiveEvent, sendPlainEvent, drainOutput, initQueueTempo, withNamedQueue, portAddress, numAddress, numAddressEither, -- constructors only for internal use Client(sequencerHandle), SndSeq.Port(..), eventToChannelMsg, eventFromChannelMsg, eventFromMetaEvent, ) where import qualified Sound.ALSA.Sequencer.FFI as SndSeq import qualified Sound.MIDI.File.Event.Meta as MetaEvent import qualified Sound.MIDI.Message.Channel as ChannelMsg import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg import qualified Sound.MIDI.Message.Channel.Mode as ModeMsg 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) 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. -} withEvents :: String -> String -> ([SndSeq.Event] -> IO a) -> IO a withEvents 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 (receiveEvent 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. -} receiveEvent :: Client -> IO (Maybe SndSeq.Event) receiveEvent ac = alloca $ \eventPtrPtr -> {- sometimes returns code -4 (Interrupted system call) SndSeq.check "receiveEvent" (SndSeq.event_input (sequencerHandle ac) eventPtrPtr) >> liftM eventToEvent (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 Just $ peek =<< peek eventPtrPtr {- | This function checks whether the ALSA sequencer message is a MIDI channel message and converts to the corresponding data structure. Note that ALSA sequencer events contain MIDI realtime messages, MIDI file events and additional events. We do not want to define yet another data structure additionally to 'SndSeq.Event' and the message types from the midi package. Instead, because we believe, that most of the time you cope with certain types of events in bundles, we provide functions that allow easy access to these types. Currently we provide only access to MIDI channel messages but that can be easily extended. Multiple handlers of certain event types can be composed using 'Control.Monad.mplus'. NoteOn events with zero velocity are not automatically converted to NoteOff events, this can be done with the 'Sound.MIDI.Message.Channel.Voice.explicitNoteOff' function. -} eventToChannelMsg :: SndSeq.Event -> Maybe ChannelMsg.T eventToChannelMsg ev = case SndSeq.eventData ev of SndSeq.Note {SndSeq.noteVelocity = v0, SndSeq.notePitch = p0, SndSeq.noteChannel = c0} -> let p = VoiceMsg.toPitch $ fromIntegral p0 v = VoiceMsg.toVelocity $ fromIntegral v0 c = ChannelMsg.toChannel $ fromIntegral c0 cons = Just . ChannelMsg.Cons c . ChannelMsg.Voice in case SndSeq.typ ev of SndSeq.EventNoteOn -> cons $ if v0==0 then VoiceMsg.NoteOff p (VoiceMsg.toVelocity 64) else VoiceMsg.NoteOn p v SndSeq.EventNoteOff -> cons $ VoiceMsg.NoteOff p v SndSeq.EventKeyPressure -> cons $ VoiceMsg.PolyAftertouch p $ fromIntegral v0 _ -> fail ("eventToChannelMsg: note typ " ++ show ev) SndSeq.Control {SndSeq.controlChannel = c, SndSeq.controlParameter = p, SndSeq.controlValue = x} -> let cons = Just . ChannelMsg.Cons (ChannelMsg.toChannel $ fromIntegral c) in case SndSeq.typ ev of SndSeq.EventController -> cons $ if p<078 then ChannelMsg.Voice $ VoiceMsg.Control (toEnum $ fromIntegral p) (fromIntegral x) else ChannelMsg.Mode $ snd $ ModeMsg.fromControllerValue (p, fromIntegral x) SndSeq.EventProgramChange -> cons $ ChannelMsg.Voice $ VoiceMsg.ProgramChange (VoiceMsg.toProgram $ fromIntegral x) SndSeq.EventChannelPressure -> cons $ ChannelMsg.Voice $ VoiceMsg.MonoAftertouch (fromIntegral x) SndSeq.EventPitchBend -> cons $ ChannelMsg.Voice $ VoiceMsg.PitchBend (fromIntegral x) _ -> fail ("eventToChannelMsg: cannot convert controller message " ++ show ev) _ -> Nothing ioToLazyList :: IO a -> IO [a] ioToLazyList m = unsafeInterleaveIO $ liftM2 (:) m (ioToLazyList m) mkNote :: ChannelMsg.Channel -> VoiceMsg.Pitch -> VoiceMsg.Velocity -> SndSeq.EventDataUnion mkNote c p v = let v1 = fromIntegral $ VoiceMsg.fromVelocity v in SndSeq.Note { SndSeq.noteChannel = fromIntegral $ ChannelMsg.fromChannel c, SndSeq.notePitch = fromIntegral $ VoiceMsg.fromPitch p, SndSeq.noteVelocity = v1, SndSeq.noteOffVelocity = v1, SndSeq.noteDuration = 0} mkControl :: ChannelMsg.Channel -> Int -> Int -> -- CUInt -> CInt -> SndSeq.EventDataUnion mkControl c p x = SndSeq.Control { SndSeq.controlChannel = fromIntegral $ ChannelMsg.fromChannel c, SndSeq.controlParameter = fromIntegral p, SndSeq.controlValue = fromIntegral x } eventFromChannelMsg :: ChannelMsg.T -> (SndSeq.EventType, SndSeq.EventDataUnion) eventFromChannelMsg (ChannelMsg.Cons c ev) = case ev of ChannelMsg.Voice voice -> case voice of VoiceMsg.NoteOn p v -> (SndSeq.EventNoteOn, mkNote c p v) VoiceMsg.NoteOff p v -> (SndSeq.EventNoteOff, mkNote c p v) VoiceMsg.Control ctrl x -> (SndSeq.EventController, mkControl c (VoiceMsg.fromController ctrl) x) VoiceMsg.ProgramChange p -> (SndSeq.EventProgramChange, mkControl c 0 (VoiceMsg.fromProgram p)) VoiceMsg.MonoAftertouch x -> (SndSeq.EventChannelPressure, mkControl c 0 x) VoiceMsg.PolyAftertouch p x -> (SndSeq.EventKeyPressure, mkNote c p (VoiceMsg.toVelocity x)) VoiceMsg.PitchBend x -> (SndSeq.EventPitchBend, mkControl c 0 x) ChannelMsg.Mode mode -> (SndSeq.EventController, let (ctrl, x) = ModeMsg.toControllerValue mode in SndSeq.Control { SndSeq.controlChannel = fromIntegral $ ChannelMsg.fromChannel c, SndSeq.controlValue = fromIntegral x, SndSeq.controlParameter = ctrl }) eventFromMetaEvent :: SndSeq.Queue -> MetaEvent.T -> (SndSeq.EventType, SndSeq.EventDataUnion) eventFromMetaEvent q ev = case ev of MetaEvent.SetTempo t -> (SndSeq.EventTempo, SndSeq.QueueEv { SndSeq.queueId = q, SndSeq.queueControl = SndSeq.QueueControlValue $ fromIntegral t}) _ -> error ("eventFromMetaEvent: event type not yet implemented, " ++ 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)