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
, OpaqueMIDIClient
, OpaqueMIDIObject
, OpaqueMIDIDevice
, OpaqueMIDIEntity
, OpaqueMIDIEndpoint
, OpaqueMIDIPort
, MIDIClientRef
, MIDIObjectRef
, MIDIDeviceRef
, MIDIEntityRef
, MIDIEndpointRef
, MIDIPortRef
, MIDITimeStamp
, MIDIReadProc
, mkMIDIReadProc
, MIDIPacket
, Source(..)
, Destination(..)
, ShortMessage(..)
, 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.MacOSX.CoreFoundation
import System.MacOSX.CoreAudio
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
type MIDIReadProc r s = Ptr MIDIPacket -> Ptr r -> Ptr s -> IO ()
foreign import ccall safe "wrapper"
mkMIDIReadProc :: MIDIReadProc () () -> IO (FunPtr (MIDIReadProc () ()))
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
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
foreign import ccall unsafe "MIDIServices.h MIDIReceived"
c_MIDIReceived :: MIDIEndpointRef -> Ptr MIDIPacket -> IO OSStatus
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
foreign import ccall unsafe "MIDIServices.h MIDIGetNumberOfDevices"
c_MIDIGetNumberOfDevices :: IO ItemCount
foreign import ccall unsafe "MIDIServices.h MIDIGetDevice"
c_MIDIGetDevice :: ItemCount -> IO MIDIDeviceRef
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
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
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
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
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
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]
9 -> [cmd,bt1,bt2]
10 -> [cmd,bt1,bt2]
11 -> [cmd,bt1,bt2]
12 -> [cmd,bt1]
13 -> [cmd,bt1]
14 -> [cmd,bt1,bt2]
15 -> case chn of
2 -> [cmd,bt1,bt2]
3 -> [cmd,bt1]
0 -> error "SysEx is not a short message!"
_ -> [cmd]
_ -> 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!"
depackMIDIPacketList :: Ptr MIDIPacket -> IO [ (MIDITimeStamp, [Word8]) ]
depackMIDIPacketList p =
do
npackets <- peek (castPtr p) :: IO UInt32
depack' (p `plusPtr` 4) npackets
where
depack' _ 0 = return []
depack' p k = do
( n , ts , msgs ) <- depackSingleMIDIPacket p
let xs = zip (repeat ts) msgs
ys <- depack' (p `plusPtr` n) (k1)
return (xs++ys)
depackSingleMIDIPacket :: Ptr MIDIPacket -> IO ( Int , MIDITimeStamp , [[Word8]] )
depackSingleMIDIPacket p = do
ts <- peek (castPtr p ) :: IO MIDITimeStamp
len' <- peek (castPtr p `plusPtr` 8) :: IO UInt16
let len = fromIntegral len'
msglist <- depackMsgList (castPtr p `plusPtr` 10 :: Ptr Word8) len
return ( len + 8 + 2, ts, msglist )
depackMsgList :: Ptr Word8 -> Int -> IO [[Word8]]
depackMsgList _ 0 = return []
depackMsgList p n = if n < 0
then fail "fatal error while depacking MIDI messages"
else do
(k,x) <- depackSingleMessage p
xs <- depackMsgList (p `plusPtr` k) (nk)
return (x:xs)
depackSingleMessage :: Ptr Word8 -> IO (Int,[Word8])
depackSingleMessage p = do
cmd <- peek p
let hi = shiftR cmd 4
lo = cmd .&. 15
let ret :: Int -> IO (Int,[Word8])
ret k = do
xs <- mapM (peekElemOff p) [0..k1]
return $ ( k , xs )
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
2 -> ret 3
3 -> ret 2
0 -> sysex p
_ -> ret 1
_ -> fail "fatal error while interpreting a MIDI message"
sysex :: Ptr Word8 -> IO (Int,[Word8])
sysex p = do
n <- sysexHelper p 2
xs <- mapM (peekElemOff p) [0..n]
return ( n+2 , xs )
sysexHelper :: Ptr Word8 -> Int -> IO Int
sysexHelper q i = do
x <- peekElemOff q i
if x == 0xf7 then return (i1) else sysexHelper q (i+1)
midiSend :: MIDIPortRef -> Destination -> ShortMessage -> IO ()
midiSend port dst msg = do
timestamp <- audioGetCurrentHostTime
midiSendStamped port dst timestamp msg
midiSendList :: MIDIPortRef -> Destination -> [ShortMessage] -> IO ()
midiSendList port dst msglist = do
timestamp <- audioGetCurrentHostTime
midiSendListStamped port dst timestamp msglist
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
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
midiReceivedStamped :: Destination -> MIDITimeStamp -> ShortMessage -> IO ()
midiReceivedStamped dst tstamp msg = midiReceivedListStamped dst tstamp [msg]
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
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
osstatus <- c_MIDISendSysex p
when (osstatus /= 0) $ osStatusError osstatus
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
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
disposePort :: MIDIPortRef -> IO ()
disposePort port = do
osstatus <- c_MIDIPortDispose port
when (osstatus /= 0) $ osStatusError osstatus
connectToSource :: MIDIPortRef -> Source -> Ptr a -> IO ()
connectToSource port (Source src) ref = do
osstatus <- c_MIDIPortConnectSource port src ref
when (osstatus /= 0) $ osStatusError osstatus
disconnectFromSource :: MIDIPortRef -> Source -> IO ()
disconnectFromSource port (Source src) = do
osstatus <- c_MIDIPortDisconnectSource port src
when (osstatus /= 0) $ osStatusError osstatus
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
disposeClient :: MIDIClientRef -> IO ()
disposeClient client = do
osstatus <- c_MIDIClientDispose client
when (osstatus /= 0) $ osStatusError osstatus
enumerateDevices :: IO [MIDIDeviceRef]
enumerateDevices = do
n <- c_MIDIGetNumberOfDevices
if n > 0
then forM [0..n1] c_MIDIGetDevice
else return []
enumerateSources :: IO [Source]
enumerateSources = do
n <- c_MIDIGetNumberOfSources
if n > 0
then forM [0..n1] $ \i -> liftM Source (c_MIDIGetSource i)
else return []
enumerateDestinations :: IO [Destination]
enumerateDestinations = do
n <- c_MIDIGetNumberOfDestinations
if n > 0
then forM [0..n1] $ \i -> liftM Destination (c_MIDIGetDestination i)
else return []
newDestination :: MIDIClientRef -> String -> FunPtr (MIDIReadProc r s) -> Ptr r -> IO Source
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
newSource :: MIDIClientRef -> String -> IO Destination
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
disposeEndpoint :: Endpoint a => a -> IO ()
disposeEndpoint x = do
osstatus <- c_MIDIEndpointDispose (endpoint x)
when (osstatus /= 0) $ osStatusError osstatus