Win32.hs

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

module System.MIDI.Win32 
  ( module System.MIDI.Base

  , Source
  , Destination
  , Connection
 
  , enumerateSources
  , enumerateDestinations
  
  , MIDIHasName
  , getName
  , getModel
  , getManufacturer

  , openSource
  , openDestination
  , close
  , send
  , sendSysEx
  , start
  , stop
  
  , getNextEvent
  , getEvents  
  , currentTime
  ) where

import Control.Monad
import Control.Concurrent.MVar
import Control.Concurrent.Chan
import Data.List
import Foreign
import Foreign.StablePtr
import System.IO.Unsafe

import System.Win32.Types
import System.Win32.MIDI 

import System.MIDI.Base

-- |Gets all the events from the buffer.
getEvents :: Connection -> IO [MidiEvent]
getEvents conn = do
  m <- getNextEvent conn
  case m of
    Nothing -> return []
    Just ev -> do
      evs <- getEvents conn
      return (ev:evs)
      
-- |Gets the next event from a buffered connection.
getNextEvent :: Connection -> IO (Maybe MidiEvent)
getNextEvent conn = case cn_fifo_cb conn of
  Right _   -> fail "this is not a buffered connection"
  Left chan -> do
    b <- isEmptyChan chan
    if b 
      then return Nothing 
      else do
        x <- readChan chan
        return (Just x)

waitFor :: IO Bool -> IO ()
waitFor check = do
  b <- check
  unless b $ waitFor check

-- |The opaque data type representing a MIDI connection.
data Connection = Connection 
  { cn_isInput    :: Bool
  , cn_handle     :: HMIDI
  , cn_time       :: MVar Word32  -- measured in milisecs  
  , cn_fifo_cb    :: Either (Chan MidiEvent) ClientCallback
  , cn_midiproc   :: FunPtr (MIDIINPROC ())
  , cn_mydata     :: StablePtr (MVar Connection)
  , cn_inbuf      :: MVar (Ptr MIDIHDR)
  , cn_sysex      :: Chan Word8   -- channel for temporarily storing sysex messages (they can be arbritrary long, but the buffer has fixed size)
  , cn_alive      :: MVar Bool
  } 

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

myMidiCallback :: HMIDIIN -> UINT -> Ptr () -> DWORD -> DWORD -> IO ()
myMidiCallback hmidi msg' myptr param1 param2 = 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
      let msg = mim msg'
      case msg of
      
        MIM_DATA -> do
          let tmsg  = translateShortMessage $ decodeShortMessage param1
          let event = MidiEvent param2 tmsg
          case (cn_fifo_cb conn) of
            Left  chan -> writeChan chan event 
            Right call -> call event 

        MIM_LONGDATA -> do
          let ptr = wordPtrToPtr (fromIntegral param1) :: Ptr MIDIHDR
          q <- peek (castPtr ptr            ) :: IO (Ptr Word8)
          n <- peek (castPtr ptr `plusPtr` 8) :: IO DWORD
          dat <- peekArray (fromIntegral n) q 
          
          sysexs <- processSysEx (cn_sysex conn) dat
          forM_ sysexs $ \dat -> do
            let event = MidiEvent param2 (SysEx dat)          
            case (cn_fifo_cb conn) of
              Left  chan -> writeChan chan event 
              Right call -> call event 
          
          -- reportedly we are not supposed to call midiInAddBuffer and the like from here, 
          -- but well, this is the simplest solution and it seems to work pretty well...
          -- (may not work on ancient versions of Windows)
          b <- isEmptyMVar (cn_time conn)  -- not really elegant hack, but the emptyness of this is also used for syncing purposes 
          unless b $ do                    -- this is here because midiInReset can block if we want to free them before it returned...
            freeMidiInHeader hmidi ptr    
            new <- midiInAddBuffer hmidi midiInBufferSize  
            swapMVar (cn_inbuf conn) new
            return ()

        MIM_CLOSE -> do
          swapMVar (cn_alive conn) False
          return ()
          
        _ -> return ()
          
      when (msg /= MIM_CLOSE) $ putMVar mv conn      -- do not forget !!!
  
-- I'm not sure, but getChanContents seems to be too lazy for our purposes  
readChanList :: Chan a -> IO [a]
readChanList chan = do
  b <- isEmptyChan chan  
  if b 
    then return []
    else do
      x <- readChan chan
      xs <- readChanList chan
      return (x:xs)

