MacOSX.hs

-- | A lowest common denominator interface to the Win32 and MacOSX MIDI bindings, MacOSX part.

module System.MIDI.MacOSX
  ( module System.MIDI.Base

    -- * MIDI sources and destionations 
  , Source
  , Destination
  , Connection
 
  , enumerateSources
  , enumerateDestinations
  
  , MIDIHasName  
  , getName
  , getModel
  , getManufacturer

    -- * connecting to a MIDI source or destination
  , openSource
  , openDestination
  , close
  , start
  , stop
  
    -- * sending messages
  , send
  , sendSysEx
  
    -- * manual polling of events 
  , getNextEvent
  , checkNextEvent
  , getEvents 
  , getEventsUntil 

  , getNextEvent'
  , checkNextEvent'
  , getEvents'
  , getEventsUntil' 
    
    -- * querying time
  , currentTime
  
    -- * creating a MIDI host (OSX only)
  , createSource
  , createDestination
  , disposeConnection
  
  ) where

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

import System.MIDI.Base

import Control.Monad
import Control.Concurrent.MVar
--import Control.Concurrent.Chan

import Control.Concurrent.STM
import Control.Concurrent.STM.TChan
import Control.Exception.Base

import Data.List
import Foreign
import Foreign.StablePtr
import System.IO.Unsafe as Unsafe

import System.MacOSX.CoreFoundation
import System.MacOSX.CoreAudio
import System.MacOSX.CoreMIDI hiding (ShortMessage) 
import qualified System.MacOSX.CoreMIDI as CM

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

-- there are two identical ShortMessage definitions in two separate modules;
-- these function bridges them
_to_CM_SM :: ShortMessage -> CM.ShortMessage
_to_CM_SM (ShortMessage a b c d) = CM.ShortMessage a b c d

_from_CM_SM :: CM.ShortMessage -> ShortMessage
_from_CM_SM (CM.ShortMessage a b c d) = ShortMessage a b c d

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

getEvents :: Connection -> IO [MidiEvent]
getEvents conn = atomically $ getEvents' conn

getEventsUntil :: Connection -> TimeStamp -> IO [MidiEvent]
getEventsUntil conn tstamp = atomically $ getEventsUntil' conn tstamp

getNextEvent :: Connection -> IO (Maybe MidiEvent)
getNextEvent conn = atomically $ getNextEvent' conn

checkNextEvent :: Connection -> IO (Maybe MidiEvent)
checkNextEvent conn = atomically $ checkNextEvent' conn

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

-- | Gets all the events from the buffer.
getEvents' :: Connection -> STM [MidiEvent]
getEvents' conn = do
  m <- getNextEvent' conn
  case m of
    Nothing -> return []
    Just ev -> do
      evs <- getEvents' conn
      return (ev:evs)

-- | Gets all the events with timestamp less than the specified from the buffer.
getEventsUntil' :: Connection -> TimeStamp -> STM [MidiEvent]
getEventsUntil' conn until = do
  m <- checkNextEvent' conn
  case m of
    Nothing -> return []
    Just ev@(MidiEvent ts _) -> do
      if ts < until 
        then do
          getNextEvent' conn -- remove from the buffer
          evs <- getEventsUntil' conn until
          return (ev:evs)
        else
          return []
          
-- | Gets the next event from a buffered connection.
getNextEvent' :: Connection -> STM (Maybe MidiEvent)
getNextEvent' conn = case cn_fifo_cb conn of
  Right _   -> stmFail "this is not a buffered connection"
  Left chan -> do
    b <- isEmptyTChan chan
    if b 
      then return Nothing 
      else do
        x <- readTChan chan
        return (Just x)

-- | Checks the next event from a buffered connection, but does not remove it from the buffer
checkNextEvent' :: Connection -> STM (Maybe MidiEvent)
checkNextEvent' conn = case cn_fifo_cb conn of
  Right _   -> stmFail "this is not a buffered connection"
  Left chan -> do
    b <- isEmptyTChan chan
    if b 
      then return Nothing 
      else do
        x <- readTChan chan
        unGetTChan chan x
        return (Just x)

stmFail :: String -> STM a
stmFail msg = throwSTM (MidiException msg)

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

type Client      = MIDIClientRef
type Device      = MIDIDeviceRef
type Port        = MIDIPortRef

