packages feed

hamid 0.8 → 0.9

raw patch · 15 files changed

+2028/−2028 lines, 15 filesdep ~HCodecsdep ~newtype

Dependency ranges changed: HCodecs, newtype

Files

hamid.cabal view
@@ -1,8 +1,8 @@  name:               hamid-version:            0.8+version:            0.9 cabal-version:      >= 1.6-synopsis:           Binding to the OS level MIDI services (fork of system-midi).+synopsis:           Binding to the OS level Midi services (fork of system-midi).  description:        Cross-platform binding to Midi libraries.                      Supports OS X and Windows (limited testing).@@ -33,14 +33,14 @@    library     build-depends:-        base        >= 4 && < 5,-        HCodecs,-        newtype+        base        >= 4     && < 5,+        HCodecs     >= 0.2.2 && < 1,+        newtype     >= 0.2   && < 1     hs-source-dirs: src     exposed-modules:-        System.MIDI+        System.Midi     other-modules:-        System.MIDI.Base+        System.Midi.Base     extensions:         ForeignFunctionInterface,         CPP,@@ -52,25 +52,25 @@         other-modules:             System.MacOSX.CoreFoundation,             System.MacOSX.CoreAudio,-            System.MacOSX.CoreMIDI-            System.MIDI.MacOSX+            System.MacOSX.CoreMidi+            System.Midi.MacOSX         frameworks:             CoreFoundation,             CoreAudio,-            CoreMIDI+            CoreMidi      if os(windows)         build-depends:             Win32         other-modules:-            System.Win32.MIDI-            System.MIDI.Win32+            System.Win32.Midi+            System.Midi.Win32         extra-libraries:             winmm      if !os(darwin) && !os(windows)         other-modules:-            System.MIDI.Placeholder+            System.Midi.Placeholder
− src/System/MIDI.hs 
@@ -1,226 +0,0 @@--{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}-------- Module      : System.MIDI--- Version     : 0.1--- License     : BSD3--- Author      : Balazs Komuves--- Maintainer  : bkomuves+hmidi@gmail.com--- Stability   : experimental--- Portability : not portable--- Tested with : GHC 6.8.2------- | A lowest common denominator interface to the Win32 and MacOSX MIDI bindings. --- Error handling is via `fail`-s in the IO monad. --module System.MIDI (-        -- * Messages-        MidiTime,-        MidiMessage,-        MidiEvent,        --        -- * Input and output-        MidiHasName(..),--        -- ** Sources and Destinations-        Source,-        sources,-        Destination,-        destinations,-        -        -- ** Streams-        openSource,-        openDestination,-        Stream,-        close,-        start,-        stop,--        -- * Sending-        send,-        -- sendSysEx,--        -- * Receiving-        getNextEvent,-        getEvents,--        -- * Timer-        currentTime,    -  ) where--import Data.Word (Word8,Word32)-import System.MIDI.Base hiding (MidiEvent, MidiMessage)-import System.IO.Unsafe (unsafePerformIO)--import qualified Codec.Midi as C--#ifdef mingw32_HOST_OS-import qualified System.MIDI.Win32 as S-#define HMIDI_SUPPORTED_OS-#endif--#ifdef darwin_HOST_OS-import qualified System.MIDI.MacOSX as S-#define HMIDI_SUPPORTED_OS-#endif---- this is just to be able to produce a Haddock documentation on a not supported system (eg. Linux)-#ifndef HMIDI_SUPPORTED_OS-import qualified System.MIDI.Placeholder as S-#endif--type MidiTime       = Word32-type MidiMessage    = C.Message-type MidiEvent      = (MidiTime, C.Message)--class MidiHasName a where-    name :: a -> IO String--instance MidiHasName Source where-    name = S.getName . getSource--instance MidiHasName Destination where-    name = S.getName . getDestination-    ---- All the definitions in this file are neccessary to be able to have a nice Haddock-generated--- documentation independently of the platform. Though I still don't know how to generate documentation--- for a platform-specific module while being on an a different platform (probably not at all possible --- at present?) ---- | The opaque data type representing a MIDI source.-newtype Source = Source { getSource :: S.Source }-    deriving (Eq)---- | The opaque data type representing a MIDI destination.-newtype Destination = Destination { getDestination :: S.Destination }-    deriving (Eq)--instance Show Source where-    show = (\n -> "<Source: "++n++">") . unsafePerformIO . name--instance Show Destination where-    show = (\n -> "<Destination: "++n++">") . unsafePerformIO . name---- | The opaque data type representing a MIDI connection.-newtype Stream = Stream { getStream :: S.Connection }---- | Enumerates the MIDI sources present in the system.-sources :: IO [Source]-sources = fmap (fmap Source) S.enumerateSources---- | Enumerates the MIDI destinations present in the system.-destinations :: IO [Destination]-destinations = fmap (fmap Destination) S.enumerateDestinations---- | These functions return the name, model and manufacturer of a MIDI source \/ destination.--- --- Note: On Win32, only `getName` returns a somewhat meaningful string at the moment.-getName :: S.MIDIHasName a => a -> IO String-getModel :: S.MIDIHasName a => a -> IO String-getManufacturer :: S.MIDIHasName a => a -> IO String--getName = S.getName-getModel = S.getModel-getManufacturer = S.getManufacturer---- | 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 (MidiTime -> C.Message -> IO ()) -> IO Stream -openSource s cb = fmap Stream $ S.openSource (getSource s) (fmap mkCb cb)-    where-        mkCb f (S.MidiEvent ts msg) = f ts (expMsg msg)----- | Opens a MIDI Destination.-openDestination :: Destination -> IO Stream -openDestination = fmap Stream . S.openDestination . getDestination----- | Gets the next event from a buffered connection (see also `openSource`)-getNextEvent :: Stream -> IO (Maybe MidiEvent)-getNextEvent = fmap (fmap g) . S.getNextEvent . getStream-    where-        g (S.MidiEvent ts msg) = (ts, expMsg msg)---- | Gets all the events from the buffer (see also `openSource`)-getEvents :: Stream -> IO [MidiEvent]-getEvents = fmap (fmap g) . S.getEvents . getStream-    where-        g (S.MidiEvent ts msg) = (ts, expMsg msg)-        --- | Sends a short message. The connection must be a `Destination`.-send :: Stream -> C.Message -> IO ()-send c = S.send (getStream c) . impMsg- -{---- | Sends a system exclusive message. You shouldn't include the starting \/ trailing bytes 0xF0 and 0xF7.--- --- Note: On Win32, the connection must be a `Destination`-sendSysEx :: Stream -> [Word8] -> IO ()-sendSysEx = S.sendSysEx--}- --- | Starts a connection. This is required for receiving MIDI messages, and also for starting the clock.-start :: Stream -> IO ()-start = S.start . getStream---- | Stops a connection.-stop :: Stream -> IO ()-stop = S.stop . getStream-    --- | Closes a MIDI Stream.-close :: Stream -> IO ()-close = S.close . getStream- --- | Returns the time elapsed since the last `start` call, in milisecs.-currentTime :: Stream -> IO MidiTime-currentTime = S.currentTime . getStream----impMsg :: C.Message -> S.MidiMessage-impMsg (C.NoteOff ch k _)       = S.MidiMessage ch (S.NoteOff k)-impMsg (C.NoteOn  ch k v)       = S.MidiMessage ch (S.NoteOn k v) -impMsg (C.ControlChange ch c v) = S.MidiMessage ch (S.CC c v)-impMsg (C.ProgramChange ch a)   = S.MidiMessage ch (S.ProgramChange a)-impMsg (C.PitchWheel ch a)      = S.MidiMessage ch (S.PitchWheel a)--expMsg :: S.MidiMessage -> C.Message-expMsg (S.MidiMessage ch (S.NoteOff k)          ) = C.NoteOff ch k 0-expMsg (S.MidiMessage ch (S.NoteOn k v)	        ) = C.NoteOn  ch k v-expMsg (S.MidiMessage ch (S.CC c v)	            ) = C.ControlChange ch c v-expMsg (S.MidiMessage ch (S.ProgramChange a)	) = C.ProgramChange ch a-expMsg (S.MidiMessage ch (S.PitchWheel a)	    ) = C.PitchWheel ch a--- expMsg (S.MidiMessage ch (S.PolyAftertouch k v) ) = undefined--- expMsg (S.MidiMessage ch (S.Aftertouch a)        ) = undefined--- expMsg (S.SysEx [Word8]                    ) = undefined--- expMsg (S.SongPosition p                   ) = undefined--- expMsg (S.SongSelect s                         ) = undefined--- expMsg (S.TuneRequest                          ) = undefined--- expMsg (S.SRTClock                             ) = undefined--- expMsg (S.SRTStart                             ) = undefined--- expMsg (S.SRTContinue                          ) = undefined--- expMsg (S.SRTStop                              ) = undefined--- expMsg (S.ActiveSensing                        ) = undefined--- expMsg (S.Reset                                ) = undefined--- expMsg (S.Undefined                           ) = undefined--------------
− src/System/MIDI/Base.hs 
@@ -1,138 +0,0 @@---- |The hardware-independent part of the MIDI binding.--{-# LANGUAGE CPP #-}-module System.MIDI.Base -    ( TimeStamp-    , MidiMessage'(..)-    , MidiMessage(..)-    , MidiEvent(..)-    , ClientCallback-    , ShortMessage(..)-    , translateShortMessage-    , untranslateShortMessage-    , shortMessage-    ) where--import Data.Bits-import Data.Word--type TimeStamp = Word32 ---- |A \"regular\" MIDI message.------ Remark: `NoteOff` not having a velocity field is a design decision, and a questionable one. According to the--- MIDI standard, NoteOff also has a velocity. However, most keyboards do not use this feature (send the default--- value 64), and there are keyboards which do not send NoteOff messages at all, but send NoteOn messages with--- zero velocity instead (for example the EMU Xboard series). I don't know what would be a good solution. --- At the moment, the code auto-translates NoteOn messages with zero velocity to NoteOff messages, and the--- NoteOff velocity is ignored. This behaviour can be inverted with the Cabal flag NoNoteOff.-data MidiMessage' -    = NoteOff         !Int          -- ^ Note Off (key)-    | NoteOn          !Int !Int     -- ^ Note On (key, velocity)-    | PolyAftertouch  !Int !Int     -- ^ Polyphonic key pressure (key, pressure)-    | CC              !Int !Int     -- ^ Control Change (controller, value)-    | ProgramChange   !Int          -- ^ Program Change (program)-    | Aftertouch      !Int          -- ^ Global aftertouch (pressure)-    | PitchWheel      !Int          -- ^ Pitch wheel (value, from -8192..+8191)-    deriving (Show,Eq)-    --- |The type representing a MIDI message.  -data MidiMessage -    = MidiMessage  !Int !MidiMessage'    -- ^ first argument is the MIDI channel (1..16)-    | SysEx        [Word8]               -- ^ not including the bytes 0xf0, 0xf7-    | SongPosition !Int-    | SongSelect   !Int -    | TuneRequest-    | SRTClock-    | SRTStart-    | SRTContinue -    | SRTStop-    | ActiveSensing-    | Reset-    | Undefined-    deriving (Show,Eq)-    --- |The type representing a timestamped MIDI message. --- Time is measured in milisecs elapsed since the last call to `System.MIDI.start`.-data MidiEvent = MidiEvent !TimeStamp !MidiMessage deriving (Show,Eq)---- |Type of the user callback function.  -type ClientCallback = MidiEvent -> IO ()-    -translateShortMessage :: ShortMessage -> MidiMessage-translateShortMessage (ShortMessage chn msg bt1 bt2) =-    if msg < 15 -      then MidiMessage (fromIntegral chn + 1) $ translate' msg k v-      else translate'' chn k v-    where-      k = fromIntegral bt1-      v = fromIntegral bt2--translate' msg k v = case msg of-#ifdef HMIDI_NO_NOTEOFF-     8  -> NoteOn k 0-     9  -> NoteOn k v-#else-     8  -> NoteOff k-     9  -> if v>0 then NoteOn k v else NoteOff k-#endif-     10 -> PolyAftertouch k v-     11 -> CC k v-     12 -> ProgramChange k-     13 -> Aftertouch k-     14 -> PitchWheel (k + shiftL v 7 - 8192)--translate'' lo a b = case lo of-    0  -> Undefined-    1  -> Undefined-    2  -> SongPosition (a + shiftL b 7)-    3  -> SongSelect a -    4  -> Undefined-    5  -> Undefined-    6  -> TuneRequest-    7  -> Undefined-    8  -> SRTClock-    9  -> Undefined-    10 -> SRTStart-    11 -> SRTContinue-    12 -> SRTStop-    13 -> Undefined-    14 -> ActiveSensing-    15 -> Reset- -untranslateShortMessage :: MidiMessage -> ShortMessage-untranslateShortMessage (MidiMessage chn msg') = -    case msg' of-      NoteOff k           -> shortMessage chn  8 k 64-      NoteOn  k v         -> shortMessage chn  9 k v-      PolyAftertouch k v  -> shortMessage chn 10 k v-      CC k v              -> shortMessage chn 11 k v-      ProgramChange k     -> shortMessage chn 12 k 0-      Aftertouch k        -> shortMessage chn 13 k 0-      PitchWheel n        -> let m = min 16383 $ max 0 $ n + 8192 in shortMessage chn 14 (m.&.127) (shiftR m 7) --untranslateShortMessage (SongPosition p) = shortMessage 15  3 (p.&.7) (shiftR p 7) -untranslateShortMessage (SongSelect   s) = shortMessage 15  3 (fromIntegral s) 0 -untranslateShortMessage  TuneRequest     = shortMessage 15  6 0 0 -untranslateShortMessage  SRTClock        = shortMessage 15  8 0 0 -untranslateShortMessage  SRTStart        = shortMessage 15 10 0 0 -untranslateShortMessage  SRTContinue     = shortMessage 15 11 0 0 -untranslateShortMessage  SRTStop         = shortMessage 15 12 0 0 -untranslateShortMessage  ActiveSensing   = shortMessage 15 14 0 0 -untranslateShortMessage  Reset           = shortMessage 15 15 0 0 -untranslateShortMessage  Undefined       = error "cannot untranslate Undefined" -untranslateShortMessage (SysEx _)        = error "cannot untranslate SysEx" - -shortMessage :: Int -> Int -> Int -> Int -> ShortMessage-shortMessage chn msg bt1 bt2 = -    ShortMessage (fromIntegral chn - 1) (fromIntegral msg) (fromIntegral bt1) (fromIntegral bt2)- --- |Low level stuff.-data ShortMessage = ShortMessage -    { sm_channel :: Word8-    , sm_msg     :: Word8 -    , sm_byte1   :: Word8-    , sm_byte2   :: Word8 -    } deriving Show-
− src/System/MIDI/MacOSX.hs 
@@ -1,236 +0,0 @@---- |A lowest common denominator interface to the Win32 and MacOSX MIDI bindings, MacOSX part.--module System.MIDI.MacOSX-    ( module System.MIDI.Base--    , Source-    , Destination-    , Connection- -    , enumerateSources-    , enumerateDestinations-    -    , MIDIHasName(..)  --    , openSource-    , openDestination-    , close-    , send-    , sendSysEx-    , start-    , stop-    -    , getNextEvent-    , getEvents-    , currentTime-    -    ) where--import System.MIDI.Base--import Control.Monad-import Control.Concurrent.MVar-import Control.Concurrent.Chan-import Data.List-import Foreign hiding (unsafePerformIO)-import Foreign.StablePtr-import System.IO.Unsafe--import System.MacOSX.CoreFoundation-import System.MacOSX.CoreAudio-import System.MacOSX.CoreMIDI---- |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)--type Client      = MIDIClientRef-type Device      = MIDIDeviceRef-type Port        = MIDIPortRef---- |The opaque data type representing a MIDI connection-data Connection = Connection-    { cn_isInput     :: Bool-    , cn_port        :: MIDIPortRef-    , cn_endpoint    :: MIDIEndpointRef-    , cn_time        :: MVar UInt64     -- measured in nanosecs-    , cn_alive       :: MVar Bool-    , cn_fifo_cb     :: Either (Chan MidiEvent) ClientCallback-    , cn_midiproc    :: FunPtr (MIDIReadProc () ())-    , cn_mydata      :: StablePtr (MVar Connection)-    }------- automatic client creation --client = 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 $ 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)-        list1 <- depackMIDIPacketList packets-        let (normal,sysex') = partition (\(_,bytes) -> isShortMessage bytes) list1-        sysexs <- forM sysex' $ \(ts',bytes) -> do-          ts <- audioConvertHostTimeToNanos ts'-          return $ MidiEvent (nanoToMili $ ts-time0) (SysEx $ tail bytes)-        normals <- mapM (convertShortMessage time0) normal-        let events = sysexs ++ normals-        case (cn_fifo_cb conn) of-          Left  chan -> 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 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@(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 $ newChan --    inport <- newInputPort client "Input Port" the_callback (castStablePtrToPtr sp) -      -    let conn = Connection True inport endpoint time alive fifo_cb the_callback sp -    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 outport endpoint time alive 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 -> midiSend (cn_port conn) (Destination $ cn_endpoint 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.-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  -> 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  -> disconnectFromSource (cn_port conn) (Source $ cn_endpoint conn)-          False -> return ()-      else putStrLn "warning: you shouldn't call stop twice"  -    --- |Closes a MIDI Connection-close conn = do-    when (cn_isInput conn) $ do-      b <- isEmptyMVar (cn_time conn)-      when (not b) (stop conn) -    disposePort (cn_port conn)-    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 ()-
− src/System/MIDI/Placeholder.hs 
@@ -1,59 +0,0 @@---- | This is just to be able to produce a Haddock documentation on a Linux system--module System.MIDI.Placeholder-    ( 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 System.MIDI.Base--data Source                 = Source      deriving (Eq, Ord, Show)-data Destination            = Destination deriving (Eq, Ord, Show)-data Connection             = Connection  deriving (Eq, Ord, Show)--enumerateSources            = noImpl-enumerateDestinations       = noImpl--class MIDIHasName a where-getName                     = noImpl -getManufacturer             = noImpl -getModel                    = noImpl -openSource                  = noImpl-openDestination             = noImpl-close                       = noImpl-send                        = noImpl-sendSysEx                   = noImpl-start                       = noImpl-stop                        = noImpl--getNextEvent                = noImpl-getEvents                   = noImpl-currentTime                 = noImpl--noImpl = error "Not implemented"-
− src/System/MIDI/Win32.hs 
@@ -1,275 +0,0 @@---- |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 ()-
− src/System/MacOSX/CoreMIDI.hs 
@@ -1,573 +0,0 @@---- |Low-level 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-    , midiSend'-    , midiSendList-    , midiSendList'-    , midiSendSysEx--    -- types  -    , OpaqueMIDIClient-    , OpaqueMIDIObject-    , OpaqueMIDIDevice-    , OpaqueMIDIEntity-    , OpaqueMIDIEndpoint-    , OpaqueMIDIPort-    -    , MIDIClientRef-    , MIDIObjectRef-    , MIDIDeviceRef-    , MIDIEntityRef-    , MIDIEndpointRef-    , MIDIPortRef--    , MIDITimeStamp-    , MIDIReadProc-    , mkMIDIReadProc-    , MIDIPacket-    , Source(..)-    , Destination(..)--    -- helper functions to write callbacks-    , depackMIDIPacketList-    , depackSingleMIDIPacket-    , decodeShortMessage -    , isShortMessage -    ) where--import Control.Monad-import Control.Concurrent.MVar-import Foreign hiding (unsafePerformIO)-import Foreign.Marshal-import System.IO.Unsafe--import System.MIDI.Base-import System.MacOSX.CoreFoundation--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         = unsafePerformIO $ peek ptr_kMIDIPropertyName-kMIDIPropertyManufacturer = unsafePerformIO $ peek ptr_kMIDIPropertyManufacturer-kMIDIPropertyModel        = 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------- 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 -> 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 - ------ encode / decode --encodeShortMessageList :: [ShortMessage] -> [Word8]-encodeShortMessageList list = concatMap encodeShortMessage list--encodeShortMessage :: ShortMessage -> [Word8]-encodeShortMessage (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]-    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 <- sysexloop p 2 -    xs <- mapM (peekElemOff p) [0..n]-    return ( n+2 , xs ) --sysexloop :: Ptr Word8 -> Int -> IO Int-sysexloop q i = do-    x <- peekElemOff q i-    if x == 0xf7 then return (i-1) else sysexloop q (i+1) -      ------ Send---- |Sends a short message with timestamp "now".-midiSend :: MIDIPortRef -> Destination -> ShortMessage -> IO () -midiSend port dst msg     = midiSend' port dst 0 msg---- |Sends a list of short messages with timestamp "now".-midiSendList :: MIDIPortRef -> Destination -> [ShortMessage] -> IO () -midiSendList port dst msglist = midiSendList' port dst 0 msglist---- |Sends a short message with the given timestamp.-midiSend' :: MIDIPortRef -> Destination -> MIDITimeStamp -> ShortMessage -> IO ()-midiSend' 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.-midiSendList' :: MIDIPortRef -> Destination -> MIDITimeStamp -> [ShortMessage] -> IO ()-midiSendList' 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--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_MIDIGetNumberOfSources-    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-    --- |Disposes an existing MIDI endpoint.-disposeEndpoint :: Endpoint a => a -> IO ()  -disposeEndpoint x = do-    osstatus <- c_MIDIEndpointDispose (endpoint x)-    when (osstatus /= 0) $ osStatusError osstatus-
+ src/System/MacOSX/CoreMidi.hs view
@@ -0,0 +1,573 @@++-- |Low-level 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+    , midiSend'+    , midiSendList+    , midiSendList'+    , midiSendSysEx++    -- types  +    , OpaqueMIDIClient+    , OpaqueMIDIObject+    , OpaqueMIDIDevice+    , OpaqueMIDIEntity+    , OpaqueMIDIEndpoint+    , OpaqueMIDIPort+    +    , MIDIClientRef+    , MIDIObjectRef+    , MIDIDeviceRef+    , MIDIEntityRef+    , MIDIEndpointRef+    , MIDIPortRef++    , MIDITimeStamp+    , MIDIReadProc+    , mkMIDIReadProc+    , MIDIPacket+    , Source(..)+    , Destination(..)++    -- helper functions to write callbacks+    , depackMIDIPacketList+    , depackSingleMIDIPacket+    , decodeShortMessage +    , isShortMessage +    ) where++import Control.Monad+import Control.Concurrent.MVar+import Foreign hiding (unsafePerformIO)+import Foreign.Marshal+import System.IO.Unsafe++import System.MIDI.Base+import System.MacOSX.CoreFoundation++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         = unsafePerformIO $ peek ptr_kMIDIPropertyName+kMIDIPropertyManufacturer = unsafePerformIO $ peek ptr_kMIDIPropertyManufacturer+kMIDIPropertyModel        = 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++----- 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 -> 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 + +----- encode / decode ++encodeShortMessageList :: [ShortMessage] -> [Word8]+encodeShortMessageList list = concatMap encodeShortMessage list++encodeShortMessage :: ShortMessage -> [Word8]+encodeShortMessage (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]+    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 <- sysexloop p 2 +    xs <- mapM (peekElemOff p) [0..n]+    return ( n+2 , xs ) ++sysexloop :: Ptr Word8 -> Int -> IO Int+sysexloop q i = do+    x <- peekElemOff q i+    if x == 0xf7 then return (i-1) else sysexloop q (i+1) +      +----- Send++-- |Sends a short message with timestamp "now".+midiSend :: MIDIPortRef -> Destination -> ShortMessage -> IO () +midiSend port dst msg     = midiSend' port dst 0 msg++-- |Sends a list of short messages with timestamp "now".+midiSendList :: MIDIPortRef -> Destination -> [ShortMessage] -> IO () +midiSendList port dst msglist = midiSendList' port dst 0 msglist++-- |Sends a short message with the given timestamp.+midiSend' :: MIDIPortRef -> Destination -> MIDITimeStamp -> ShortMessage -> IO ()+midiSend' 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.+midiSendList' :: MIDIPortRef -> Destination -> MIDITimeStamp -> [ShortMessage] -> IO ()+midiSendList' 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++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_MIDIGetNumberOfSources+    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+    +-- |Disposes an existing MIDI endpoint.+disposeEndpoint :: Endpoint a => a -> IO ()  +disposeEndpoint x = do+    osstatus <- c_MIDIEndpointDispose (endpoint x)+    when (osstatus /= 0) $ osStatusError osstatus+
+ src/System/Midi.hs view
@@ -0,0 +1,226 @@++{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}+++--+-- Module      : System.MIDI+-- Version     : 0.1+-- License     : BSD3+-- Author      : Balazs Komuves+-- Maintainer  : bkomuves+hmidi@gmail.com+-- Stability   : experimental+-- Portability : not portable+-- Tested with : GHC 6.8.2+--++-- | A lowest common denominator interface to the Win32 and MacOSX MIDI bindings. +-- Error handling is via `fail`-s in the IO monad. ++module System.MIDI (+        -- * Messages+        MidiTime,+        MidiMessage,+        MidiEvent,        ++        -- * Input and output+        MidiHasName(..),++        -- ** Sources and Destinations+        Source,+        sources,+        Destination,+        destinations,+        +        -- ** Streams+        openSource,+        openDestination,+        Stream,+        close,+        start,+        stop,++        -- * Sending+        send,+        -- sendSysEx,++        -- * Receiving+        getNextEvent,+        getEvents,++        -- * Timer+        currentTime,    +  ) where++import Data.Word (Word8,Word32)+import System.MIDI.Base hiding (MidiEvent, MidiMessage)+import System.IO.Unsafe (unsafePerformIO)++import qualified Codec.Midi as C++#ifdef mingw32_HOST_OS+import qualified System.MIDI.Win32 as S+#define HMIDI_SUPPORTED_OS+#endif++#ifdef darwin_HOST_OS+import qualified System.MIDI.MacOSX as S+#define HMIDI_SUPPORTED_OS+#endif++-- this is just to be able to produce a Haddock documentation on a not supported system (eg. Linux)+#ifndef HMIDI_SUPPORTED_OS+import qualified System.MIDI.Placeholder as S+#endif++type MidiTime       = Word32+type MidiMessage    = C.Message+type MidiEvent      = (MidiTime, C.Message)++class MidiHasName a where+    name :: a -> IO String++instance MidiHasName Source where+    name = S.getName . getSource++instance MidiHasName Destination where+    name = S.getName . getDestination+    ++-- All the definitions in this file are neccessary to be able to have a nice Haddock-generated+-- documentation independently of the platform. Though I still don't know how to generate documentation+-- for a platform-specific module while being on an a different platform (probably not at all possible +-- at present?) ++-- | The opaque data type representing a MIDI source.+newtype Source = Source { getSource :: S.Source }+    deriving (Eq)++-- | The opaque data type representing a MIDI destination.+newtype Destination = Destination { getDestination :: S.Destination }+    deriving (Eq)++instance Show Source where+    show = (\n -> "<Source: "++n++">") . unsafePerformIO . name++instance Show Destination where+    show = (\n -> "<Destination: "++n++">") . unsafePerformIO . name++-- | The opaque data type representing a MIDI connection.+newtype Stream = Stream { getStream :: S.Connection }++-- | Enumerates the MIDI sources present in the system.+sources :: IO [Source]+sources = fmap (fmap Source) S.enumerateSources++-- | Enumerates the MIDI destinations present in the system.+destinations :: IO [Destination]+destinations = fmap (fmap Destination) S.enumerateDestinations++-- | These functions return the name, model and manufacturer of a MIDI source \/ destination.+-- +-- Note: On Win32, only `getName` returns a somewhat meaningful string at the moment.+getName :: S.MIDIHasName a => a -> IO String+getModel :: S.MIDIHasName a => a -> IO String+getManufacturer :: S.MIDIHasName a => a -> IO String++getName = S.getName+getModel = S.getModel+getManufacturer = S.getManufacturer++-- | 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 (MidiTime -> C.Message -> IO ()) -> IO Stream +openSource s cb = fmap Stream $ S.openSource (getSource s) (fmap mkCb cb)+    where+        mkCb f (S.MidiEvent ts msg) = f ts (expMsg msg)+++-- | Opens a MIDI Destination.+openDestination :: Destination -> IO Stream +openDestination = fmap Stream . S.openDestination . getDestination+++-- | Gets the next event from a buffered connection (see also `openSource`)+getNextEvent :: Stream -> IO (Maybe MidiEvent)+getNextEvent = fmap (fmap g) . S.getNextEvent . getStream+    where+        g (S.MidiEvent ts msg) = (ts, expMsg msg)++-- | Gets all the events from the buffer (see also `openSource`)+getEvents :: Stream -> IO [MidiEvent]+getEvents = fmap (fmap g) . S.getEvents . getStream+    where+        g (S.MidiEvent ts msg) = (ts, expMsg msg)+        +-- | Sends a short message. The connection must be a `Destination`.+send :: Stream -> C.Message -> IO ()+send c = S.send (getStream c) . impMsg+ +{-+-- | Sends a system exclusive message. You shouldn't include the starting \/ trailing bytes 0xF0 and 0xF7.+-- +-- Note: On Win32, the connection must be a `Destination`+sendSysEx :: Stream -> [Word8] -> IO ()+sendSysEx = S.sendSysEx+-}+ +-- | Starts a connection. This is required for receiving MIDI messages, and also for starting the clock.+start :: Stream -> IO ()+start = S.start . getStream++-- | Stops a connection.+stop :: Stream -> IO ()+stop = S.stop . getStream+    +-- | Closes a MIDI Stream.+close :: Stream -> IO ()+close = S.close . getStream+ +-- | Returns the time elapsed since the last `start` call, in milisecs.+currentTime :: Stream -> IO MidiTime+currentTime = S.currentTime . getStream++++impMsg :: C.Message -> S.MidiMessage+impMsg (C.NoteOff ch k _)       = S.MidiMessage ch (S.NoteOff k)+impMsg (C.NoteOn  ch k v)       = S.MidiMessage ch (S.NoteOn k v) +impMsg (C.ControlChange ch c v) = S.MidiMessage ch (S.CC c v)+impMsg (C.ProgramChange ch a)   = S.MidiMessage ch (S.ProgramChange a)+impMsg (C.PitchWheel ch a)      = S.MidiMessage ch (S.PitchWheel a)++expMsg :: S.MidiMessage -> C.Message+expMsg (S.MidiMessage ch (S.NoteOff k)          ) = C.NoteOff ch k 0+expMsg (S.MidiMessage ch (S.NoteOn k v)	        ) = C.NoteOn  ch k v+expMsg (S.MidiMessage ch (S.CC c v)	            ) = C.ControlChange ch c v+expMsg (S.MidiMessage ch (S.ProgramChange a)	) = C.ProgramChange ch a+expMsg (S.MidiMessage ch (S.PitchWheel a)	    ) = C.PitchWheel ch a+-- expMsg (S.MidiMessage ch (S.PolyAftertouch k v) ) = undefined+-- expMsg (S.MidiMessage ch (S.Aftertouch a)        ) = undefined+-- expMsg (S.SysEx [Word8]                    ) = undefined+-- expMsg (S.SongPosition p                   ) = undefined+-- expMsg (S.SongSelect s                         ) = undefined+-- expMsg (S.TuneRequest                          ) = undefined+-- expMsg (S.SRTClock                             ) = undefined+-- expMsg (S.SRTStart                             ) = undefined+-- expMsg (S.SRTContinue                          ) = undefined+-- expMsg (S.SRTStop                              ) = undefined+-- expMsg (S.ActiveSensing                        ) = undefined+-- expMsg (S.Reset                                ) = undefined+-- expMsg (S.Undefined                           ) = undefined++++++++++++++
+ src/System/Midi/Base.hs view
@@ -0,0 +1,138 @@++-- |The hardware-independent part of the MIDI binding.++{-# LANGUAGE CPP #-}+module System.MIDI.Base +    ( TimeStamp+    , MidiMessage'(..)+    , MidiMessage(..)+    , MidiEvent(..)+    , ClientCallback+    , ShortMessage(..)+    , translateShortMessage+    , untranslateShortMessage+    , shortMessage+    ) where++import Data.Bits+import Data.Word++type TimeStamp = Word32 ++-- |A \"regular\" MIDI message.+--+-- Remark: `NoteOff` not having a velocity field is a design decision, and a questionable one. According to the+-- MIDI standard, NoteOff also has a velocity. However, most keyboards do not use this feature (send the default+-- value 64), and there are keyboards which do not send NoteOff messages at all, but send NoteOn messages with+-- zero velocity instead (for example the EMU Xboard series). I don't know what would be a good solution. +-- At the moment, the code auto-translates NoteOn messages with zero velocity to NoteOff messages, and the+-- NoteOff velocity is ignored. This behaviour can be inverted with the Cabal flag NoNoteOff.+data MidiMessage' +    = NoteOff         !Int          -- ^ Note Off (key)+    | NoteOn          !Int !Int     -- ^ Note On (key, velocity)+    | PolyAftertouch  !Int !Int     -- ^ Polyphonic key pressure (key, pressure)+    | CC              !Int !Int     -- ^ Control Change (controller, value)+    | ProgramChange   !Int          -- ^ Program Change (program)+    | Aftertouch      !Int          -- ^ Global aftertouch (pressure)+    | PitchWheel      !Int          -- ^ Pitch wheel (value, from -8192..+8191)+    deriving (Show,Eq)+    +-- |The type representing a MIDI message.  +data MidiMessage +    = MidiMessage  !Int !MidiMessage'    -- ^ first argument is the MIDI channel (1..16)+    | SysEx        [Word8]               -- ^ not including the bytes 0xf0, 0xf7+    | SongPosition !Int+    | SongSelect   !Int +    | TuneRequest+    | SRTClock+    | SRTStart+    | SRTContinue +    | SRTStop+    | ActiveSensing+    | Reset+    | Undefined+    deriving (Show,Eq)+    +-- |The type representing a timestamped MIDI message. +-- Time is measured in milisecs elapsed since the last call to `System.MIDI.start`.+data MidiEvent = MidiEvent !TimeStamp !MidiMessage deriving (Show,Eq)++-- |Type of the user callback function.  +type ClientCallback = MidiEvent -> IO ()+    +translateShortMessage :: ShortMessage -> MidiMessage+translateShortMessage (ShortMessage chn msg bt1 bt2) =+    if msg < 15 +      then MidiMessage (fromIntegral chn + 1) $ translate' msg k v+      else translate'' chn k v+    where+      k = fromIntegral bt1+      v = fromIntegral bt2++translate' msg k v = case msg of+#ifdef HMIDI_NO_NOTEOFF+     8  -> NoteOn k 0+     9  -> NoteOn k v+#else+     8  -> NoteOff k+     9  -> if v>0 then NoteOn k v else NoteOff k+#endif+     10 -> PolyAftertouch k v+     11 -> CC k v+     12 -> ProgramChange k+     13 -> Aftertouch k+     14 -> PitchWheel (k + shiftL v 7 - 8192)++translate'' lo a b = case lo of+    0  -> Undefined+    1  -> Undefined+    2  -> SongPosition (a + shiftL b 7)+    3  -> SongSelect a +    4  -> Undefined+    5  -> Undefined+    6  -> TuneRequest+    7  -> Undefined+    8  -> SRTClock+    9  -> Undefined+    10 -> SRTStart+    11 -> SRTContinue+    12 -> SRTStop+    13 -> Undefined+    14 -> ActiveSensing+    15 -> Reset+ +untranslateShortMessage :: MidiMessage -> ShortMessage+untranslateShortMessage (MidiMessage chn msg') = +    case msg' of+      NoteOff k           -> shortMessage chn  8 k 64+      NoteOn  k v         -> shortMessage chn  9 k v+      PolyAftertouch k v  -> shortMessage chn 10 k v+      CC k v              -> shortMessage chn 11 k v+      ProgramChange k     -> shortMessage chn 12 k 0+      Aftertouch k        -> shortMessage chn 13 k 0+      PitchWheel n        -> let m = min 16383 $ max 0 $ n + 8192 in shortMessage chn 14 (m.&.127) (shiftR m 7) ++untranslateShortMessage (SongPosition p) = shortMessage 15  3 (p.&.7) (shiftR p 7) +untranslateShortMessage (SongSelect   s) = shortMessage 15  3 (fromIntegral s) 0 +untranslateShortMessage  TuneRequest     = shortMessage 15  6 0 0 +untranslateShortMessage  SRTClock        = shortMessage 15  8 0 0 +untranslateShortMessage  SRTStart        = shortMessage 15 10 0 0 +untranslateShortMessage  SRTContinue     = shortMessage 15 11 0 0 +untranslateShortMessage  SRTStop         = shortMessage 15 12 0 0 +untranslateShortMessage  ActiveSensing   = shortMessage 15 14 0 0 +untranslateShortMessage  Reset           = shortMessage 15 15 0 0 +untranslateShortMessage  Undefined       = error "cannot untranslate Undefined" +untranslateShortMessage (SysEx _)        = error "cannot untranslate SysEx" + +shortMessage :: Int -> Int -> Int -> Int -> ShortMessage+shortMessage chn msg bt1 bt2 = +    ShortMessage (fromIntegral chn - 1) (fromIntegral msg) (fromIntegral bt1) (fromIntegral bt2)+ +-- |Low level stuff.+data ShortMessage = ShortMessage +    { sm_channel :: Word8+    , sm_msg     :: Word8 +    , sm_byte1   :: Word8+    , sm_byte2   :: Word8 +    } deriving Show+
+ src/System/Midi/MacOSX.hs view
@@ -0,0 +1,236 @@++-- |A lowest common denominator interface to the Win32 and MacOSX MIDI bindings, MacOSX part.++module System.MIDI.MacOSX+    ( module System.MIDI.Base++    , Source+    , Destination+    , Connection+ +    , enumerateSources+    , enumerateDestinations+    +    , MIDIHasName(..)  ++    , openSource+    , openDestination+    , close+    , send+    , sendSysEx+    , start+    , stop+    +    , getNextEvent+    , getEvents+    , currentTime+    +    ) where++import System.MIDI.Base++import Control.Monad+import Control.Concurrent.MVar+import Control.Concurrent.Chan+import Data.List+import Foreign hiding (unsafePerformIO)+import Foreign.StablePtr+import System.IO.Unsafe++import System.MacOSX.CoreFoundation+import System.MacOSX.CoreAudio+import System.MacOSX.CoreMIDI++-- |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)++type Client      = MIDIClientRef+type Device      = MIDIDeviceRef+type Port        = MIDIPortRef++-- |The opaque data type representing a MIDI connection+data Connection = Connection+    { cn_isInput     :: Bool+    , cn_port        :: MIDIPortRef+    , cn_endpoint    :: MIDIEndpointRef+    , cn_time        :: MVar UInt64     -- measured in nanosecs+    , cn_alive       :: MVar Bool+    , cn_fifo_cb     :: Either (Chan MidiEvent) ClientCallback+    , cn_midiproc    :: FunPtr (MIDIReadProc () ())+    , cn_mydata      :: StablePtr (MVar Connection)+    }++----- automatic client creation ++client = 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 $ 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)+        list1 <- depackMIDIPacketList packets+        let (normal,sysex') = partition (\(_,bytes) -> isShortMessage bytes) list1+        sysexs <- forM sysex' $ \(ts',bytes) -> do+          ts <- audioConvertHostTimeToNanos ts'+          return $ MidiEvent (nanoToMili $ ts-time0) (SysEx $ tail bytes)+        normals <- mapM (convertShortMessage time0) normal+        let events = sysexs ++ normals+        case (cn_fifo_cb conn) of+          Left  chan -> 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 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@(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 $ newChan ++    inport <- newInputPort client "Input Port" the_callback (castStablePtrToPtr sp) +      +    let conn = Connection True inport endpoint time alive fifo_cb the_callback sp +    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 outport endpoint time alive 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 -> midiSend (cn_port conn) (Destination $ cn_endpoint 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.+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  -> 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  -> disconnectFromSource (cn_port conn) (Source $ cn_endpoint conn)+          False -> return ()+      else putStrLn "warning: you shouldn't call stop twice"  +    +-- |Closes a MIDI Connection+close conn = do+    when (cn_isInput conn) $ do+      b <- isEmptyMVar (cn_time conn)+      when (not b) (stop conn) +    disposePort (cn_port conn)+    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 ()+
+ src/System/Midi/Placeholder.hs view
@@ -0,0 +1,59 @@++-- | This is just to be able to produce a Haddock documentation on a Linux system++module System.MIDI.Placeholder+    ( 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 System.MIDI.Base++data Source                 = Source      deriving (Eq, Ord, Show)+data Destination            = Destination deriving (Eq, Ord, Show)+data Connection             = Connection  deriving (Eq, Ord, Show)++enumerateSources            = noImpl+enumerateDestinations       = noImpl++class MIDIHasName a where+getName                     = noImpl +getManufacturer             = noImpl +getModel                    = noImpl +openSource                  = noImpl+openDestination             = noImpl+close                       = noImpl+send                        = noImpl+sendSysEx                   = noImpl+start                       = noImpl+stop                        = noImpl++getNextEvent                = noImpl+getEvents                   = noImpl+currentTime                 = noImpl++noImpl = error "Not implemented"+
+ src/System/Midi/Win32.hs view
@@ -0,0 +1,275 @@++-- |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 ()+
− src/System/Win32/MIDI.hs 
@@ -1,508 +0,0 @@---- |Low-level binding to the Win32 MIDI services.--- Error handling is via `fail`-s in the IO monad. --{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}-module System.Win32.MIDI -    ( Source(..)-    , Destination(..)-    , enumerateSources-    , enumerateDestinations-    , MIDIHasName-    , getName-    , getModel-    , getManufacturer-    , getMidiInCaps-    , getMidiOutCaps-    , MidiInCaps(..)-    , MidiOutCaps(..)-    , midiInOpen-    , midiOutOpen-    , Callback(..)-    , midiInClose-    , midiOutClose-    , midiInStart-    , midiInStop-    , midiInReset-    , midiOutReset-    , midiOutSend--    , midiInAddBuffer-    , midiOutSendSysEx-    , withMidiInHeader-    , withMidiOutHeader-    , newMidiInHeader-    , freeMidiInHeader-    -    , MIDIHDR-    , HMIDI-    , HMIDIIN-    , HMIDIOUT-    , MIDIPROC-    , MIDIINPROC-    , MIDIOUTPROC-    , mkMIDIPROC-    -    , decodeShortMessage-    , encodeShortMessage-    , MIM(..)-    , MOM(..)-    , mim-    , mom-    -    , timeGetTime  -- not strictly MIDI, nevertheless quite useful in this context -    ) where--import Control.Monad-import Data.Bits-import Data.Word-import Foreign-import Foreign.Storable--import System.Win32.Types-import System.MIDI.Base--maxPNAMELEN    = 32  :: Int-maxERRORLENGTH = 256 :: UINT--midiMapperID = -1 :: UINT--type HMIDI    = HANDLE-type HMIDIIN  = HANDLE-type HMIDIOUT = HANDLE--type MIDIPROC a    = HMIDI    -> UINT -> Ptr a -> DWORD -> DWORD -> IO ()-type MIDIINPROC a  = HMIDIIN  -> UINT -> Ptr a -> DWORD -> DWORD -> IO ()-type MIDIOUTPROC a = HMIDIOUT -> UINT -> Ptr a -> DWORD -> DWORD -> IO ()--foreign import stdcall safe "wrapper" -    mkMIDIPROC :: MIDIPROC () -> IO (FunPtr (MIDIPROC ()))---------type MMRESULT     = UINT-type MMVERSION    = UINT--newtype Source       = Source      UINT deriving (Show,Eq)-newtype Destination  = Destination UINT deriving (Show,Eq)--fromMMVersion :: MMVERSION -> (Int,Int)-fromMMVersion mmversion = (major,minor) where-    major = fromIntegral $ shiftR mmversion 8-    minor = fromIntegral $ mmversion .&. 255------- Time---- Returns the system time in miliseconds.-foreign import stdcall unsafe "mmsystem.h timeGetTime"-    timeGetTime :: IO DWORD------- Errors--{---- not really informative conversion (fallback)-mmErrorString :: MMRESULT -> String-mmErrorString mmresult = "MMRESULT = " ++ show mmresult---- not really informative "fail"-mmError :: MMRESULT -> IO a-mmError mmresult = fail $ mmErrorString mmresult--}--mmInError :: MMRESULT -> IO a-mmInError mmresult = do { txt <- midiInGetErrorText mmresult ; fail txt }--mmOutError :: MMRESULT -> IO a-mmOutError mmresult = do { txt <- midiOutGetErrorText mmresult ; fail txt }--foreign import stdcall unsafe "mmsystem.h midiInGetErrorTextW"-    c_midiInGetErrorText :: MMRESULT -> LPTSTR -> UINT -> IO UINT--foreign import stdcall unsafe "mmsystem.h midiOutGetErrorTextW"-    c_midiOutGetErrorText :: MMRESULT -> LPTSTR -> UINT -> IO UINT-    -midiInGetErrorText :: MMRESULT -> IO String-midiInGetErrorText errcode = do-    allocaArray0 (fromIntegral maxERRORLENGTH) $ \p -> do-      mmr <- c_midiInGetErrorText errcode p maxERRORLENGTH-      if mmr /= 0 -        then return "invalid MMRESULT"-        else peekTString p --midiOutGetErrorText :: MMRESULT -> IO String  -midiOutGetErrorText errcode = do-    allocaArray0 (fromIntegral maxERRORLENGTH) $ \p -> do-      mmr <- c_midiOutGetErrorText errcode p maxERRORLENGTH-      if mmr /= 0 -        then return "invalid MMRESULT"-        else peekTString p -    ------ Devices-    -foreign import stdcall unsafe "mmsystem.h midiInGetNumDevs"-    c_midiInGetNumDevs :: IO UINT--foreign import stdcall unsafe "mmsystem.h midiOutGetNumDevs"-    c_midiOutGetNumDevs :: IO UINT---- |Eumerates the MIDI sources.-enumerateSources :: IO [Source]-enumerateSources = do-    n <- c_midiInGetNumDevs-    return $ if n>0 then [ Source i | i<-[0..n-1] ] else []  -- n is unsigned!---- |Eumerates the MIDI destinations.-enumerateDestinations :: IO [Destination]-enumerateDestinations = do-    n <- c_midiOutGetNumDevs-    return $ if n>0 then [ Destination i | i<-[0..n-1] ] else []  -- n is unsigned!------- MIDI capabilities--manufacturerIDToString :: WORD -> String-manufacturerIDToString mid = "Manufacturer ID = " ++ show mid--productIDToString :: WORD -> WORD -> String-productIDToString mid  pid = "Product ID = " ++ show mid ++ ":" ++ show pid--data MIDIINCAPS-data MIDIOUTCAPS--type LPMIDIINCAPS  = Ptr MIDIINCAPS-type LPMIDIOUTCAPS = Ptr MIDIOUTCAPS--data MidiInCaps = MidiInCaps-    { mic_Mid :: WORD-    , mic_Pid :: WORD-    , mic_DriverVersion :: MMVERSION-    , mic_Pname :: String   -- TCHAR [MAXPNAMELEN]-    , mic_Support :: DWORD  -- reserved-    } deriving Show--instance Storable MidiInCaps where-    sizeOf    _  = 12 + maxPNAMELEN * sizeOf (undefined::TCHAR)-    alignment _  = 4 -    peek p = do-      mid <- peek (castPtr p) ; q <- return (p `plusPtr` 2)-      pid <- peek (castPtr q) ; q <- return (q `plusPtr` 2)-      ver <- peek (castPtr q) ; q <- return (q `plusPtr` 4)-      nam <- peekTString (castPtr q) ; q <- return (q `plusPtr` (4*maxPNAMELEN))-      sup <- peek (castPtr q) -      return $ MidiInCaps mid pid ver nam sup-    poke p mic = fail "MidiInCaps/poke not implemented yet"--data MidiOutCaps = MidiOutCaps-    { moc_Mid :: WORD-    , moc_Pid :: WORD-    , moc_DriverVersion :: MMVERSION-    , moc_Pname :: String       -- TCHAR [MAXPNAMELEN]-    , moc_Technology  :: WORD-    , moc_Voices      :: WORD-    , moc_Notes       :: WORD-    , moc_ChannelMask :: WORD-    , moc_Support     :: DWORD  -- reserved-    } deriving Show--instance Storable MidiOutCaps where-    sizeOf    _  = 20 + maxPNAMELEN * sizeOf (undefined::TCHAR) -    alignment _  = 4 -    peek p = do-      mid <- peek (castPtr p) ; q <- return (p `plusPtr` 2)-      pid <- peek (castPtr q) ; q <- return (q `plusPtr` 2)-      ver <- peek (castPtr q) ; q <- return (q `plusPtr` 4)-      nam <- peekTString (castPtr q) ; q <- return (q `plusPtr` (4*maxPNAMELEN))-      tec <- peek (castPtr p) ; q <- return (p `plusPtr` 2)-      voi <- peek (castPtr p) ; q <- return (p `plusPtr` 2)-      not <- peek (castPtr p) ; q <- return (p `plusPtr` 2)-      chm <- peek (castPtr p) ; q <- return (p `plusPtr` 2)-      sup <- peek (castPtr q) -      return $ MidiOutCaps mid pid ver nam tec voi not chm sup-    poke p mic = fail "not implemented yet"-       -foreign import stdcall unsafe "mmsystem.h midiInGetDevCapsW"-    c_midiInGetDevCaps :: UINT -> LPMIDIINCAPS -> UINT -> IO MMRESULT --foreign import stdcall unsafe "mmsystem.h midiOutGetDevCapsW"-    c_midiOutGetDevCaps :: UINT -> LPMIDIOUTCAPS -> UINT -> IO MMRESULT ---- |`Source`'s and `Destinations` have names, models and manufacturers (though the last two is not really supported...)-class MIDIHasName a where -    getName :: a -> IO String-    getModel :: a -> IO String-    getManufacturer :: a -> IO String-    -instance MIDIHasName Source where-    getName src = do -      caps <- getMidiInCaps src-      return $ mic_Pname caps-    getModel src = do-      caps <- getMidiInCaps src-      return $ productIDToString (mic_Mid caps) (mic_Pid caps)-    getManufacturer src = do-      caps <- getMidiInCaps src-      return $ manufacturerIDToString (mic_Mid caps)- -instance MIDIHasName Destination where-    getName dst = do -      caps <- getMidiOutCaps dst  -      return $ moc_Pname caps-    getModel dst = do-      caps <- getMidiOutCaps dst-      return $ productIDToString (moc_Mid caps) (moc_Pid caps)-    getManufacturer dst = do-      caps <- getMidiOutCaps dst-      return $ manufacturerIDToString (moc_Mid caps)- -getMidiInCaps :: Source -> IO MidiInCaps -getMidiInCaps (Source device) = do-    let cast = castPtr :: Ptr MidiInCaps -> LPMIDIINCAPS-    alloca $ \ptr -> do-      mmresult <- c_midiInGetDevCaps device (cast ptr) (fromIntegral $ sizeOf (undefined::MidiInCaps))-      if mmresult /= 0-        then mmInError mmresult-        else peek ptr--getMidiOutCaps :: Destination -> IO MidiOutCaps -getMidiOutCaps (Destination device) = do-    let cast = castPtr :: Ptr MidiOutCaps -> LPMIDIOUTCAPS-    alloca $ \ptr -> do-      mmresult <- c_midiOutGetDevCaps device (cast ptr) (fromIntegral $ sizeOf (undefined::MidiOutCaps))-      if mmresult /= 0-        then mmOutError mmresult-        else peek ptr- ------ Open / Close (these should be "safe", as they are generating immediate callbacks!)--foreign import stdcall safe "mmsystem.h midiInOpen"-    c_midiInOpen  :: Ptr HMIDIIN -> UINT -> FunPtr (MIDIINPROC a) -> Ptr a -> DWORD -> IO MMRESULT  --foreign import stdcall safe "mmsystem.h midiOutOpen"-    c_midiOutOpen :: Ptr HMIDIOUT -> UINT -> FunPtr (MIDIOUTPROC a) -> Ptr a -> DWORD -> IO MMRESULT  -    -foreign import stdcall safe "mmsystem.h midiInClose"-    c_midiInClose  :: HMIDIIN -> IO MMRESULT  -    -foreign import stdcall safe "mmsystem.h midiOutClose"-    c_midiOutClose  :: HMIDIOUT -> IO MMRESULT  -    ------ Start / Stop / Reset--foreign import stdcall unsafe "mmsystem.h midiInStart"-    c_midiInStart  :: HMIDIIN -> IO MMRESULT  -    -foreign import stdcall unsafe "mmsystem.h midiInStop"-    c_midiInStop  :: HMIDIIN -> IO MMRESULT  --foreign import stdcall safe "mmsystem.h midiInReset"-    c_midiInReset  :: HMIDIIN -> IO MMRESULT    -- the resetting functions must be safe, as they are doing callbacks!!!--foreign import stdcall safe "mmsystem.h midiOutReset"-    c_midiOutReset  :: HMIDIIN -> IO MMRESULT  -    ------ Send Messages  - -data MIDIHDR --foreign import stdcall unsafe "mmsystem.h midiInAddBuffer"  -- this should be called midiInLongMsg ???-    c_midiInAddBuffer  :: HMIDIIN -> Ptr MIDIHDR -> UINT -> IO MMRESULT  -    -foreign import stdcall unsafe "mmsystem.h midiOutShortMsg"-    c_midiOutShortMsg  :: HMIDIOUT -> DWORD -> IO MMRESULT  -    -foreign import stdcall unsafe "mmsystem.h midiOutLongMsg"-    c_midiOutLongMsg  :: HMIDIOUT -> Ptr MIDIHDR -> UINT -> IO MMRESULT  -    -foreign import stdcall unsafe "mmystem.h midiInPrepareHeader"-    c_midiInPrepareHeader :: HMIDIIN -> Ptr MIDIHDR -> UINT -> IO MMRESULT--foreign import stdcall unsafe "mmystem.h midiOutPrepareHeader"-    c_midiOutPrepareHeader :: HMIDIOUT -> Ptr MIDIHDR -> UINT -> IO MMRESULT--foreign import stdcall unsafe "mmystem.h midiInUnprepareHeader"-    c_midiInUnprepareHeader :: HMIDIIN -> Ptr MIDIHDR -> UINT -> IO MMRESULT--foreign import stdcall unsafe "mmystem.h midiOutUnprepareHeader"-    c_midiOutUnprepareHeader :: HMIDIOUT -> Ptr MIDIHDR -> UINT -> IO MMRESULT-    -type CPrepare   = HMIDI -> Ptr MIDIHDR -> UINT -> IO MMRESULT -type CUnprepare = HMIDI -> Ptr MIDIHDR -> UINT -> IO MMRESULT -    -waitFor :: IO Bool -> IO ()-waitFor check = do-    b <- check-    unless b $ waitFor check  -    -while :: (a -> Bool) -> IO a -> IO a-while cond act = do-    x <- act-    if cond x then while cond act else return x  -    -withMidiHeader :: (MMRESULT -> IO ()) -> CPrepare -> CUnprepare -> HMIDI -> [Word8] -> (HMIDI -> Ptr MIDIHDR -> UINT -> IO a) -> IO a-withMidiHeader mmError prepare unprepare handle bytes action = do-    let n = fromIntegral (length bytes) :: DWORD -        size = 48 :: UINT  -- size of the MIDIHDR structure-    allocaBytes (fromIntegral size) $ \p -> allocaBytes (fromIntegral n) $ \q -> do-      poke (castPtr p             ) q           -- pointer to the data-      poke (castPtr p `plusPtr`  4) n           -- length of the data-      poke (castPtr p `plusPtr` 16) (0::DWORD)  -- flags, must be zero-      mmresult <- prepare   handle p size ; when (mmresult /=0) $ mmError mmresult   -      pokeArray q bytes-      x        <- action    handle p size-{--      waitFor $ do -        flags <- peek (castPtr p `plusPtr` 16) :: IO DWORD -        return $ (flags .&. 1) /= 0  -- DONE FLAG-      mmresult <- unprepare handle p size ; when (mmresult /=0) $ mmError mmresult   --}-      mmresult <- while (==65) (unprepare handle p size)    -- 65 is MIDIERR_STILLPLAYING-      return x--newMidiHeader :: (MMRESULT -> IO ()) -> CPrepare -> HMIDI -> Int -> IO (Ptr MIDIHDR)-newMidiHeader mmError prepare handle n = do-    let size = 48 :: UINT  -- size of the MIDIHDR structure-    p <- mallocBytes (fromIntegral size + n)-    let q = castPtr p `plusPtr` (fromIntegral size) :: Ptr Word8-    poke (castPtr p             ) q           -- pointer to the data-    poke (castPtr p `plusPtr`  4) n           -- length of the data-    poke (castPtr p `plusPtr` 16) (0::DWORD)  -- flags, must be zero-    mmresult <- prepare handle p size ; when (mmresult /=0) $ mmError mmresult   -    return p-    -freeMidiHeader :: (MMRESULT -> IO ()) -> CUnprepare -> HMIDI -> Ptr MIDIHDR -> IO ()-freeMidiHeader mmError unprepare handle p = do-    mmresult <- unprepare handle p 48 ; when (mmresult /=0) $ mmError mmresult -    free p--withMidiInHeader  = withMidiHeader mmInError  c_midiInPrepareHeader  c_midiInUnprepareHeader   -withMidiOutHeader = withMidiHeader mmOutError c_midiOutPrepareHeader c_midiOutUnprepareHeader   -newMidiInHeader   = newMidiHeader  mmInError  c_midiInPrepareHeader -freeMidiInHeader  = freeMidiHeader mmInError  c_midiInUnprepareHeader  -    -midiInAddBuffer :: HMIDIIN -> Int -> IO (Ptr MIDIHDR)-midiInAddBuffer handle n = do-    p <- newMidiInHeader handle n -    mmresult <- c_midiInAddBuffer handle p 48 -    when (mmresult /=0) $ mmInError mmresult   -    return p---- |you shouldn't include the starting/trailing bytes 0xf0 and 0xf7-midiOutSendSysEx :: HMIDIOUT -> [Word8] -> IO ()-midiOutSendSysEx handle msg' = do-    let msg = 0xf0 : (msg' ++ [0xf7])-    --print msg-    mmresult <- withMidiOutHeader handle msg c_midiOutLongMsg -    when (mmresult /=0) $ mmOutError mmresult   -      -midiOutSend :: HMIDIOUT -> ShortMessage -> IO ()-midiOutSend handle msg = do-    mmresult <- c_midiOutShortMsg handle (encodeShortMessage msg)-    when (mmresult /=0) $ mmOutError mmresult   -      ----------- exported Haskell functions -----------encodeRunningMessages :: [ShortMessage] -> [DWORD]-encodeRunningMessages msgs = encodeShortMessage (head msgs) : map encode' (tail msgs) where-    encode' msg = fromIntegral (sm_byte1 msg) + (shiftL (fromIntegral $ sm_byte2 msg) 8)-     -encodeShortMessage :: ShortMessage -> DWORD-encodeShortMessage (ShortMessage chn' msg' bt1' bt2') -    = chn + shiftL msg 4 + shiftL bt1 8 + shiftL bt2 16  -    where -      chn = 15 .&. fromIntegral chn'-      msg = 15 .&. fromIntegral msg'-      bt1 = fromIntegral bt1'-      bt2 = fromIntegral bt2'-      -decodeShortMessage :: DWORD -> ShortMessage-decodeShortMessage x = ShortMessage chn msg bt1 bt2 -    where-      chn = fromIntegral $ (       x   ) .&. 15-      msg = fromIntegral $ (shiftR x  4) .&. 15-      bt1 = fromIntegral $ (shiftR x  8) .&. 255-      bt2 = fromIntegral $ (shiftR x 16) .&. 255--midiInStart :: HMIDIIN -> IO ()-midiInStart handle = do-    mmresult <- c_midiInStart handle-    when (mmresult /=0) $ mmInError mmresult   --midiInStop :: HMIDIIN -> IO ()-midiInStop handle = do-    mmresult <- c_midiInStop handle-    when (mmresult /=0) $ mmInError mmresult   --midiInClose :: HMIDIIN -> IO ()-midiInClose handle = do-    mmresult <- c_midiInClose handle-    when (mmresult /=0) $ mmInError mmresult   --midiOutClose :: HMIDIOUT -> IO ()-midiOutClose handle = do-    mmresult <- c_midiOutClose handle-    when (mmresult /=0) $ mmOutError mmresult   --midiInReset :: HMIDIIN -> IO ()-midiInReset handle = do-    mmresult <- c_midiInReset handle-    when (mmresult /=0) $ mmInError mmresult   --midiOutReset :: HMIDIOUT -> IO ()-midiOutReset handle = do-    mmresult <- c_midiOutReset handle-    when (mmresult /=0) $ mmOutError mmresult   --data MIM -    = MIM_OPEN-    | MIM_CLOSE-    | MIM_DATA-    | MIM_LONGDATA-    | MIM_ERROR-    | MIM_LONGERROR-    deriving (Eq,Show)-    -mim :: UINT -> MIM-mim 0x3C1 = MIM_OPEN-mim 0x3C2 = MIM_CLOSE-mim 0x3C3 = MIM_DATA-mim 0x3C4 = MIM_LONGDATA-mim 0x3C5 = MIM_ERROR-mim 0x3C6 = MIM_LONGERROR--data MOM -    = MOM_OPEN-    | MOM_CLOSE-    | MOM_DONE-    deriving (Eq,Show)-    -mom :: UINT -> MOM-mom 0x3c7 = MOM_OPEN-mom 0x3c8 = MOM_CLOSE-mom 0x3c9 = MOM_DONE-               -data Callback -    = CALLBACK_NULL            -- ^ no callback-    | CALLBACK_WINDOW          -- ^ callback is window (needs a HWND)-    | CALLBACK_THREAD          -- ^ callback is a thread (needs the thread id)-    | CALLBACK_FUNCTION Bool   -- ^ callback is a function; the boolean is MIDI_IO_STATUS (input only)-    | CALLBACK_EVENT           -- ^ callback is an event (needs an event handle; output only)--callback :: Callback -> DWORD-callback CALLBACK_NULL           = 0x00000000-callback CALLBACK_WINDOW         = 0x00010000-callback CALLBACK_THREAD         = 0x00020000-callback (CALLBACK_FUNCTION ios) = 0x00030000 + if ios then 0x20 else 0-callback CALLBACK_EVENT          = 0x00050000--midiInOpen :: Source -> FunPtr (MIDIINPROC a) -> Ptr a -> Callback -> IO HMIDIIN-midiInOpen (Source dev) proc ref cbtype = -    alloca $ \phandle -> do-      mmresult <- c_midiInOpen phandle dev proc ref (callback cbtype)-      when (mmresult /=0) $ mmInError mmresult-      peek phandle    --midiOutOpen :: Destination -> FunPtr (MIDIOUTPROC a) -> Ptr a -> Callback -> IO HMIDIOUT -midiOutOpen dst@(Destination dev) proc ref cbtype = do-    alloca $ \phandle -> do-      mmresult <- c_midiOutOpen phandle dev proc ref (callback cbtype)-      when (mmresult /=0) $ mmInError mmresult-      peek phandle
+ src/System/Win32/Midi.hs view
@@ -0,0 +1,508 @@++-- |Low-level binding to the Win32 MIDI services.+-- Error handling is via `fail`-s in the IO monad. ++{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}+module System.Win32.MIDI +    ( Source(..)+    , Destination(..)+    , enumerateSources+    , enumerateDestinations+    , MIDIHasName+    , getName+    , getModel+    , getManufacturer+    , getMidiInCaps+    , getMidiOutCaps+    , MidiInCaps(..)+    , MidiOutCaps(..)+    , midiInOpen+    , midiOutOpen+    , Callback(..)+    , midiInClose+    , midiOutClose+    , midiInStart+    , midiInStop+    , midiInReset+    , midiOutReset+    , midiOutSend++    , midiInAddBuffer+    , midiOutSendSysEx+    , withMidiInHeader+    , withMidiOutHeader+    , newMidiInHeader+    , freeMidiInHeader+    +    , MIDIHDR+    , HMIDI+    , HMIDIIN+    , HMIDIOUT+    , MIDIPROC+    , MIDIINPROC+    , MIDIOUTPROC+    , mkMIDIPROC+    +    , decodeShortMessage+    , encodeShortMessage+    , MIM(..)+    , MOM(..)+    , mim+    , mom+    +    , timeGetTime  -- not strictly MIDI, nevertheless quite useful in this context +    ) where++import Control.Monad+import Data.Bits+import Data.Word+import Foreign+import Foreign.Storable++import System.Win32.Types+import System.MIDI.Base++maxPNAMELEN    = 32  :: Int+maxERRORLENGTH = 256 :: UINT++midiMapperID = -1 :: UINT++type HMIDI    = HANDLE+type HMIDIIN  = HANDLE+type HMIDIOUT = HANDLE++type MIDIPROC a    = HMIDI    -> UINT -> Ptr a -> DWORD -> DWORD -> IO ()+type MIDIINPROC a  = HMIDIIN  -> UINT -> Ptr a -> DWORD -> DWORD -> IO ()+type MIDIOUTPROC a = HMIDIOUT -> UINT -> Ptr a -> DWORD -> DWORD -> IO ()++foreign import stdcall safe "wrapper" +    mkMIDIPROC :: MIDIPROC () -> IO (FunPtr (MIDIPROC ()))++-----++type MMRESULT     = UINT+type MMVERSION    = UINT++newtype Source       = Source      UINT deriving (Show,Eq)+newtype Destination  = Destination UINT deriving (Show,Eq)++fromMMVersion :: MMVERSION -> (Int,Int)+fromMMVersion mmversion = (major,minor) where+    major = fromIntegral $ shiftR mmversion 8+    minor = fromIntegral $ mmversion .&. 255++----- Time++-- Returns the system time in miliseconds.+foreign import stdcall unsafe "mmsystem.h timeGetTime"+    timeGetTime :: IO DWORD++----- Errors++{-+-- not really informative conversion (fallback)+mmErrorString :: MMRESULT -> String+mmErrorString mmresult = "MMRESULT = " ++ show mmresult++-- not really informative "fail"+mmError :: MMRESULT -> IO a+mmError mmresult = fail $ mmErrorString mmresult+-}++mmInError :: MMRESULT -> IO a+mmInError mmresult = do { txt <- midiInGetErrorText mmresult ; fail txt }++mmOutError :: MMRESULT -> IO a+mmOutError mmresult = do { txt <- midiOutGetErrorText mmresult ; fail txt }++foreign import stdcall unsafe "mmsystem.h midiInGetErrorTextW"+    c_midiInGetErrorText :: MMRESULT -> LPTSTR -> UINT -> IO UINT++foreign import stdcall unsafe "mmsystem.h midiOutGetErrorTextW"+    c_midiOutGetErrorText :: MMRESULT -> LPTSTR -> UINT -> IO UINT+    +midiInGetErrorText :: MMRESULT -> IO String+midiInGetErrorText errcode = do+    allocaArray0 (fromIntegral maxERRORLENGTH) $ \p -> do+      mmr <- c_midiInGetErrorText errcode p maxERRORLENGTH+      if mmr /= 0 +        then return "invalid MMRESULT"+        else peekTString p ++midiOutGetErrorText :: MMRESULT -> IO String  +midiOutGetErrorText errcode = do+    allocaArray0 (fromIntegral maxERRORLENGTH) $ \p -> do+      mmr <- c_midiOutGetErrorText errcode p maxERRORLENGTH+      if mmr /= 0 +        then return "invalid MMRESULT"+        else peekTString p +    +----- Devices+    +foreign import stdcall unsafe "mmsystem.h midiInGetNumDevs"+    c_midiInGetNumDevs :: IO UINT++foreign import stdcall unsafe "mmsystem.h midiOutGetNumDevs"+    c_midiOutGetNumDevs :: IO UINT++-- |Eumerates the MIDI sources.+enumerateSources :: IO [Source]+enumerateSources = do+    n <- c_midiInGetNumDevs+    return $ if n>0 then [ Source i | i<-[0..n-1] ] else []  -- n is unsigned!++-- |Eumerates the MIDI destinations.+enumerateDestinations :: IO [Destination]+enumerateDestinations = do+    n <- c_midiOutGetNumDevs+    return $ if n>0 then [ Destination i | i<-[0..n-1] ] else []  -- n is unsigned!++----- MIDI capabilities++manufacturerIDToString :: WORD -> String+manufacturerIDToString mid = "Manufacturer ID = " ++ show mid++productIDToString :: WORD -> WORD -> String+productIDToString mid  pid = "Product ID = " ++ show mid ++ ":" ++ show pid++data MIDIINCAPS+data MIDIOUTCAPS++type LPMIDIINCAPS  = Ptr MIDIINCAPS+type LPMIDIOUTCAPS = Ptr MIDIOUTCAPS++data MidiInCaps = MidiInCaps+    { mic_Mid :: WORD+    , mic_Pid :: WORD+    , mic_DriverVersion :: MMVERSION+    , mic_Pname :: String   -- TCHAR [MAXPNAMELEN]+    , mic_Support :: DWORD  -- reserved+    } deriving Show++instance Storable MidiInCaps where+    sizeOf    _  = 12 + maxPNAMELEN * sizeOf (undefined::TCHAR)+    alignment _  = 4 +    peek p = do+      mid <- peek (castPtr p) ; q <- return (p `plusPtr` 2)+      pid <- peek (castPtr q) ; q <- return (q `plusPtr` 2)+      ver <- peek (castPtr q) ; q <- return (q `plusPtr` 4)+      nam <- peekTString (castPtr q) ; q <- return (q `plusPtr` (4*maxPNAMELEN))+      sup <- peek (castPtr q) +      return $ MidiInCaps mid pid ver nam sup+    poke p mic = fail "MidiInCaps/poke not implemented yet"++data MidiOutCaps = MidiOutCaps+    { moc_Mid :: WORD+    , moc_Pid :: WORD+    , moc_DriverVersion :: MMVERSION+    , moc_Pname :: String       -- TCHAR [MAXPNAMELEN]+    , moc_Technology  :: WORD+    , moc_Voices      :: WORD+    , moc_Notes       :: WORD+    , moc_ChannelMask :: WORD+    , moc_Support     :: DWORD  -- reserved+    } deriving Show++instance Storable MidiOutCaps where+    sizeOf    _  = 20 + maxPNAMELEN * sizeOf (undefined::TCHAR) +    alignment _  = 4 +    peek p = do+      mid <- peek (castPtr p) ; q <- return (p `plusPtr` 2)+      pid <- peek (castPtr q) ; q <- return (q `plusPtr` 2)+      ver <- peek (castPtr q) ; q <- return (q `plusPtr` 4)+      nam <- peekTString (castPtr q) ; q <- return (q `plusPtr` (4*maxPNAMELEN))+      tec <- peek (castPtr p) ; q <- return (p `plusPtr` 2)+      voi <- peek (castPtr p) ; q <- return (p `plusPtr` 2)+      not <- peek (castPtr p) ; q <- return (p `plusPtr` 2)+      chm <- peek (castPtr p) ; q <- return (p `plusPtr` 2)+      sup <- peek (castPtr q) +      return $ MidiOutCaps mid pid ver nam tec voi not chm sup+    poke p mic = fail "not implemented yet"+       +foreign import stdcall unsafe "mmsystem.h midiInGetDevCapsW"+    c_midiInGetDevCaps :: UINT -> LPMIDIINCAPS -> UINT -> IO MMRESULT ++foreign import stdcall unsafe "mmsystem.h midiOutGetDevCapsW"+    c_midiOutGetDevCaps :: UINT -> LPMIDIOUTCAPS -> UINT -> IO MMRESULT ++-- |`Source`'s and `Destinations` have names, models and manufacturers (though the last two is not really supported...)+class MIDIHasName a where +    getName :: a -> IO String+    getModel :: a -> IO String+    getManufacturer :: a -> IO String+    +instance MIDIHasName Source where+    getName src = do +      caps <- getMidiInCaps src+      return $ mic_Pname caps+    getModel src = do+      caps <- getMidiInCaps src+      return $ productIDToString (mic_Mid caps) (mic_Pid caps)+    getManufacturer src = do+      caps <- getMidiInCaps src+      return $ manufacturerIDToString (mic_Mid caps)+ +instance MIDIHasName Destination where+    getName dst = do +      caps <- getMidiOutCaps dst  +      return $ moc_Pname caps+    getModel dst = do+      caps <- getMidiOutCaps dst+      return $ productIDToString (moc_Mid caps) (moc_Pid caps)+    getManufacturer dst = do+      caps <- getMidiOutCaps dst+      return $ manufacturerIDToString (moc_Mid caps)+ +getMidiInCaps :: Source -> IO MidiInCaps +getMidiInCaps (Source device) = do+    let cast = castPtr :: Ptr MidiInCaps -> LPMIDIINCAPS+    alloca $ \ptr -> do+      mmresult <- c_midiInGetDevCaps device (cast ptr) (fromIntegral $ sizeOf (undefined::MidiInCaps))+      if mmresult /= 0+        then mmInError mmresult+        else peek ptr++getMidiOutCaps :: Destination -> IO MidiOutCaps +getMidiOutCaps (Destination device) = do+    let cast = castPtr :: Ptr MidiOutCaps -> LPMIDIOUTCAPS+    alloca $ \ptr -> do+      mmresult <- c_midiOutGetDevCaps device (cast ptr) (fromIntegral $ sizeOf (undefined::MidiOutCaps))+      if mmresult /= 0+        then mmOutError mmresult+        else peek ptr+ +----- Open / Close (these should be "safe", as they are generating immediate callbacks!)++foreign import stdcall safe "mmsystem.h midiInOpen"+    c_midiInOpen  :: Ptr HMIDIIN -> UINT -> FunPtr (MIDIINPROC a) -> Ptr a -> DWORD -> IO MMRESULT  ++foreign import stdcall safe "mmsystem.h midiOutOpen"+    c_midiOutOpen :: Ptr HMIDIOUT -> UINT -> FunPtr (MIDIOUTPROC a) -> Ptr a -> DWORD -> IO MMRESULT  +    +foreign import stdcall safe "mmsystem.h midiInClose"+    c_midiInClose  :: HMIDIIN -> IO MMRESULT  +    +foreign import stdcall safe "mmsystem.h midiOutClose"+    c_midiOutClose  :: HMIDIOUT -> IO MMRESULT  +    +----- Start / Stop / Reset++foreign import stdcall unsafe "mmsystem.h midiInStart"+    c_midiInStart  :: HMIDIIN -> IO MMRESULT  +    +foreign import stdcall unsafe "mmsystem.h midiInStop"+    c_midiInStop  :: HMIDIIN -> IO MMRESULT  ++foreign import stdcall safe "mmsystem.h midiInReset"+    c_midiInReset  :: HMIDIIN -> IO MMRESULT    -- the resetting functions must be safe, as they are doing callbacks!!!++foreign import stdcall safe "mmsystem.h midiOutReset"+    c_midiOutReset  :: HMIDIIN -> IO MMRESULT  +    +----- Send Messages  + +data MIDIHDR ++foreign import stdcall unsafe "mmsystem.h midiInAddBuffer"  -- this should be called midiInLongMsg ???+    c_midiInAddBuffer  :: HMIDIIN -> Ptr MIDIHDR -> UINT -> IO MMRESULT  +    +foreign import stdcall unsafe "mmsystem.h midiOutShortMsg"+    c_midiOutShortMsg  :: HMIDIOUT -> DWORD -> IO MMRESULT  +    +foreign import stdcall unsafe "mmsystem.h midiOutLongMsg"+    c_midiOutLongMsg  :: HMIDIOUT -> Ptr MIDIHDR -> UINT -> IO MMRESULT  +    +foreign import stdcall unsafe "mmystem.h midiInPrepareHeader"+    c_midiInPrepareHeader :: HMIDIIN -> Ptr MIDIHDR -> UINT -> IO MMRESULT++foreign import stdcall unsafe "mmystem.h midiOutPrepareHeader"+    c_midiOutPrepareHeader :: HMIDIOUT -> Ptr MIDIHDR -> UINT -> IO MMRESULT++foreign import stdcall unsafe "mmystem.h midiInUnprepareHeader"+    c_midiInUnprepareHeader :: HMIDIIN -> Ptr MIDIHDR -> UINT -> IO MMRESULT++foreign import stdcall unsafe "mmystem.h midiOutUnprepareHeader"+    c_midiOutUnprepareHeader :: HMIDIOUT -> Ptr MIDIHDR -> UINT -> IO MMRESULT+    +type CPrepare   = HMIDI -> Ptr MIDIHDR -> UINT -> IO MMRESULT +type CUnprepare = HMIDI -> Ptr MIDIHDR -> UINT -> IO MMRESULT +    +waitFor :: IO Bool -> IO ()+waitFor check = do+    b <- check+    unless b $ waitFor check  +    +while :: (a -> Bool) -> IO a -> IO a+while cond act = do+    x <- act+    if cond x then while cond act else return x  +    +withMidiHeader :: (MMRESULT -> IO ()) -> CPrepare -> CUnprepare -> HMIDI -> [Word8] -> (HMIDI -> Ptr MIDIHDR -> UINT -> IO a) -> IO a+withMidiHeader mmError prepare unprepare handle bytes action = do+    let n = fromIntegral (length bytes) :: DWORD +        size = 48 :: UINT  -- size of the MIDIHDR structure+    allocaBytes (fromIntegral size) $ \p -> allocaBytes (fromIntegral n) $ \q -> do+      poke (castPtr p             ) q           -- pointer to the data+      poke (castPtr p `plusPtr`  4) n           -- length of the data+      poke (castPtr p `plusPtr` 16) (0::DWORD)  -- flags, must be zero+      mmresult <- prepare   handle p size ; when (mmresult /=0) $ mmError mmresult   +      pokeArray q bytes+      x        <- action    handle p size+{-+      waitFor $ do +        flags <- peek (castPtr p `plusPtr` 16) :: IO DWORD +        return $ (flags .&. 1) /= 0  -- DONE FLAG+      mmresult <- unprepare handle p size ; when (mmresult /=0) $ mmError mmresult   +-}+      mmresult <- while (==65) (unprepare handle p size)    -- 65 is MIDIERR_STILLPLAYING+      return x++newMidiHeader :: (MMRESULT -> IO ()) -> CPrepare -> HMIDI -> Int -> IO (Ptr MIDIHDR)+newMidiHeader mmError prepare handle n = do+    let size = 48 :: UINT  -- size of the MIDIHDR structure+    p <- mallocBytes (fromIntegral size + n)+    let q = castPtr p `plusPtr` (fromIntegral size) :: Ptr Word8+    poke (castPtr p             ) q           -- pointer to the data+    poke (castPtr p `plusPtr`  4) n           -- length of the data+    poke (castPtr p `plusPtr` 16) (0::DWORD)  -- flags, must be zero+    mmresult <- prepare handle p size ; when (mmresult /=0) $ mmError mmresult   +    return p+    +freeMidiHeader :: (MMRESULT -> IO ()) -> CUnprepare -> HMIDI -> Ptr MIDIHDR -> IO ()+freeMidiHeader mmError unprepare handle p = do+    mmresult <- unprepare handle p 48 ; when (mmresult /=0) $ mmError mmresult +    free p++withMidiInHeader  = withMidiHeader mmInError  c_midiInPrepareHeader  c_midiInUnprepareHeader   +withMidiOutHeader = withMidiHeader mmOutError c_midiOutPrepareHeader c_midiOutUnprepareHeader   +newMidiInHeader   = newMidiHeader  mmInError  c_midiInPrepareHeader +freeMidiInHeader  = freeMidiHeader mmInError  c_midiInUnprepareHeader  +    +midiInAddBuffer :: HMIDIIN -> Int -> IO (Ptr MIDIHDR)+midiInAddBuffer handle n = do+    p <- newMidiInHeader handle n +    mmresult <- c_midiInAddBuffer handle p 48 +    when (mmresult /=0) $ mmInError mmresult   +    return p++-- |you shouldn't include the starting/trailing bytes 0xf0 and 0xf7+midiOutSendSysEx :: HMIDIOUT -> [Word8] -> IO ()+midiOutSendSysEx handle msg' = do+    let msg = 0xf0 : (msg' ++ [0xf7])+    --print msg+    mmresult <- withMidiOutHeader handle msg c_midiOutLongMsg +    when (mmresult /=0) $ mmOutError mmresult   +      +midiOutSend :: HMIDIOUT -> ShortMessage -> IO ()+midiOutSend handle msg = do+    mmresult <- c_midiOutShortMsg handle (encodeShortMessage msg)+    when (mmresult /=0) $ mmOutError mmresult   +      +---------- exported Haskell functions ---------++encodeRunningMessages :: [ShortMessage] -> [DWORD]+encodeRunningMessages msgs = encodeShortMessage (head msgs) : map encode' (tail msgs) where+    encode' msg = fromIntegral (sm_byte1 msg) + (shiftL (fromIntegral $ sm_byte2 msg) 8)+     +encodeShortMessage :: ShortMessage -> DWORD+encodeShortMessage (ShortMessage chn' msg' bt1' bt2') +    = chn + shiftL msg 4 + shiftL bt1 8 + shiftL bt2 16  +    where +      chn = 15 .&. fromIntegral chn'+      msg = 15 .&. fromIntegral msg'+      bt1 = fromIntegral bt1'+      bt2 = fromIntegral bt2'+      +decodeShortMessage :: DWORD -> ShortMessage+decodeShortMessage x = ShortMessage chn msg bt1 bt2 +    where+      chn = fromIntegral $ (       x   ) .&. 15+      msg = fromIntegral $ (shiftR x  4) .&. 15+      bt1 = fromIntegral $ (shiftR x  8) .&. 255+      bt2 = fromIntegral $ (shiftR x 16) .&. 255++midiInStart :: HMIDIIN -> IO ()+midiInStart handle = do+    mmresult <- c_midiInStart handle+    when (mmresult /=0) $ mmInError mmresult   ++midiInStop :: HMIDIIN -> IO ()+midiInStop handle = do+    mmresult <- c_midiInStop handle+    when (mmresult /=0) $ mmInError mmresult   ++midiInClose :: HMIDIIN -> IO ()+midiInClose handle = do+    mmresult <- c_midiInClose handle+    when (mmresult /=0) $ mmInError mmresult   ++midiOutClose :: HMIDIOUT -> IO ()+midiOutClose handle = do+    mmresult <- c_midiOutClose handle+    when (mmresult /=0) $ mmOutError mmresult   ++midiInReset :: HMIDIIN -> IO ()+midiInReset handle = do+    mmresult <- c_midiInReset handle+    when (mmresult /=0) $ mmInError mmresult   ++midiOutReset :: HMIDIOUT -> IO ()+midiOutReset handle = do+    mmresult <- c_midiOutReset handle+    when (mmresult /=0) $ mmOutError mmresult   ++data MIM +    = MIM_OPEN+    | MIM_CLOSE+    | MIM_DATA+    | MIM_LONGDATA+    | MIM_ERROR+    | MIM_LONGERROR+    deriving (Eq,Show)+    +mim :: UINT -> MIM+mim 0x3C1 = MIM_OPEN+mim 0x3C2 = MIM_CLOSE+mim 0x3C3 = MIM_DATA+mim 0x3C4 = MIM_LONGDATA+mim 0x3C5 = MIM_ERROR+mim 0x3C6 = MIM_LONGERROR++data MOM +    = MOM_OPEN+    | MOM_CLOSE+    | MOM_DONE+    deriving (Eq,Show)+    +mom :: UINT -> MOM+mom 0x3c7 = MOM_OPEN+mom 0x3c8 = MOM_CLOSE+mom 0x3c9 = MOM_DONE+               +data Callback +    = CALLBACK_NULL            -- ^ no callback+    | CALLBACK_WINDOW          -- ^ callback is window (needs a HWND)+    | CALLBACK_THREAD          -- ^ callback is a thread (needs the thread id)+    | CALLBACK_FUNCTION Bool   -- ^ callback is a function; the boolean is MIDI_IO_STATUS (input only)+    | CALLBACK_EVENT           -- ^ callback is an event (needs an event handle; output only)++callback :: Callback -> DWORD+callback CALLBACK_NULL           = 0x00000000+callback CALLBACK_WINDOW         = 0x00010000+callback CALLBACK_THREAD         = 0x00020000+callback (CALLBACK_FUNCTION ios) = 0x00030000 + if ios then 0x20 else 0+callback CALLBACK_EVENT          = 0x00050000++midiInOpen :: Source -> FunPtr (MIDIINPROC a) -> Ptr a -> Callback -> IO HMIDIIN+midiInOpen (Source dev) proc ref cbtype = +    alloca $ \phandle -> do+      mmresult <- c_midiInOpen phandle dev proc ref (callback cbtype)+      when (mmresult /=0) $ mmInError mmresult+      peek phandle    ++midiOutOpen :: Destination -> FunPtr (MIDIOUTPROC a) -> Ptr a -> Callback -> IO HMIDIOUT +midiOutOpen dst@(Destination dev) proc ref cbtype = do+    alloca $ \phandle -> do+      mmresult <- c_midiOutOpen phandle dev proc ref (callback cbtype)+      when (mmresult /=0) $ mmInError mmresult+      peek phandle