module Sound.ALSA.Sequencer (
createClient,
deleteClient,
createInputPort,
createOutputPort,
withEvents,
receiveEvent,
sendPlainEvent,
drainOutput,
initQueueTempo,
withNamedQueue,
portAddress,
numAddress,
numAddressEither,
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.C.String (withCString)
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]"
withEvents :: String -> String -> ([SndSeq.Event] -> IO a) -> IO a
withEvents clientName portName act = do
bracket
(createClient SndSeq.openInput clientName)
deleteClient $
\ client -> do
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 ()
receiveEvent :: Client -> IO (Maybe SndSeq.Event)
receiveEvent ac =
alloca $ \eventPtrPtr ->
SndSeq.event_input (sequencerHandle ac) eventPtrPtr
>>= \(SndSeq.ReturnCode err) ->
if err < 0
then return Nothing
else liftM Just $ peek =<< peek eventPtrPtr
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 ->
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
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 ())
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
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)