hmidi-0.2.3.1: System/MacOSX/CoreMIDI.hs
-- |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
--------------------------------------------------------------------------------