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)