-- |Low-level (partial) binding to the CoreMIDI services present in Mac OS X. -- Error \"handling\" is via `fail`-s in the IO monad. {-# LANGUAGE BangPatterns, ForeignFunctionInterface, EmptyDataDecls #-} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} module System.MacOSX.CoreMIDI ( enumerateDevices , enumerateSources , enumerateDestinations , MIDIHasName , getName , getModel , getManufacturer , newSource , newDestination , disposeEndpoint , newClient , disposeClient , newInputPort , newOutputPort , disposePort , connectToSource , disconnectFromSource , midiSend , midiSendStamped , midiSendList , midiSendListStamped , midiSendSysEx , midiReceivedStamped , midiReceivedListStamped -- types , OpaqueMIDIClient , OpaqueMIDIObject , OpaqueMIDIDevice , OpaqueMIDIEntity , OpaqueMIDIEndpoint , OpaqueMIDIPort , MIDIClientRef , MIDIObjectRef , MIDIDeviceRef , MIDIEntityRef , MIDIEndpointRef , MIDIPortRef , MIDITimeStamp , MIDIReadProc , mkMIDIReadProc , MIDIPacket , Source(..) , Destination(..) , ShortMessage(..) -- helper functions to write callbacks , SysExStatus(..) , depackMIDIPacketList , depackSingleMIDIPacket , decodeShortMessage , isShortMessage ) where -------------------------------------------------------------------------------- import Control.Monad import Control.Concurrent.MVar import Foreign import Foreign.Marshal import System.IO.Unsafe as Unsafe --import System.MIDI.Base import System.MacOSX.CoreFoundation import System.MacOSX.CoreAudio -- import qualified Data.ByteString as B -------------------------------------------------------------------------------- data OpaqueMIDIClient data OpaqueMIDIObject data OpaqueMIDIDevice data OpaqueMIDIEntity data OpaqueMIDIEndpoint data OpaqueMIDIPort type MIDIClientRef = Ptr OpaqueMIDIClient type MIDIObjectRef = Ptr OpaqueMIDIObject type MIDIDeviceRef = Ptr OpaqueMIDIDevice type MIDIEntityRef = Ptr OpaqueMIDIEntity type MIDIEndpointRef = Ptr OpaqueMIDIEndpoint type MIDIPortRef = Ptr OpaqueMIDIPort type MIDIUniqueID = SInt32 type MIDIObjectType = SInt32 type MIDITimeStamp = UInt64 data MIDINotification type MIDINotifyProc a = Ptr MIDINotification -> Ptr a -> IO () data MIDIPacket data MIDISysexSendRequest -- | 'r' is readProcRefCon (The refCon you passed to MIDIInputPortCreate or MIDIDestinationCreate); -- 's' is srcConnRefCon (A refCon you passed to MIDIPortConnectSource, which identifies the source of the data). type MIDIReadProc r s = Ptr MIDIPacket -> Ptr r -> Ptr s -> IO () foreign import ccall safe "wrapper" mkMIDIReadProc :: MIDIReadProc () () -> IO (FunPtr (MIDIReadProc () ())) -------------------------------------------------------------------------------- -- * Properties foreign import ccall "&kMIDIPropertyName" ptr_kMIDIPropertyName :: Ptr CFStringRef foreign import ccall "&kMIDIPropertyManufacturer" ptr_kMIDIPropertyManufacturer :: Ptr CFStringRef foreign import ccall "&kMIDIPropertyModel" ptr_kMIDIPropertyModel :: Ptr CFStringRef kMIDIPropertyName = Unsafe.unsafePerformIO $ peek ptr_kMIDIPropertyName kMIDIPropertyManufacturer = Unsafe.unsafePerformIO $ peek ptr_kMIDIPropertyManufacturer kMIDIPropertyModel = Unsafe.unsafePerformIO $ peek ptr_kMIDIPropertyModel -- * Send foreign import ccall unsafe "MIDIServices.h MIDISend" c_MIDISend :: MIDIPortRef -> MIDIEndpointRef -> Ptr MIDIPacket -> IO OSStatus foreign import ccall unsafe "MIDIServices.h MIDISendSysex" c_MIDISendSysex :: Ptr MIDISysexSendRequest -> IO OSStatus -- | Distributes incoming MIDI from a source to the client input ports which are connected to that source -- -- After creating a virtual source, use MIDIReceived to transmit MIDI messages from your -- virtual source to any clients connected to the virtual source. -- -- Unlike @MIDISend()@, a timestamp of 0 is not equivalent to "now"; the driver or virtual. foreign import ccall unsafe "MIDIServices.h MIDIReceived" c_MIDIReceived :: MIDIEndpointRef -> Ptr MIDIPacket -> IO OSStatus -- * Clients foreign import ccall unsafe "MIDIServices.h MIDIClientCreate" c_MIDIClientCreate :: CFStringRef -> FunPtr (MIDINotifyProc a) -> Ptr a -> Ptr MIDIClientRef -> IO OSStatus foreign import ccall unsafe "MIDIServices.h MIDIClientDispose" c_MIDIClientDispose :: MIDIClientRef -> IO OSStatus -- * Devices foreign import ccall unsafe "MIDIServices.h MIDIGetNumberOfDevices" c_MIDIGetNumberOfDevices :: IO ItemCount foreign import ccall unsafe "MIDIServices.h MIDIGetDevice" c_MIDIGetDevice :: ItemCount -> IO MIDIDeviceRef -- * Endpoints foreign import ccall unsafe "MIDIServices.h MIDIGetNumberOfSources" c_MIDIGetNumberOfSources :: IO ItemCount foreign import ccall unsafe "MIDIServices.h MIDIGetNumberOfDestinations" c_MIDIGetNumberOfDestinations :: IO ItemCount foreign import ccall unsafe "MIDIServices.h MIDIGetSource" c_MIDIGetSource :: ItemCount -> IO MIDIEndpointRef foreign import ccall unsafe "MIDIServices.h MIDIGetDestination" c_MIDIGetDestination :: ItemCount -> IO MIDIEndpointRef foreign import ccall unsafe "MIDIServices.h MIDISourceCreate" c_MIDISourceCreate :: MIDIClientRef -> CFStringRef -> Ptr MIDIEndpointRef -> IO OSStatus foreign import ccall unsafe "MIDIServices.h MIDIDestinationCreate" c_MIDIDestinationCreate :: MIDIClientRef -> CFStringRef -> FunPtr (MIDIReadProc r s) -> Ptr r -> Ptr MIDIEndpointRef -> IO OSStatus foreign import ccall unsafe "MIDIServices.h MIDIEndpointDispose" c_MIDIEndpointDispose :: MIDIEndpointRef -> IO OSStatus foreign import ccall unsafe "MIDIServices.h MIDIEndpointGetEntity" c_MIDIEndpointGetEntity :: MIDIEndpointRef -> Ptr MIDIEntityRef -> IO OSStatus -- * Ports foreign import ccall safe "MIDIServices.h MIDIInputPortCreate" c_MIDIInputPortCreate :: MIDIClientRef -> CFStringRef -> FunPtr (MIDIReadProc r s) -> Ptr r -> Ptr MIDIPortRef -> IO OSStatus foreign import ccall safe "MIDIServices.h MIDIOutputPortCreate" c_MIDIOutputPortCreate :: MIDIClientRef -> CFStringRef -> Ptr MIDIPortRef -> IO OSStatus foreign import ccall unsafe "MIDIServices.h MIDIPortDispose" c_MIDIPortDispose :: MIDIPortRef -> IO OSStatus foreign import ccall safe "MIDIServices.h MIDIPortConnectSource" c_MIDIPortConnectSource :: MIDIPortRef -> MIDIEndpointRef -> Ptr a -> IO OSStatus foreign import ccall safe "MIDIServices.h MIDIPortDisconnectSource" c_MIDIPortDisconnectSource :: MIDIPortRef -> MIDIEndpointRef -> IO OSStatus -------------------------------------------------------------------------------- -- * Objects foreign import ccall unsafe "MIDIServices.h MIDIObjectFindByUniqueID" c_MIDIObjectFindByUniqueID :: MIDIUniqueID -> Ptr MIDIObjectRef -> Ptr MIDIObjectType -> IO OSStatus foreign import ccall unsafe "MIDIServices.h MIDIObjectGetDataProperty" c_MIDIObjectGetDataProperty :: MIDIObjectRef -> CFStringRef -> Ptr CFDataRef -> IO OSStatus foreign import ccall unsafe "MIDIServices.h MIDIObjectGetIntegerProperty" c_MIDIObjectGetIntegerProperty :: MIDIObjectRef -> CFStringRef -> Ptr SInt32 -> IO OSStatus foreign import ccall unsafe "MIDIServices.h MIDIObjectGetStringProperty" c_MIDIObjectGetStringProperty :: MIDIObjectRef -> CFStringRef -> Ptr CFStringRef -> IO OSStatus foreign import ccall unsafe "MIDIServices.h MIDIObjectSetDataProperty" c_MIDIObjectSetDataProperty :: MIDIObjectRef -> CFStringRef -> CFDataRef -> IO OSStatus foreign import ccall unsafe "MIDIServices.h MIDIObjectSetIntegerProperty" c_MIDIObjectSetIntegerProperty :: MIDIObjectRef -> CFStringRef -> SInt32 -> IO OSStatus foreign import ccall unsafe "MIDIServices.h MIDIObjectSetStringProperty" c_MIDIObjectSetStringProperty :: MIDIObjectRef -> CFStringRef -> CFStringRef -> IO OSStatus -------------------------------------------------------------------------------- midiObjectGetStringProperty :: MIDIObjectRef -> CFStringRef -> IO String midiObjectGetStringProperty object propertyid = alloca $ \ptr_cfstringref -> do osstatus <- c_MIDIObjectGetStringProperty object propertyid ptr_cfstringref if osstatus /= 0 then osStatusError osstatus else do cfstringref <- peek ptr_cfstringref string <- peekCFString cfstringref releaseCFString cfstringref return string midiObjectGetIntegerProperty :: MIDIObjectRef -> CFStringRef -> IO SInt32 midiObjectGetIntegerProperty object propertyid = alloca $ \ptr_sint32 -> do osstatus <- c_MIDIObjectGetIntegerProperty object propertyid ptr_sint32 if osstatus /= 0 then osStatusError osstatus else do sint32 <- peek ptr_sint32 return sint32 -------------------------------------------------------------------------------- -- * exported Haskell functions newtype Source = Source MIDIEndpointRef deriving (Eq,Show) newtype Destination = Destination MIDIEndpointRef deriving (Eq,Show) class Endpoint a where endpoint :: a -> MIDIEndpointRef instance Endpoint Source where endpoint (Source src) = src instance Endpoint Destination where endpoint (Destination src) = src instance Endpoint MIDIEndpointRef where endpoint = id class MIDIObject a where midiObject :: a -> MIDIObjectRef instance MIDIObject MIDIClientRef where midiObject = castPtr instance MIDIObject MIDIDeviceRef where midiObject = castPtr instance MIDIObject MIDIPortRef where midiObject = castPtr instance MIDIObject MIDIEndpointRef where midiObject = castPtr instance MIDIObject MIDIEntityRef where midiObject = castPtr instance MIDIObject Source where midiObject (Source src) = castPtr src instance MIDIObject Destination where midiObject (Destination dst) = castPtr dst -- |MIDI objects which can have a name, model name and manufacturer class MIDIObject a => MIDIHasName a where getName :: a -> IO String getModel :: a -> IO String getManufacturer :: a -> IO String getName = genericGetName . midiObject getModel = genericGetModel . midiObject getManufacturer = genericGetManufacturer . midiObject instance MIDIHasName MIDIDeviceRef instance MIDIHasName MIDIEntityRef instance MIDIHasName MIDIPortRef instance MIDIHasName MIDIEndpointRef instance MIDIHasName Source instance MIDIHasName Destination genericGetName obj = midiObjectGetStringProperty obj kMIDIPropertyName genericGetModel obj = midiObjectGetStringProperty obj kMIDIPropertyModel genericGetManufacturer obj = midiObjectGetStringProperty obj kMIDIPropertyManufacturer data Notification = Notification NotificationMessageID (Maybe [Word8]) data NotificationMessageID = SetupChanged | ObjectAdded | ObjectRemoved | PropertyChanged | ThruConnectionsChanged | SerialPortOwnerChanged | MIDIMsgIOError deriving Show -------------------------------------------------------------------------------- -- * encode / decode -- |Short message in low level format. data ShortMessage = ShortMessage { sm_channel :: Word8 , sm_msg :: Word8 , sm_byte1 :: Word8 , sm_byte2 :: Word8 } deriving Show encodeShortMessageList :: [ShortMessage] -> [Word8] encodeShortMessageList list = concatMap encodeShortMessage list encodeShortMessage :: ShortMessage -> [Word8] encodeShortMessage sm@(ShortMessage chn' msg' bt1 bt2) = case msg of 8 -> [cmd,bt1,bt2] -- note off 9 -> [cmd,bt1,bt2] -- note on 10 -> [cmd,bt1,bt2] -- aftertouch 11 -> [cmd,bt1,bt2] -- control change 12 -> [cmd,bt1] -- program chane 13 -> [cmd,bt1] -- channel pressure 14 -> [cmd,bt1,bt2] -- pitchwheel 15 -> case chn of 1 -> [cmd,bt1] -- midi timing code 2 -> [cmd,bt1,bt2] -- song position 3 -> [cmd,bt1] -- song select 0 -> error "SysEx is not a short message!" _ -> [cmd] -- all the rest are one-byte messages _ -> error $ "invalid MIDI message high nibble: " ++ show sm where chn = 15 .&. chn' msg = 15 .&. msg' cmd = chn + shiftL msg 4 isShortMessage :: [Word8] -> Bool isShortMessage msg = (head msg /= 0xf0) decodeShortMessage :: [Word8] -> ShortMessage decodeShortMessage bytes = ShortMessage chn msg bt1 bt2 where cmd = head bytes chn = cmd .&. 15 msg = shiftR cmd 4 (bt1,bt2) = case tail bytes of [] -> (0,0) [a] -> (a,0) [a,b] -> (a,b) _ -> error "a short message shouldn't be longer than 3 bytes!" -- | OSX can split sysex message into multiple parts, -- and it does not signal this in any way... apart from missing 0xf7 bytes data SysExStatus = NoSysEx | PartialSysEx [Word8] deriving Show depackMIDIPacketList :: Ptr MIDIPacket -> SysExStatus -> IO ( [ (MIDITimeStamp, [Word8]) ] , SysExStatus ) depackMIDIPacketList p initial_sysex_status = do npackets <- peek (castPtr p) :: IO UInt32 -- print ("number of packets = ",npackets) -- print ("sysex status = ",initial_sysex_status) depack' (p `plusPtr` 4) initial_sysex_status npackets where depack' _ sysex_status 0 = return ([],sysex_status) depack' !p sysex_status !k = do ( n , ts , msgs , sysex_status' ) <- depackSingleMIDIPacket p sysex_status let xs = zip (repeat ts) msgs (ys , sysex_status'') <- depack' (p `plusPtr` n) sysex_status' (k-1) return ( xs++ys , sysex_status'' ) -- decodes a single MIDIPacket, and returns the length (in bytes), the timestamp, and the list of midi messages depackSingleMIDIPacket :: Ptr MIDIPacket -> SysExStatus -> IO ( Int , MIDITimeStamp , [[Word8]] , SysExStatus ) depackSingleMIDIPacket p sysex_status = do ts <- peek (castPtr p ) :: IO MIDITimeStamp len' <- peek (castPtr p `plusPtr` 8) :: IO UInt16 let len = fromIntegral len' -- print ("number of bytes in packet = ",len) ( msglist , sysex_status' ) <- depackMsgList (castPtr p `plusPtr` 10 :: Ptr Word8) sysex_status len return ( len + 8 + 2 , ts , msglist , sysex_status' ) -- helper function depackMsgList :: Ptr Word8 -> SysExStatus -> Int -> IO ( [[Word8]] , SysExStatus ) depackMsgList _ sysex_status 0 = return ( [] , sysex_status ) depackMsgList !p !sysex_status !n = if n < 0 then fail "fatal error while depacking MIDI messages" else do (k , mbx , sysex_status') <- depackSingleMessage p sysex_status n -- print (n,(k,mbx,sysex_status')) -- DEBUGGING (xs , sysex_status'') <- depackMsgList (p `plusPtr` k) sysex_status' (n-k) case mbx of Nothing -> return ( xs , sysex_status'' ) Just x -> return ( (x:xs) , sysex_status'' ) depackSingleMessage :: Ptr Word8 -> SysExStatus -> Int -> IO (Int , Maybe [Word8] , SysExStatus) depackSingleMessage !p NoSysEx !maxlen = do cmd <- peek p let hi = shiftR cmd 4 lo = cmd .&. 15 let ret :: Int -> IO (Int , Maybe[Word8] , SysExStatus) ret k = do xs <- mapM (peekElemOff p) [0..k-1] return $ ( k , Just xs , NoSysEx ) case hi of 8 -> ret 3 9 -> ret 3 10 -> ret 3 11 -> ret 3 12 -> ret 2 13 -> ret 2 14 -> ret 3 15 -> case lo of 0 -> do -- 0xF0 ... 0xF7 = sysex (k,bytes,finished) <- sysex p maxlen if finished then return (k, Just bytes , NoSysEx ) else return (k, Nothing , PartialSysEx bytes) 1 -> ret 2 -- 0xF1 bb = midi timing code 2 -> ret 3 -- 0xF2 bb cc = song position 3 -> ret 2 -- 0xF3 bb = song select _ -> ret 1 -- 0xFz _ -> fail "fatal error while interpreting a MIDI message" depackSingleMessage !p (PartialSysEx partial) !maxlen = do (n,bytes,finished) <- sysex p maxlen return $ if finished then (n , Just (partial ++ bytes) , NoSysEx) else (n , Nothing , PartialSysEx (partial ++ bytes) ) -- CHANGE in 2020: now we include the terminating 0xf7 byte! -- this is because longer sysex messages can be broken into several parts... sysex :: Ptr Word8 -> Int -> IO (Int,[Word8],Bool) sysex !p !maxlen = do (n,finished) <- sysexHelper p maxlen 0 xs <- mapM (peekElemOff p) [0..n-1] return ( n , xs , finished) sysexHelper :: Ptr Word8 -> Int -> Int -> IO (Int,Bool) sysexHelper !q !maxlen = go where go !i = if (i < maxlen) then do x <- peekElemOff q i if x == 0xf7 then return (i+1 , True) else go (i+1) else return (maxlen , False) -------------------------------------------------------------------------------- -- * Send messages to destinations we connected to -- | Sends a short message with timestamp "now". midiSend :: MIDIPortRef -> Destination -> ShortMessage -> IO () --midiSend port dst msg = midiSendStamped port dst 0 msg midiSend port dst msg = do timestamp <- audioGetCurrentHostTime -- see https://forum.ableton.com/viewtopic.php?p=1426466 midiSendStamped port dst timestamp msg -- | Sends a list of short messages with timestamp "now". midiSendList :: MIDIPortRef -> Destination -> [ShortMessage] -> IO () --midiSendList port dst msglist = midiSendListStamped port dst 0 msglist midiSendList port dst msglist = do timestamp <- audioGetCurrentHostTime -- see https://forum.ableton.com/viewtopic.php?p=1426466 midiSendListStamped port dst timestamp msglist -- | Sends a short message with the given timestamp. midiSendStamped :: MIDIPortRef -> Destination -> MIDITimeStamp -> ShortMessage -> IO () midiSendStamped port (Destination dst) ts msg = do let encoded = encodeShortMessage msg n = length encoded allocaBytes (4 + 8 + 2 + n) $ \p -> do poke ( p :: Ptr UInt32) 1 poke (castPtr p `plusPtr` 4 :: Ptr UInt64) ts poke (castPtr p `plusPtr` 12 :: Ptr UInt16) (fromIntegral n) pokeArray (castPtr p `plusPtr` 14 :: Ptr Word8 ) encoded osstatus <- c_MIDISend port dst (castPtr p) when (osstatus /= 0) $ osStatusError osstatus -- | Sends a list of short messages with the given timestamp. midiSendListStamped :: MIDIPortRef -> Destination -> MIDITimeStamp -> [ShortMessage] -> IO () midiSendListStamped port (Destination dst) ts msglist = do let encoded = encodeShortMessageList msglist n = length encoded allocaBytes (4 + 8 + 2 + n) $ \p -> do poke ( p :: Ptr UInt32) 1 poke (castPtr p `plusPtr` 4 :: Ptr UInt64) ts poke (castPtr p `plusPtr` 12 :: Ptr UInt16) (fromIntegral n) pokeArray (castPtr p `plusPtr` 14 :: Ptr Word8 ) encoded osstatus <- c_MIDISend port dst (castPtr p) when (osstatus /= 0) $ osStatusError osstatus -------------------------------------------------------------------------------- -- * sending (short) messages to other programs connected to us midiReceivedStamped :: Destination -> MIDITimeStamp -> ShortMessage -> IO () midiReceivedStamped dst tstamp msg = midiReceivedListStamped dst tstamp [msg] -- | "Distributes [incoming MIDI from a source] to the client input ports which are connected to that source." midiReceivedListStamped :: Destination -> MIDITimeStamp -> [ShortMessage] -> IO () midiReceivedListStamped (Destination dst) ts msglist = do let encoded = encodeShortMessageList msglist n = length encoded allocaBytes (4 + 8 + 2 + n) $ \p -> do poke ( p :: Ptr UInt32) 1 poke (castPtr p `plusPtr` 4 :: Ptr UInt64) ts poke (castPtr p `plusPtr` 12 :: Ptr UInt16) (fromIntegral n) pokeArray (castPtr p `plusPtr` 14 :: Ptr Word8 ) encoded osstatus <- c_MIDIReceived dst (castPtr p) when (osstatus /= 0) $ osStatusError osstatus -------------------------------------------------------------------------------- type MIDISendSysExCallback = Ptr Word8 -> IO () foreign import ccall safe "wrapper" mkMidiSendSysExCallback :: MIDISendSysExCallback -> IO (FunPtr MIDISendSysExCallback) midiSendSysExCallback :: MIDISendSysExCallback midiSendSysExCallback p = do free p -- |Sends a system exclusive message. You shouldn't include the starting/trailing bytes 0xF0 and 0xF7. midiSendSysEx :: Endpoint a => a -> [Word8] -> IO () midiSendSysEx dst dat' = do let ptrsize = sizeOf (undefined :: Ptr Word8) n = length dat k = 4*ptrsize + 8 ep = endpoint dst dat = 0xf0 : (dat' ++ [0xf7]) cb <- mkMidiSendSysExCallback midiSendSysExCallback p <- mallocBytes (k + n) let q = (castPtr p `plusPtr` k) :: Ptr Word8 pokeArray q dat poke (castPtr p) ep ; r <- return (p `plusPtr` ptrsize) poke (castPtr r) q ; r <- return (r `plusPtr` ptrsize) poke (castPtr r) n ; r <- return (r `plusPtr` 4 ) poke (castPtr r) (0::Int32) ; r <- return (r `plusPtr` 4 ) poke (castPtr r) cb ; r <- return (r `plusPtr` ptrsize) poke (castPtr r) p -- not used (?) osstatus <- c_MIDISendSysex p -- this is asynchronous! (returns immediately before data has been sent) when (osstatus /= 0) $ osStatusError osstatus -------------------------------------------------------------------------------- -- * Ports -- |Creates a new input port. newInputPort :: MIDIClientRef -> String -> FunPtr (MIDIReadProc r s) -> Ptr r -> IO MIDIPortRef newInputPort client name proc ref = do withCFString name $ \cfname -> alloca $ \pport -> do osstatus <- c_MIDIInputPortCreate client cfname proc ref pport when (osstatus /= 0) $ osStatusError osstatus peek pport -- |Creates a new output port. newOutputPort :: MIDIClientRef -> String -> IO MIDIPortRef newOutputPort client name = do withCFString name $ \cfname -> alloca $ \pport -> do osstatus <- c_MIDIOutputPortCreate client cfname pport when (osstatus /= 0) $ osStatusError osstatus peek pport -- |Disposes an existing port. disposePort :: MIDIPortRef -> IO () disposePort port = do osstatus <- c_MIDIPortDispose port when (osstatus /= 0) $ osStatusError osstatus -- |Connects an input port to a source. connectToSource :: MIDIPortRef -> Source -> Ptr a -> IO () connectToSource port (Source src) ref = do osstatus <- c_MIDIPortConnectSource port src ref when (osstatus /= 0) $ osStatusError osstatus -- |Disconnects an input port from a source. disconnectFromSource :: MIDIPortRef -> Source -> IO () disconnectFromSource port (Source src) = do osstatus <- c_MIDIPortDisconnectSource port src when (osstatus /= 0) $ osStatusError osstatus ----- Clients -- |Creates a new MIDI client with the given name. newClient :: String -> IO MIDIClientRef newClient name = do withCFString name $ \cfname -> alloca $ \pclient -> do osstatus <- c_MIDIClientCreate cfname nullFunPtr nullPtr pclient when (osstatus /= 0) $ osStatusError osstatus peek pclient -- |Disposes an existing MIDI client. disposeClient :: MIDIClientRef -> IO () disposeClient client = do osstatus <- c_MIDIClientDispose client when (osstatus /= 0) $ osStatusError osstatus ----- Devices -- |Note: If a client iterates through the devices and entities in the system, it will not ever visit any virtual sources and destinations created by other clients. Also, a device iteration will return devices which are offline (were present in the past but are not currently present), while iterations through the system's sources and destinations will not include the endpoints of offline devices. -- -- Thus clients should usually use `enumerateSources` and `enumerateDestinations`, rather iterating through devices and entities to locate endpoints. enumerateDevices :: IO [MIDIDeviceRef] enumerateDevices = do n <- c_MIDIGetNumberOfDevices if n > 0 -- n is unsigned => (n-1)=(2^32)-1 !! then forM [0..n-1] c_MIDIGetDevice else return [] ----- Endpoints -- |Enumaretes the MIDI sources present. enumerateSources :: IO [Source] enumerateSources = do n <- c_MIDIGetNumberOfSources if n > 0 -- n is unsigned => (n-1)=(2^32)-1 !! then forM [0..n-1] $ \i -> liftM Source (c_MIDIGetSource i) else return [] -- |Enumaretes the MIDI destinations present. enumerateDestinations :: IO [Destination] enumerateDestinations = do n <- c_MIDIGetNumberOfDestinations if n > 0 -- n is unsigned => (n-1)=(2^32)-1 !! then forM [0..n-1] $ \i -> liftM Destination (c_MIDIGetDestination i) else return [] {- -- a helper function; not exposed. newEndpoint :: (MIDIClientRef -> CFStringRef -> Ptr MIDIEndpointRef -> IO OSStatus) -> MIDIClientRef -> String -> IO MIDIEndpointRef newEndpoint createEndpoint client name = withCFString name $ \cfname -> do alloca $ \ptr_endpoint -> do osstatus <- createEndpoint client cfname ptr_endpoint if osstatus /= 0 then osStatusError osstatus else peek ptr_endpoint -- |Creates a new MIDI source with the given name. newSource :: MIDIClientRef -> String -> IO Source newSource client name = do src <- newEndpoint c_MIDISourceCreate client name return $ Source src -- |Creates a new MIDI destination with the given name. newDestination :: MIDIClientRef -> String -> IO Destination newDestination client name = do dst <- newEndpoint c_MIDIDestinationCreate client name return $ Destination dst -} -- | Creates a new MIDI destination (to which other programs can connect to, -- so that it is a source for /us/) -- with the given name. newDestination :: MIDIClientRef -> String -> FunPtr (MIDIReadProc r s) -> Ptr r -> IO Source --Destination newDestination client name proc ref = liftM Source $ do withCFString name $ \cfname -> do alloca $ \ptr_endpoint -> do osstatus <- c_MIDIDestinationCreate client cfname proc ref ptr_endpoint if osstatus /= 0 then osStatusError osstatus else peek ptr_endpoint -- | Creates a new MIDI source (to which other programs can connect to, so that -- it is a destination for /us/) with the given name. newSource :: MIDIClientRef -> String -> IO Destination -- Source newSource client name = liftM Destination $ do withCFString name $ \cfname -> do alloca $ \ptr_endpoint -> do osstatus <- c_MIDISourceCreate client cfname ptr_endpoint if osstatus /= 0 then osStatusError osstatus else peek ptr_endpoint -- |Disposes an existing MIDI endpoint. disposeEndpoint :: Endpoint a => a -> IO () disposeEndpoint x = do osstatus <- c_MIDIEndpointDispose (endpoint x) when (osstatus /= 0) $ osStatusError osstatus --------------------------------------------------------------------------------