alsa-midi-0.4: src/Sound/ALSA/Sequencer.hs
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)