-- |Low-level (partial) binding to the CoreMIDI services present in Mac OS X.
-- Error \"handling\" is via `fail`-s in the IO monad. 

{-# LANGUAGE 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
  , 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

--------------------------------------------------------------------------------

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
      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!"
    
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) (k-1) 
      return (xs++ys) 
 
-- decodes a single MIDIPacket, and returns the length (in bytes), the timestamp, and the list of midi messages
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 )

-- helper function  
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) (n-k)
    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..k-1]
        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"
      
-- does not include the terminating 0xf7 byte!      
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 (i-1) else sysexHelper q (i+1) 
    
--------------------------------------------------------------------------------
-- * 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
 
--------------------------------------------------------------------------------