-- the Win32 SysEx support is somewhat brain-dead...
processSysEx :: Chan Word8 -> [Word8] -> IO [[Word8]]
processSysEx _    []  = return []
processSysEx chan dat = do
  case (findIndex (==0xf7) dat) of
    Nothing -> do
      writeList2Chan chan dat
      return []          
    Just k  -> do
      xs <- readChanList chan  
      let (aa,bb) = splitAt k dat
          ys = xs ++ aa
          ev = if (head ys == 0xf0) then tail ys else ys 
      evs <- processSysEx chan (tail bb)
      return (ev:evs)
  
midiInBufferSize = 64

-- |Opens a MIDI source.
-- There are two possibilites to receive MIDI messages. The user can either support 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 mcallback = do
  myData <- newEmptyMVar :: IO (MVar Connection)
  sp <- newStablePtr myData 
  the_callback <- mkMIDIPROC myMidiCallback
  alive <- newMVar True
  fifo_cb <- case mcallback of
    Just cb -> return $ Right cb
    Nothing -> liftM Left $ newChan 
  time <- newEmptyMVar 
  handle <- midiInOpen src the_callback (castStablePtrToPtr sp) (CALLBACK_FUNCTION False)
  bufmv <- newEmptyMVar 
  sysex <- newChan   -- channel for temporarily storing sysex messages (they can be arbritrary long, but the buffer has fixed size)
  let conn = Connection True handle time fifo_cb the_callback sp bufmv sysex alive 
  putMVar myData conn
  return conn 
  
-- |Opens a MIDI destination.
openDestination :: Destination -> IO Connection  
openDestination dst = do
  alive <- newMVar True
  handle <- midiOutOpen dst nullFunPtr nullPtr CALLBACK_NULL
  time <- newEmptyMVar 
  let conn = Connection False handle time undefined undefined undefined undefined undefined alive
  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 -> midiOutSend (cn_handle conn) 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 in the data.
sendSysEx :: Connection -> [Word8] -> IO ()
sendSysEx conn msg = do
  let handle = cn_handle  conn
  case cn_isInput conn of 
    True  -> fail "sending SysEx messages to midi sources is not supported under Win32"
    False -> midiOutSendSysEx handle msg

-- |Starts a connection. This is required for receiving MIDI messages, and also for starting the clock.
start :: Connection -> IO ()
start conn = do
  let handle = cn_handle conn
  b <- isEmptyMVar (cn_time conn)
  if b
    then do
      time <- timeGetTime
      putMVar (cn_time conn) time
      case cn_isInput conn of 
        True  -> do
          buf <- midiInAddBuffer handle midiInBufferSize
          putMVar (cn_inbuf conn) buf
          midiInStart handle
        False -> return ()
    else putStrLn "warning: you shouldn't call start twice"  

-- |Starts a connection. This is required for receiving MIDI messages, and also for starting the clock.
stop :: Connection -> IO ()
stop conn = do 
  let handle = cn_handle conn
  b <- isEmptyMVar (cn_time conn)
  if not b
    then do
      takeMVar (cn_time conn)   -- also used for syncing!
      case cn_isInput conn of 
        True  -> do
          midiInReset handle
          hdr <- takeMVar (cn_inbuf conn)
          freeMidiInHeader handle hdr
          midiInStop  handle
        False -> return ()
      return ()
    else putStrLn "warning: you shouldn't call stop twice"  
  
-- |Resets a `Connection`.
reset :: Connection -> IO ()
reset conn = do
  let handle = cn_handle conn
  case cn_isInput conn of 
    True  -> midiInReset  handle
    False -> midiOutReset handle

-- |Closes a `Connection`
close :: Connection -> IO ()
close conn = do
  let handle = cn_handle conn
  case cn_isInput conn of 
    True  -> midiInClose  handle
    False -> midiOutClose handle

-- called by "close" 
cleanup :: Connection -> IO ()
cleanup conn = case (cn_isInput conn) of
  True  -> do
    waitFor (liftM not $ readMVar $ cn_alive conn)
    freeHaskellFunPtr (cn_midiproc conn)
    freeStablePtr     (cn_mydata   conn)
  False -> return ()