-- |The opaque data type representing a MIDI connection
data Connection = Connection
  { cn_isInput     :: Bool
  , cn_isNew       :: Bool            -- did we create the endpoint?
  , cn_port        :: MIDIPortRef
  , cn_endpoint    :: MIDIEndpointRef
  , cn_time        :: MVar UInt64     -- measured in nanosecs
  , cn_alive       :: MVar Bool
  , cn_fifo_cb     :: Either (TChan MidiEvent) ClientCallback
  , cn_midiproc    :: FunPtr (MIDIReadProc () ())
  , cn_mydata      :: StablePtr (MVar Connection)
  , cn_sysex       :: MVar SysExStatus   -- osx api for long sysexs is fucking stupid
  }

----- automatic client creation 

client :: MVar Client
client = Unsafe.unsafePerformIO $ newEmptyMVar :: MVar Client

{-
#ifdef __GLASGOW_HASKELL__
clientFinalizer :: IO ()
clientFinalizer = do
  c <- readMVar client
  disposeClient c
#endif
-}

getClient :: IO MIDIClientRef
getClient = do
  b <- isEmptyMVar client
  if b 
    then do
      x <- newClient "HaskellMidi" 
      putMVar client x
{-
#ifdef __GLASGOW_HASKELL__
      addMVarFinalizer client clientFinalizer      -- uh-oh, that's not a good idea (not in the present form)
#endif      
-}
      return x
    else readMVar client

-- |Returns the time elapsed since the last `start` call, in milisecs.
currentTime :: Connection -> IO Word32
currentTime conn = do
  t  <- audioGetCurrentTimeInNanos 
  t0 <- readMVar (cn_time conn)
  return (nanoToMili $ t-t0)

nanoToMili :: UInt64 -> Word32
nanoToMili n = fromIntegral $ div n 1000000

