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