convertShortMessage :: UInt64 -> (MIDITimeStamp,[Word8]) -> IO MidiEvent
convertShortMessage t0 (ts',bytes) = do
  ts <- audioConvertHostTimeToNanos ts'
  return $ MidiEvent (nanoToMili $ ts-t0) (translateShortMessage $ _from_CM_SM $ decodeShortMessage bytes) 

myMIDIReadProc :: Ptr MIDIPacket -> Ptr () -> Ptr () -> IO ()
myMIDIReadProc packets myptr _  = do
  let stabptr = castPtrToStablePtr myptr :: StablePtr (MVar Connection)
  mv <- deRefStablePtr stabptr :: IO (MVar Connection)
  mconn <- tryTakeMVar mv  -- we are also "blocking" (handling) further callbacks this way
  case mconn of 
    Nothing   -> return ()
    Just conn -> do
      time0 <- readMVar (cn_time conn)
      
      sysex_status <- takeMVar (cn_sysex conn)
      (list1,sysex_status') <- depackMIDIPacketList packets sysex_status
      putMVar (cn_sysex conn) sysex_status'
      
      let (normal,sysex') = partition (\(_,bytes) -> isShortMessage bytes) list1
      sysexs <- forM sysex' $ \(ts',bytes) -> do
        ts <- audioConvertHostTimeToNanos ts'
        return $ MidiEvent (nanoToMili $ ts-time0) (SysEx $ init $ tail bytes)
      normals <- mapM (convertShortMessage time0) normal
      let events = sysexs ++ normals
      case (cn_fifo_cb conn) of
        Left  chan -> atomically $ mapM_ (writeTChan chan) events -- writeList2Chan chan events 
        Right call -> mapM_ call events 
      putMVar mv conn      -- do not forget to put it back!

-- |Opens a MIDI Source.
-- There are two possibilites to receive MIDI messages. The user can either supply a callback function,
-- or get the messages from an asynchronous buffer. However, mixing the two approaches is not allowed.
openSource :: Source -> Maybe ClientCallback -> IO Connection 
openSource src@(Source endpoint) mcallback = do
 
  client <- getClient
  
  myData <- newEmptyMVar :: IO (MVar Connection)
  sp <- newStablePtr myData 
  the_callback <- mkMIDIReadProc myMIDIReadProc

  time  <- newEmptyMVar 
  alive <- newMVar True

  fifo_cb <- case mcallback of
    Just cb -> return $ Right cb
    Nothing -> liftM Left $ newTChanIO 

  inport <- newInputPort client "Input Port" the_callback (castStablePtrToPtr sp) 
    
  sysex <- newMVar NoSysEx
  
  let conn = Connection True False inport endpoint time alive fifo_cb the_callback sp sysex
  putMVar myData conn
  return conn 

-- |Opens a MIDI Destination.
openDestination :: Destination -> IO Connection 
openDestination dst@(Destination endpoint) = do

  client <- getClient 
  outport <- newOutputPort client "Output Port" 
  alive <- newMVar True
  time  <- newEmptyMVar 

  let conn = Connection False False outport endpoint time alive undefined undefined undefined undefined
  return conn 

sendShortMessage :: Connection -> ShortMessage -> IO ()
sendShortMessage conn msg = case cn_isInput conn of
  True  -> fail "sending short messages to midi sources is not supported"
  False -> case cn_isNew conn of 
    False -> midiSend (cn_port conn) (Destination $ cn_endpoint conn) (_to_CM_SM msg)
    True  -> do
      tstamp <- audioGetCurrentTimeInNanos 
      midiReceivedStamped (Destination $ cn_endpoint conn) tstamp (_to_CM_SM msg) 
    
-- |Sends a short message. The connection must be a `Destination`.
send :: Connection -> MidiMessage -> IO ()
send conn msg = sendShortMessage conn (untranslateShortMessage msg)
 
-- |Sends a system exclusive message. You shouldn't include the starting \/ trailing bytes 0xF0 and 0xF7.
sendSysEx :: Connection -> [Word8] -> IO ()
sendSysEx conn dat = midiSendSysEx (cn_endpoint conn) dat 
 
-- |Starts a connection. This is required for receiving MIDI messages, and also for starting the clock.
start :: Connection -> IO ()
start conn = do 
  b <- isEmptyMVar (cn_time conn)
  if b
    then do
      hosttime <- audioGetCurrentTimeInNanos
      putMVar (cn_time conn) hosttime
      case cn_isInput conn of 
        True  -> when (not (cn_isNew conn)) $ do
          connectToSource (cn_port conn) (Source $ cn_endpoint conn) nullPtr
        False -> return ()
    else putStrLn "warning: you shouldn't call start twice"  

-- |Stops a connection.
stop :: Connection -> IO ()
stop conn = do
  b <- isEmptyMVar (cn_time conn)
  if not b
    then do
      takeMVar (cn_time conn) 
      case cn_isInput conn of 
        True  -> when (not (cn_isNew conn)) $ do
          disconnectFromSource (cn_port conn) (Source $ cn_endpoint conn)
        False -> return ()
    else putStrLn "warning: you shouldn't call stop twice"  
  
-- |Closes a MIDI Connection
close :: Connection -> IO ()
close conn = do
  when (cn_isInput conn) $ do
    b <- isEmptyMVar (cn_time conn)
    when (not b) (stop conn)     
  unless (cn_isNew conn && cn_isInput conn) $ disposePort (cn_port conn)      -- inport was undefined in new & input case (see below)
  cleanup conn
 
-- called by "close"; not exposed. 
cleanup :: Connection -> IO ()
cleanup conn = case cn_isInput conn of
  True  -> do
    freeHaskellFunPtr (cn_midiproc conn)
    freeStablePtr     (cn_mydata   conn)
  False -> return ()

--------------------------------------------------------------------------------
-- * Being a MIDI host (so other programs can connect to us). OSX only

-- | Creates a new MIDI destination (which is a source for /us/), to which other programs can connect to (OSX only).
createDestination :: String -> Maybe ClientCallback -> IO Connection
createDestination name mcallback = do
  client <- getClient
  
  myData <- newEmptyMVar :: IO (MVar Connection)
  sp <- newStablePtr myData 
  the_callback <- mkMIDIReadProc myMIDIReadProc

  time  <- newEmptyMVar 
  alive <- newMVar True

  fifo_cb <- case mcallback of
    Just cb -> return $ Right cb
    Nothing -> liftM Left $ newTChanIO 

  Source endpoint <- newDestination client name the_callback (castStablePtrToPtr sp) 
    
  sysex <- newMVar NoSysEx
  
  let inport = error "createDestination/inport"
      conn = Connection True True inport endpoint time alive fifo_cb the_callback sp sysex
  putMVar myData conn
  return conn 


-- | Creates a new MIDI source (which is a destination for /us/), to which other programs can connect to (OSX only).
createSource :: String -> IO Connection
createSource name = do
  client <- getClient
  Destination endpoint <- newSource client name
  
  outport <- newOutputPort client "Output Port" 
  alive <- newMVar True
  time  <- newEmptyMVar 

  let conn = Connection False True outport endpoint time alive undefined undefined undefined undefined
  return conn 

-- | Dispose a connection we created earlier.
disposeConnection :: Connection -> IO ()
disposeConnection conn = do
  disposeEndpoint (cn_endpoint conn)
  
--------------------------------------------------------------------------------