packages feed

hmidi 0.1 → 0.2.0.0

raw patch · 17 files changed

+1240/−323 lines, 17 filesdep ~base

Dependency ranges changed: base

Files

LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2008, Balazs Komuves+Copyright (c) 2008-2013, Balazs Komuves All rights reserved.  Redistribution and use in source and binary forms, with or without@@ -15,15 +15,15 @@ may be used to endorse or promote products derived from this software without specific prior written permission.  -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
-EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
-PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
System/MIDI.hs view
@@ -1,13 +1,13 @@  -- -- Module      : System.MIDI--- Version     : 0.1+-- Version     : 0.2 -- License     : BSD3 -- Author      : Balazs Komuves--- Maintainer  : bkomuves+hmidi@gmail.com+-- Maintainer  : bkomuves (plus) hackage (at) gmail (dot) com -- Stability   : experimental -- Portability : not portable--- Tested with : GHC 6.8.2+-- Tested with : GHC 6.8.3 --  -- |A lowest common denominator interface to the Win32 and MacOSX MIDI bindings. @@ -24,6 +24,7 @@   , enumerateSources   , enumerateDestinations   +  , S.MIDIHasName    , getName   , getModel   , getManufacturer@@ -37,11 +38,19 @@   , stop      , getNextEvent+  , checkNextEvent   , getEvents+  , getEventsUntil   , currentTime   +#ifdef darwin_HOST_OS  +  , createDestination +  , createSource+#endif      ) where +--------------------------------------------------------------------------------+ import Data.Word (Word8,Word32) import System.MIDI.Base @@ -94,7 +103,7 @@ getManufacturer = S.getManufacturer  -- |Opens a MIDI Source.--- There are two possibilites to receive MIDI messages. The user can either support a callback function,+-- There are two possibilites to receive MIDI messages. The user can either supply a callback function, -- or get the messages from an asynchronous buffer. However, mixing the two approaches is not allowed. openSource :: Source -> Maybe ClientCallback -> IO Connection  openSource = S.openSource@@ -103,11 +112,19 @@ openDestination :: Destination -> IO Connection  openDestination = S.openDestination --- |Gets the next event from a buffered connection (see also `openSource`)+-- | Gets the next event from a buffered connection (see also `openSource`) getNextEvent :: Connection -> IO (Maybe MidiEvent) getNextEvent = S.getNextEvent --- |Gets all the events from the buffer (see also `openSource`)+-- | Checks the next event from a buffered connection, but does not remove it from the buffer.+checkNextEvent :: Connection -> IO (Maybe MidiEvent)+checkNextEvent = S.checkNextEvent++-- | Gets all the events with timestamp less than the specified from the buffer.+getEventsUntil :: Connection -> TimeStamp -> IO [MidiEvent]+getEventsUntil = S.getEventsUntil++-- | Gets all the events from the buffer (see also `openSource`) getEvents :: Connection -> IO [MidiEvent] getEvents = S.getEvents       @@ -115,7 +132,7 @@ send :: Connection -> MidiMessage -> IO () send = S.send  --- |Sends a system exclusive message. You shouldn't include the starting \/ trailing bytes 0xF0 and 0xF7.+-- |Sends a system exclusive message. You should /not/ include the starting \/ trailing bytes 0xF0 and 0xF7. --  -- Note: On Win32, the connection must be a `Destination` sendSysEx :: Connection -> [Word8] -> IO ()@@ -137,3 +154,20 @@ currentTime :: Connection -> IO Word32 currentTime = S.currentTime  +--------------------------------------------------------------------------------++#ifdef darwin_HOST_OS  ++-- | Creates a new MIDI destination (which is a source for /us/), to which other programs can connect to.+-- There are two possibilites to receive MIDI messages. The user can either supply a callback function,+-- or get the messages from an asynchronous buffer. However, mixing the two approaches is not allowed.+createDestination :: String -> Maybe ClientCallback -> IO Connection+createDestination = S.createDestination ++-- | Creates a new MIDI source (which is a destination for /us/), to which other programs can connect to.+createSource :: String -> IO Connection+createSource = S.createSource++#endif   ++--------------------------------------------------------------------------------
System/MIDI/Base.hs view
@@ -1,7 +1,7 @@  -- |The hardware-independent part of the MIDI binding.-
-{-# LANGUAGE CPP #-}
++{-# LANGUAGE CPP #-} module System.MIDI.Base    ( TimeStamp   , MidiMessage'(..)@@ -12,39 +12,40 @@   , translateShortMessage   , untranslateShortMessage   , shortMessage-  ) where
-
-import Data.Bits
-import Data.Word
-
-type TimeStamp = Word32 
+  ) 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+-- Remark: 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)
+-- zero velocity instead (for example the EMU Xboard series).  +-- At the moment, the code auto-translates NoteOn messages with zero velocity to NoteOff messages with velocity 64.+-- This behaviour can be inverted with the Cabal flag 'noNoteOff', which translates all NoteOff messages to+-- NoteOn messages with velocity 0.+data MidiMessage' +  = NoteOff         !Int !Int     -- ^ Note Off (key, velocity)+  | 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.  
+-- |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+  | SysEx        [Word8]               -- ^ not including the bytes 0xf0, 0xf7+  | SongPosition !Int                  -- ^ measured in "MIDI beats" (1/16th notes).   | SongSelect   !Int    | TuneRequest-  | SRTClock+  | SRTClock                           -- ^ clock is sent 24 times per quarter note   | SRTStart   | SRTContinue    | SRTStop@@ -54,34 +55,34 @@   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)
+-- 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 -> MidiMessage translateShortMessage (ShortMessage chn msg bt1 bt2) =   if msg < 15 -    then MidiMessage (fromIntegral chn + 1) $ translate' msg k v
+    then MidiMessage (fromIntegral chn + 1) $ translate' msg k v     else translate'' chn k v   where-    k = fromIntegral bt1
+    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)
+#ifdef HMIDI_NO_NOTEOFF+   8  -> NoteOn k 0+   9  -> NoteOn k v+#else+   8  -> NoteOff k v+   9  -> if v>0 then NoteOn k v else NoteOff k 64+#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@@ -100,39 +101,47 @@   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 :: MidiMessage -> ShortMessage+untranslateShortMessage (MidiMessage chn msg') = +  case msg' of+    NoteOff k v         -> shortMessage chn  8 k v+    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 (SongPosition p) = sysShortMessage  2 (p.&.7) (shiftR p 7) +untranslateShortMessage (SongSelect   s) = sysShortMessage  3 (fromIntegral s) 0 +untranslateShortMessage  TuneRequest     = sysShortMessage  6 0 0 +untranslateShortMessage  SRTClock        = sysShortMessage  8 0 0 +untranslateShortMessage  SRTStart        = sysShortMessage 10 0 0 +untranslateShortMessage  SRTContinue     = sysShortMessage 11 0 0 +untranslateShortMessage  SRTStop         = sysShortMessage 12 0 0 +untranslateShortMessage  ActiveSensing   = sysShortMessage 14 0 0 +untranslateShortMessage  Reset           = sysShortMessage 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)
++-- high nibble = message+-- low nibble = chn, or submessage when msg=15 (system messages)+sysShortMessage :: Int -> Int -> Int -> ShortMessage+sysShortMessage chn bt1 bt2 = +  ShortMessage (fromIntegral chn) 15 (fromIntegral bt1) (fromIntegral bt2) ++-- regular short message +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
-
+-- |Low level stuff.+data ShortMessage = ShortMessage +  { sm_channel :: Word8+  , sm_msg     :: Word8 +  , sm_byte1   :: Word8+  , sm_byte2   :: Word8 +  } deriving Show+
System/MIDI/MacOSX.hs view
@@ -25,11 +25,18 @@   , stop      , getNextEvent-  , getEvents+  , checkNextEvent+  , getEvents +  , getEventsUntil    , currentTime   +  , createSource+  , createDestination+     ) where +--------------------------------------------------------------------------------+ import System.MIDI.Base  import Control.Monad@@ -38,12 +45,26 @@ import Data.List import Foreign import Foreign.StablePtr-import System.IO.Unsafe+import System.IO.Unsafe as Unsafe  import System.MacOSX.CoreFoundation import System.MacOSX.CoreAudio-import System.MacOSX.CoreMIDI+import System.MacOSX.CoreMIDI hiding (ShortMessage) +import qualified System.MacOSX.CoreMIDI as CM +--------------------------------------------------------------------------------++-- there are two identical ShortMessage definitions in two separate modules;+-- these function bridges them+_to_CM_SM :: ShortMessage -> CM.ShortMessage+_to_CM_SM (ShortMessage a b c d) = CM.ShortMessage a b c d++_from_CM_SM :: CM.ShortMessage -> ShortMessage+_from_CM_SM (CM.ShortMessage a b c d) = ShortMessage a b c d++--------------------------------------------------------------------------------++{- -- |Gets all the events from the buffer. getEvents :: Connection -> IO [MidiEvent] getEvents conn = do@@ -65,7 +86,60 @@       else do         x <- readChan chan         return (Just x)+-} +-- | 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 all the events with timestamp less than the specified from the buffer.+getEventsUntil :: Connection -> TimeStamp -> IO [MidiEvent]+getEventsUntil conn until = do+  m <- checkNextEvent conn+  case m of+    Nothing -> return []+    Just ev@(MidiEvent ts _) -> do+      if ts < until +        then do+          getNextEvent conn -- remove from the buffer+          evs <- getEventsUntil conn until+          return (ev:evs)+        else+          return []+          +-- | Gets the next event from a buffered connection.+getNextEvent :: Connection -> 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)++-- | Checks the next event from a buffered connection, but does not remove it from the buffer+checkNextEvent :: Connection -> IO (Maybe MidiEvent)+checkNextEvent 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+        unGetChan chan x+        return (Just x)++--------------------------------------------------------------------------------+ type Client      = MIDIClientRef type Device      = MIDIDeviceRef type Port        = MIDIPortRef@@ -73,6 +147,7 @@ -- |The opaque data type representing a MIDI connection data Connection = Connection   { cn_isInput     :: Bool+  , cn_isNew       :: Bool            -- did we create the endpoint?   , cn_port        :: MIDIPortRef   , cn_endpoint    :: MIDIEndpointRef   , cn_time        :: MVar UInt64     -- measured in nanosecs@@ -84,7 +159,7 @@  ----- automatic client creation  -client = unsafePerformIO $ newEmptyMVar :: MVar Client+client = Unsafe.unsafePerformIO $ newEmptyMVar :: MVar Client  {- #ifdef __GLASGOW_HASKELL__@@ -123,7 +198,7 @@ convertShortMessage :: UInt64 -> (MIDITimeStamp,[Word8]) -> IO MidiEvent convertShortMessage t0 (ts',bytes) = do   ts <- audioConvertHostTimeToNanos ts'-  return $ MidiEvent (nanoToMili $ ts-t0) (translateShortMessage $ decodeShortMessage bytes) +  return $ MidiEvent (nanoToMili $ ts-t0) (translateShortMessage $ _from_CM_SM $ decodeShortMessage bytes)   myMIDIReadProc :: Ptr MIDIPacket -> Ptr () -> Ptr () -> IO () myMIDIReadProc packets myptr _  = do@@ -147,7 +222,7 @@       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,+-- There are two possibilites to receive MIDI messages. The user can either supply a callback function, -- or get the messages from an asynchronous buffer. However, mixing the two approaches is not allowed. openSource :: Source -> Maybe ClientCallback -> IO Connection  openSource src@(Source endpoint) mcallback = do@@ -167,7 +242,7 @@    inport <- newInputPort client "Input Port" the_callback (castStablePtrToPtr sp)      -  let conn = Connection True inport endpoint time alive fifo_cb the_callback sp +  let conn = Connection True False inport endpoint time alive fifo_cb the_callback sp    putMVar myData conn   return conn  @@ -180,13 +255,13 @@   alive <- newMVar True   time  <- newEmptyMVar  -  let conn = Connection False outport endpoint time alive undefined undefined undefined +  let conn = Connection False 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+  False -> midiSend (cn_port conn) (Destination $ cn_endpoint conn) (_to_CM_SM msg)     -- |Sends a short message. The connection must be a `Destination`. send :: Connection -> MidiMessage -> IO ()@@ -205,7 +280,8 @@       hosttime <- audioGetCurrentTimeInNanos       putMVar (cn_time conn) hosttime       case cn_isInput conn of -        True  -> connectToSource (cn_port conn) (Source $ cn_endpoint conn) nullPtr+        True  -> when (not (cn_isNew conn)) $ do+          connectToSource (cn_port conn) (Source $ cn_endpoint conn) nullPtr         False -> return ()     else putStrLn "warning: you shouldn't call start twice"   @@ -217,7 +293,8 @@     then do       takeMVar (cn_time conn)        case cn_isInput conn of -        True  -> disconnectFromSource (cn_port conn) (Source $ cn_endpoint conn)+        True  -> when (not (cn_isNew conn)) $ do+          disconnectFromSource (cn_port conn) (Source $ cn_endpoint conn)         False -> return ()     else putStrLn "warning: you shouldn't call stop twice"     @@ -236,4 +313,44 @@     freeHaskellFunPtr (cn_midiproc conn)     freeStablePtr     (cn_mydata   conn)   False -> return ()++--------------------------------------------------------------------------------++-- | Creates a new MIDI destination (which is a source for /us/), to which other programs can connect to.+createDestination :: String -> Maybe ClientCallback -> IO Connection+createDestination name mcallback = do+  client <- getClient+  +  myData <- newEmptyMVar :: IO (MVar Connection)+  sp <- newStablePtr myData +  the_callback <- mkMIDIReadProc myMIDIReadProc++  time  <- newEmptyMVar +  alive <- newMVar True++  fifo_cb <- case mcallback of+    Just cb -> return $ Right cb+    Nothing -> liftM Left $ newChan ++  Source endpoint <- newDestination client name the_callback (castStablePtrToPtr sp) +    +  let inport = error "createDestination/inport"+      conn = Connection True True inport endpoint time alive fifo_cb the_callback sp +  putMVar myData conn+  return conn +++-- | Creates a new MIDI source (which is a destination for /us/), to which other programs can connect to.+createSource :: String -> IO Connection+createSource name = do+  client <- getClient+  Destination endpoint <- newSource client name+  +  outport <- newOutputPort client "Output Port" +  alive <- newMVar True+  time  <- newEmptyMVar ++  let conn = Connection False True outport endpoint time alive undefined undefined undefined +  return conn +
System/MIDI/Placeholder.hs view
@@ -23,11 +23,13 @@   , sendSysEx   , start   , stop-  +   , getNextEvent+  , checkNextEvent   , getEvents+  , getEventsUntil   , currentTime-  +       ) where  import Data.Word@@ -64,7 +66,7 @@ getManufacturer = undefined  -- |Opens a MIDI Source.--- There are two possibilites to receive MIDI messages. The user can either support a callback function,+-- There are two possibilites to receive MIDI messages. The user can either supply a callback function, -- or get the messages from an asynchronous buffer. However, mixing the two approaches is not allowed. openSource :: Source -> Maybe ClientCallback -> IO Connection  openSource = undefined@@ -76,6 +78,14 @@ -- |Gets the next event from a buffered connection (see also `openSource`) getNextEvent :: Connection -> IO (Maybe MidiEvent) getNextEvent = undefined++-- | Checks the next event from a buffered connection, but does not remove it from the buffer.+checkNextEvent :: Connection -> IO (Maybe MidiEvent)+checkNextEvent = undefined++-- | Gets all the events with timestamp less than the specified from the buffer.+getEventsUntil :: Connection -> TimeStamp -> IO [MidiEvent]+getEventsUntil = undefined  -- |Gets all the events from the buffer (see also `openSource`) getEvents :: Connection -> IO [MidiEvent]
+ System/MIDI/Sync.hs view
@@ -0,0 +1,137 @@++-- | MIDI sync to an external clock source.+--+-- To avoid confusion:+-- In our terminology, /beat/ means a quarter note (the same thing as the B in BPM).+-- In MIDI terminology however, a \"MIDI beat\" means a sixteenth note.+--+-- With our notion of beats, one bar is 4 beats (in 4/4 signature, that is)+--++module System.MIDI.Sync +  ( Beats, BPM, openSourceWithSync+  ) +  where++--------------------------------------------------------------------------------++import Control.Monad+import Control.Concurrent+import Control.Concurrent.MVar++import System.MIDI++--------------------------------------------------------------------------------++-- | Song position measured in beats (that is, quarter notes), starting from zero.+-- So with 120 BPM, you will have song position 120 after one minute.+type Beats = Double++-- | Estimated BPM+type BPM = Double++oneTwentyFourth = 1/24 :: Double+lambda          = 0.05 :: Double  -- ad-hoc speed of bpm adjustement++-- | Opens a midi source with the possibility to sync to it. +-- +-- The user callback gets the the song position in /beats/, +-- and also we return functions to query to song position and +-- the estimated BPM. You may want to round the BPM to the nearest +-- integer if that is appropriate. Song position is Nothing when+-- the playback is stopped.+--+-- Note that when first used, it may need some time to calibrate +-- the bpm correctly, so start your MIDI host, press play, and +-- wait a few second. Afterwards, it should be reasonably ok.+-- Also if you do fast realtime BPM changes, +-- it will be a tiny little bit behind.+--+-- Note that we forward all messages (including clock messages) to +-- the user, so you can implement your own handling of transport+-- (start/stop/continue) or send messages on clock if you want.+--  +openSourceWithSync +  :: Source                                     -- ^ midi source+  -> (Maybe Beats -> MidiEvent -> IO ())        -- ^ user callback+  -> IO (Connection, IO (Maybe Beats), IO BPM)  -- ^ (connection, song_position, estimated_bpm) +openSourceWithSync src userCallback = do++  theLastPos   <- newMVar 0       :: IO (MVar Beats)      -- last song position +  theBpmEst    <- newMVar 120     :: IO (MVar BPM)        -- last bpm estimation+  thePlayFlag  <- newMVar False   :: IO (MVar Bool)       -- whether we are playing or stopped+  theLastClock <- newMVar 0       :: IO (MVar TimeStamp)  -- timestamp of last clock signal  +  theLastQuery <- newMVar 0       :: IO (MVar Beats)      -- last queried pos +  +  let queryPos tstamp = do+        b <- readMVar thePlayFlag+        if b +          then do +            lastpos   <- readMVar theLastPos    -- song position at the last clock/start message+            bpm       <- readMVar theBpmEst     -- estimated bpm+            lastclock <- readMVar theLastClock  -- time of the last clock/start message+            let tdiff = fromIntegral (tstamp - lastclock) / 60000.0 :: Double   -- in minutes+            let newpos0 = lastpos + tdiff * bpm  -- extrapolate since last clock signal +            lastquery <- takeMVar theLastQuery+            let newpos = max lastquery newpos0   -- make it monotone in time (!)+            putMVar theLastQuery newpos+            return (Just newpos) +          else return Nothing+              +  let queryBPM = readMVar theBpmEst+        +  let handle (MidiEvent tstamp msg) = case msg of+  +        SongPosition midibeats -> do+          let pos = fromIntegral midibeats / 6+          replaceMVar theLastPos   pos+          replaceMVar theLastQuery pos+  +        SRTStart -> do+          replaceMVar theLastPos   0+          replaceMVar theLastQuery 0+          replaceMVar theLastClock tstamp+          replaceMVar thePlayFlag  True+  +        SRTStop     -> replaceMVar thePlayFlag False+        +        SRTContinue	-> do+          replaceMVar theLastClock tstamp+          replaceMVar thePlayFlag  True+  +        Reset -> do +          replaceMVar theLastPos   0+          replaceMVar theLastQuery 0+          replaceMVar thePlayFlag  False+          replaceMVar theBpmEst    120+          +        SRTClock -> do+          lastclock <- takeMVar theLastClock+          bpm       <- takeMVar theBpmEst+          lastpos   <- takeMVar theLastPos+          let lastpos' = lastpos + oneTwentyFourth+          let tdiff = fromIntegral (tstamp - lastclock) / 60000.0 :: Double   -- in minutes+          let bpm' = (1-lambda)*bpm + lambda*(oneTwentyFourth/tdiff)                        +          putMVar theLastClock tstamp+          putMVar theLastPos lastpos'+          putMVar theBpmEst  bpm'      +          print (bpm',tdiff,1/24/tdiff) +          +        _ -> return ()++  let syncCallback event@(MidiEvent tstamp _) = do+        handle event+        mbpos <- queryPos tstamp+        userCallback mbpos event+          +  conn <- openSource src (Just syncCallback)+  return (conn, currentTime conn >>= queryPos, queryBPM)++--------------------------------------------------------------------------------++replaceMVar :: MVar a -> a -> IO ()      +replaceMVar mv x = do+  _ <- tryTakeMVar mv  +  putMVar mv x+       +--------------------------------------------------------------------------------
+ System/MIDI/Utility.hs view
@@ -0,0 +1,72 @@++-- | Helper functions to make it easy to start messing around++module System.MIDI.Utility+  ( selectMidiDevice+  , selectInputDevice+  , selectOutputDevice+  ) +  where++--------------------------------------------------------------------------------++import Data.List++import Control.Monad+import Control.Concurrent++import System.MIDI+import System.MIDI.Base++--------------------------------------------------------------------------------++maybeRead :: Read a => String -> Maybe a+maybeRead s = case reads s of +  [(x,"")] -> Just x+  _        -> Nothing++-- | Utility function to help choosing a midi device.+-- If there is only a single device, we select that.+-- You can also set a default device (by its name), which+-- will be automatically selected if present.+selectMidiDevice :: MIDIHasName a => Maybe String -> [a] -> IO a  +selectMidiDevice mbdefault srclist = do+  names <- mapM getName srclist+  forM_ (zip [1..] names) $ \(i,name) -> putStrLn $ show i ++ ": " ++ name+  let nsrc = length srclist+  src <- case srclist of+    []  -> fail "no midi devices found"+    [x] -> return x+    _  -> do+      k <- case findIndex (==mbdefault) (map Just names) of+        Just i -> return (i+1)+        Nothing -> do+          putStrLn "please select a midi device"+          l <- getLine+          let k = case maybeRead l of+                    Nothing -> nsrc+                    Just m  -> if m<1 || m>nsrc then nsrc else m+          return k+      putStrLn $ "device #" ++ show k ++ " (" ++ names!!(k-1) ++ ") selected."+      return $ srclist!!(k-1)+  return src+  +-- | Select a MIDI input device (source) +selectInputDevice :: Maybe String -> IO Source  +selectInputDevice mbdefault = do+  srclist <- enumerateSources+  putStrLn "midi sources:"+  src <- selectMidiDevice mbdefault srclist+  return src+  +-- | Select a MIDI output device (destination)+selectOutputDevice :: Maybe String -> IO Destination  +selectOutputDevice mbdefault = do+  dstlist <- enumerateDestinations+  putStrLn "\nmidi destinations:"+  dst <- selectMidiDevice mbdefault dstlist+  return dst++--------------------------------------------------------------------------------++
System/MIDI/Win32.hs view
@@ -25,7 +25,9 @@   , stop      , getNextEvent-  , getEvents  +  , checkNextEvent+  , getEvents +  , getEventsUntil    , currentTime   ) where @@ -35,14 +37,16 @@ import Data.List import Foreign import Foreign.StablePtr-import System.IO.Unsafe+import System.IO.Unsafe as Unsafe  import System.Win32.Types import System.Win32.MIDI   import System.MIDI.Base --- |Gets all the events from the buffer.+--------------------------------------------------------------------------------++-- | Gets all the events from the buffer. getEvents :: Connection -> IO [MidiEvent] getEvents conn = do   m <- getNextEvent conn@@ -51,8 +55,23 @@     Just ev -> do       evs <- getEvents conn       return (ev:evs)-      --- |Gets the next event from a buffered connection.++-- | Gets all the events with timestamp less than the specified from the buffer.+getEventsUntil :: Connection -> TimeStamp -> IO [MidiEvent]+getEventsUntil conn until = do+  m <- checkNextEvent conn+  case m of+    Nothing -> return []+    Just ev@(MidiEvent ts _) -> do+      if ts < until +        then do+          getNextEvent conn -- remove from the buffer+          evs <- getEventsUntil conn until+          return (ev:evs)+        else+          return []+     +-- | Gets the next event from a buffered connection. getNextEvent :: Connection -> IO (Maybe MidiEvent) getNextEvent conn = case cn_fifo_cb conn of   Right _   -> fail "this is not a buffered connection"@@ -64,6 +83,22 @@         x <- readChan chan         return (Just x) +-- | Checks the next event from a buffered connection, but does not remove it from the buffer+checkNextEvent :: Connection -> IO (Maybe MidiEvent)+checkNextEvent 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+        unGetChan chan x+        return (Just x)++--------------------------------------------------------------------------------++ waitFor :: IO Bool -> IO () waitFor check = do   b <- check@@ -168,7 +203,7 @@ midiInBufferSize = 64  -- |Opens a MIDI source.--- There are two possibilites to receive MIDI messages. The user can either support a callback function,+-- There are two possibilites to receive MIDI messages. The user can either supply a callback function, -- or get the messages from an asynchronous buffer. However, mixing the two approaches is not allowed. openSource :: Source -> Maybe ClientCallback -> IO Connection   openSource src mcallback = do
System/MacOSX/CoreAudio.hs view
@@ -1,19 +1,163 @@ --- |Partial binding to CoreAudio, as required for `System.MIDI`. --- At the moment only HostTime is supported. --- In the future this module should grow into a separate entity.+-- | Partial binding to CoreAudio. +-- At the moment only HostTime and parts of the HAL (Hardware Abstraction Layer) is supported. +--+-- See <http://developer.apple.com/documentation/MusicAudio/Reference/CACoreAudioReference/AudioHardware/> -{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-} module System.MacOSX.CoreAudio -  ( audioGetCurrentHostTime+  ( +    -- * some basic types+    Device+  , Stream+  , AudioValueRange(..)+  , Direction(..) +    -- * more types+  , AudioDeviceIOProc +  , AudioDeviceIOProcFloat+  , mkAudioDeviceIOProc+  , AudioTimeStamp(..)+  , SMPTETime(..)+  , AudioBuffer(..)+  , AudioBufferList(..)+  , pokeAudioBufferList+  , peekAudioBufferList+    -- * HostTime+  , audioGetCurrentHostTime   , audioConvertHostTimeToNanos   , audioConvertNanosToHostTime   , audioGetCurrentTimeInNanos+    -- * low-level whatever+  , audioDeviceStart+  , audioDeviceStop+  , audioDeviceAddIOProc+  , audioDeviceRemoveIOProc+    -- * enumerations+  , enumerateAudioDevices+  , enumerateAudioStreams+    -- * properties+  , audioDeviceGetProperty  +  , audioDeviceGetPropertyList  +  , audioDeviceGetPropertyString+  , audioDeviceGetPropertyCFString++{-  +  , audioDeviceGetPropertyUnsafe+  , audioDeviceGetPropertyListUnsafe  +  , audioDeviceGetPropertyStringUnsafe+  , audioDeviceGetPropertyCFStringUnsafe+-}++  , audioDeviceSetProperty  +  , audioDeviceName  +   )   where +-----++import Control.Monad++import Data.Char (ord)++import Foreign+import Foreign.C+ import System.MacOSX.CoreFoundation +----- types++type Device   = UInt32+type Stream   = UInt32++data AudioValueRange = AudioValueRange Float64 Float64 deriving Show+data Direction = In | Out++instance Storable AudioValueRange where+  sizeOf    _ = 16  +  alignment _ = 8+  +  peek p = do+    x <- peek (castPtr p)+    y <- peek (castPtr p `plusPtr` 8)+    return (AudioValueRange x y)+    +  poke p (AudioValueRange x y) = do+    poke (castPtr p) x+    poke (castPtr p `plusPtr` 8) y+ +----- helper functions -----++fromRight :: Either a b -> b+fromRight (Right x) = x++fromJust :: Maybe a -> a+fromJust (Just x) = x++eitherToMaybe :: Either a b -> Maybe b+eitherToMaybe (Left  _) = Nothing+eitherToMaybe (Right x) = Just x++eitherToMaybeIO :: Either a b -> IO (Maybe b)+eitherToMaybeIO = return . eitherToMaybe ++liftRight :: (b -> c) -> Either a b -> Either a c+liftRight _ (Left  y) = Left y+liftRight f (Right x) = Right (f x)++liftRightM :: Monad m => (b -> m c) -> Either a b -> m (Either a c)+liftRightM u ei = case ei of+  Left  y -> return $ Left y+  Right x -> do+    z <- u x+    return $ Right z++liftMaybeIO :: (a -> IO b) -> Maybe a -> IO (Maybe b)+liftMaybeIO _ Nothing  = return Nothing+liftMaybeIO f (Just x) = do { y <- f x ; return (Just y) }+    +----- memory "management" -----++data Mem a = Mem Int (ForeignPtr a)++allocMem n = do+  p <- mallocForeignPtrBytes n+  return $ Mem n p+  +withMem :: Mem a -> (Int -> Ptr a -> IO b) -> IO b+withMem (Mem n p) f = withForeignPtr p $ \q -> f n q++memToString :: Mem CChar -> IO String+memToString m = withMem m $ \_ p -> peekCString p ++memToCFString :: Mem CChar -> IO String+memToCFString m = withMem m $ \_ p -> peekCFString (castPtr p) ++memToStorable :: Storable a => Mem a -> IO a+memToStorable m = withMem m $ \_ p -> peek p ++memToStorableList :: forall a. Storable a => Mem a -> IO [a]+memToStorableList m = withMem m $ \n p -> do+  let u = sizeOf (undefined :: a) +  forM [0..(div n u)-1] $ \i -> peekElemOff p i++---- converting four character IDs and directions++fromFourCharacterID :: String -> UInt32+fromFourCharacterID [a,b,c,d] = +  (ord32 a `shiftL` 24) + +  (ord32 b `shiftL` 16) + +  (ord32 c `shiftL`  8) + +  (ord32 d            )  +  where+    ord32 :: Char -> UInt32+    ord32 = fromIntegral . ord  ++fromDir In  = True+fromDir Out = False++----- HostTime+ foreign import ccall unsafe "HostTime.h AudioGetCurrentHostTime"   audioGetCurrentHostTime :: IO UInt64   @@ -25,4 +169,340 @@  audioGetCurrentTimeInNanos :: IO UInt64   audioGetCurrentTimeInNanos = ( audioGetCurrentHostTime >>= audioConvertHostTimeToNanos )++----- AudioDeviceIOProc -----++-- | Arguments: +--+--    * @device           :: UInt32@, +--+--    * @currentTimeStamp :: Ptr AudioTimeStamp@,+--+--    * @input            :: Ptr (AudioBufferList a)@,+--+--    * @inputTimeStamp   :: Ptr AudioTimeStamp@,+--+--    * @output           :: Ptr (AudioBufferList a)@,+--+--    * @outputTimeStamp  :: Ptr AudioTimeStamp@,+--+--    * @clientData       :: Ptr b@.+--+type AudioDeviceIOProc a b +  =  UInt32 -> Ptr AudioTimeStamp                   +  -> Ptr (AudioBufferList a) -> Ptr AudioTimeStamp+  -> Ptr (AudioBufferList a) -> Ptr AudioTimeStamp+  -> Ptr b                                        +  -> IO OSStatus   +type AudioDeviceIOProcFloat c = AudioDeviceIOProc Float c++foreign import ccall "wrapper"+  mkAudioDeviceIOProc :: AudioDeviceIOProc a b -> IO (FunPtr (AudioDeviceIOProc a b))+ +----- AudioBuffer -----++data AudioBuffer a = AudioBuffer +  { ab_NumberChannels :: UInt32 +  , ab_DataByteSize   :: UInt32+  , ab_Data           :: Ptr a+  }++instance Storable (AudioBuffer a) where+  alignment _ = 4+  sizeOf    _ = 8 + sizeOf (undefined :: Ptr a)+  +  poke p x = do+    poke (castPtr p) (ab_NumberChannels x) ; p <- return $ plusPtr p 4+    poke (castPtr p) (ab_DataByteSize   x) ; p <- return $ plusPtr p 4+    poke (castPtr p) (ab_Data           x) ++  peek p = do+    n <- peek (castPtr p) ; p <- return $ plusPtr p 4+    s <- peek (castPtr p) ; p <- return $ plusPtr p 4+    d <- peek (castPtr p) +    return $ AudioBuffer n s d++----- AudioBufferList -----++-- Keeps track of multiple buffers.+-- +-- > typedef struct AudioBufferList {+-- >   UInt32 mNumberBuffers;+-- >   AudioBuffer mBuffers[1];+-- > } AudioBufferList;+--+-- Discussion+-- +-- When audio data is interleaved, only one buffer is needed in the +-- AudioBufferList; when dealing with multiple mono channels, each will +-- need its own buffer. This is accomplished by allocating the needed +-- space and pointing mBuffers to it.++data AudioBufferList a = AudioBufferList [AudioBuffer a]++-- | Returns the number of bytes written.+pokeAudioBufferList :: Ptr (AudioBufferList a) -> AudioBufferList a -> IO Int+pokeAudioBufferList p (AudioBufferList list) = do+  let len = length list+  poke (castPtr p :: Ptr UInt32) (fromIntegral len)+  pokeArray (castPtr p `plusPtr` 4) list+  return (4 + len * sizeOf (undefined::AudioBuffer a))+  +-- | Does not need the length of the list, as it is stored in the memory.+peekAudioBufferList :: Ptr (AudioBufferList a) -> IO (AudioBufferList a)+peekAudioBufferList p = do+  n <- liftM fromIntegral $ peek (castPtr p :: Ptr UInt32)+  liftM AudioBufferList $ peekArray n (castPtr p `plusPtr` 4)+  +----- AudioTimeStamp -----+  +data AudioTimeStamp = AudioTimeStamp+  { ats_SampleTime    :: Float64 +  , ats_HostTime      :: UInt64 +  , ats_RateScalar    :: Float64+  , ats_WordClockTime :: UInt64+  , ats_SMPTETime     :: SMPTETime+  , ats_Flags         :: UInt32 +  , ats_Reserved      :: UInt32+  } ++instance Storable AudioTimeStamp where+  alignment _ = 8+  sizeOf    _ = 64+  +  poke p x = do+    poke (castPtr p) (ats_SampleTime    x) ; p <- return $ plusPtr p 8+    poke (castPtr p) (ats_HostTime      x) ; p <- return $ plusPtr p 8+    poke (castPtr p) (ats_RateScalar    x) ; p <- return $ plusPtr p 8+    poke (castPtr p) (ats_WordClockTime x) ; p <- return $ plusPtr p 8+    poke (castPtr p) (ats_SMPTETime     x) ; p <- return $ plusPtr p 24+    poke (castPtr p) (ats_Flags         x) ; p <- return $ plusPtr p 4+    poke (castPtr p) (ats_Reserved      x) ++  peek p = do+    s <- peek (castPtr p) ; p <- return $ plusPtr p 8+    h <- peek (castPtr p) ; p <- return $ plusPtr p 8+    r <- peek (castPtr p) ; p <- return $ plusPtr p 8+    w <- peek (castPtr p) ; p <- return $ plusPtr p 8+    m <- peek (castPtr p) ; p <- return $ plusPtr p 24+    f <- peek (castPtr p) ; p <- return $ plusPtr p 4+    v <- peek (castPtr p) +    return $ AudioTimeStamp s h r w m f v+ +kAudioTimeStampSampleTimeValid     = bit 0 :: UInt32+kAudioTimeStampHostTimeValid       = bit 1 :: UInt32+kAudioTimeStampRateScalarValid     = bit 2 :: UInt32+kAudioTimeStampWordClockTimeValid  = bit 3 :: UInt32+kAudioTimeStampSMPTETimeValid      = bit 4 :: UInt32++----- SMPTETime -----++data SMPTETime = SMPTETime +  { smpte_Counter  :: UInt64 +  , smpte_Type     :: UInt32+  , smpte_Flags    :: UInt32 +  , smpte_Hours    :: SInt16 +  , smpte_Minutes  :: SInt16 +  , smpte_Seconds  :: SInt16+  , smpte_Frames   :: SInt16+  } ++instance Storable SMPTETime where+  alignment _ = 8+  sizeOf    _ = 24++  poke p x = do+    poke (castPtr p) (smpte_Counter x) ; p <- return $ plusPtr p 8+    poke (castPtr p) (smpte_Type    x) ; p <- return $ plusPtr p 4+    poke (castPtr p) (smpte_Flags   x) ; p <- return $ plusPtr p 4+    poke (castPtr p) (smpte_Hours   x) ; p <- return $ plusPtr p 2+    poke (castPtr p) (smpte_Minutes x) ; p <- return $ plusPtr p 2+    poke (castPtr p) (smpte_Seconds x) ; p <- return $ plusPtr p 2+    poke (castPtr p) (smpte_Frames  x) ++  peek p = do+    c <- peek (castPtr p) ; p <- return $ plusPtr p 8+    t <- peek (castPtr p) ; p <- return $ plusPtr p 4+    f <- peek (castPtr p) ; p <- return $ plusPtr p 4+    h <- peek (castPtr p) ; p <- return $ plusPtr p 2+    m <- peek (castPtr p) ; p <- return $ plusPtr p 2+    s <- peek (castPtr p) ; p <- return $ plusPtr p 2+    r <- peek (castPtr p) +    return $ SMPTETime c t f h m s r+    +----- AudioDeviceIOProc++foreign import ccall safe "AudioHardware.h AudioDeviceAddIOProc" +  audioDeviceAddIOProc :: Device -> FunPtr (AudioDeviceIOProc a b) -> Ptr b -> IO OSStatus++foreign import ccall safe "AudioHardware.h AudioDeviceRemoveIOProc" +  audioDeviceRemoveIOProc :: Device -> FunPtr (AudioDeviceIOProc a b) -> IO OSStatus++foreign import ccall safe "AudioHardware.h AudioDeviceStart" +  audioDeviceStart :: Device -> FunPtr (AudioDeviceIOProc a b) -> IO OSStatus++foreign import ccall safe "AudioHardware.h AudioDeviceStop" +  audioDeviceStop :: Device -> FunPtr (AudioDeviceIOProc a b) -> IO OSStatus++----- generic wrapper around Audio****GetPropertyInfo & Audio****GetProperty++type GetPropertyInfo = UInt32 -> Ptr UInt32 -> Ptr Boolean -> IO OSStatus+type GetProperty a   = UInt32 -> Ptr UInt32 -> Ptr a       -> IO OSStatus++audioGetPropertyMem :: GetPropertyInfo -> GetProperty a -> String -> IO (Either OSStatus (Mem a))+audioGetPropertyMem getPropertyInfo getProperty id = do+  let id1 = fromFourCharacterID id+  alloca $ \p -> alloca $ \q -> do  +    os1 <- getPropertyInfo id1 p q+    if os1 /=0 +      then return (Left os1)+      else do+        k <- liftM fromIntegral $ peek p :: IO Int+        m <- allocMem k+        os2 <- withMem m $ \_ s -> getProperty id1 p s+        if os2 /=0+          then return $ Left os2+          else return $ Right m++audioGetProperty :: Storable a => GetPropertyInfo -> GetProperty a -> String -> IO (Maybe a)+audioGetProperty gpi gp id = +  (audioGetPropertyMem gpi gp id) >>= eitherToMaybeIO >>= (liftMaybeIO memToStorable)+          +audioGetPropertyList :: Storable a => GetPropertyInfo -> GetProperty a -> String -> IO (Maybe [a])+audioGetPropertyList gpi gp id = +  (audioGetPropertyMem gpi gp id) >>= eitherToMaybeIO >>= (liftMaybeIO memToStorableList)++audioGetPropertyString :: GetPropertyInfo -> GetProperty CChar -> String -> IO (Maybe String)+audioGetPropertyString gpi gp id = +  (audioGetPropertyMem gpi gp id) >>= eitherToMaybeIO >>= (liftMaybeIO memToString)++audioGetPropertyCFString :: GetPropertyInfo -> GetProperty CChar -> String -> IO (Maybe String)+audioGetPropertyCFString gpi gp id = +  (audioGetPropertyMem gpi gp id) >>= eitherToMaybeIO >>= (liftMaybeIO memToCFString)++{-+audioGetPropertyUnsafe         gpi gp id = liftM fromJust $ audioGetProperty         gpi gp id+audioGetPropertyListUnsafe     gpi gp id = liftM fromJust $ audioGetPropertyList     gpi gp id+audioGetPropertyStringUnsafe   gpi gp id = liftM fromJust $ audioGetPropertyString   gpi gp id+audioGetPropertyCFStringUnsafe gpi gp id = liftM fromJust $ audioGetPropertyCFString gpi gp id+-}++----- AudioHardware -----+  +foreign import ccall safe "AudioHardware.h AudioHardwareGetPropertyInfo" +  c_AudioHardwareGetPropertyInfo :: UInt32 -> Ptr UInt32 -> Ptr Boolean -> IO OSStatus++foreign import ccall safe "AudioHardware.h AudioHardwareGetProperty" +  c_AudioHardwareGetProperty :: UInt32 -> Ptr UInt32 -> Ptr a -> IO OSStatus+  +audioHardwareGetPropertyList = +  audioGetPropertyList +    c_AudioHardwareGetPropertyInfo +    c_AudioHardwareGetProperty++enumerateAudioDevices :: IO [Device]+enumerateAudioDevices = do+  xx <- audioHardwareGetPropertyList "dev#"  +  case xx of+    Nothing -> do+      fail "enumeration of audio devices failed."+    Just ls -> return ls+    +----- AudioDevice -----++foreign import ccall safe "AudioHardware.h AudioDeviceGetPropertyInfo" +  c_AudioDeviceGetPropertyInfo +    :: Device -> UInt32 -> Boolean -> UInt32 -> Ptr UInt32 -> Ptr Boolean -> IO OSStatus++foreign import ccall safe "AudioHardware.h AudioDeviceGetProperty" +  c_AudioDeviceGetProperty +    :: Device -> UInt32 -> Boolean -> UInt32 -> Ptr UInt32 -> Ptr a -> IO OSStatus++audioDeviceGetPropertyString :: Device -> Int -> Direction -> String -> IO (Maybe String)+audioDeviceGetPropertyString device channel dir = +  audioGetPropertyString +    (c_AudioDeviceGetPropertyInfo device ch isInput) +    (c_AudioDeviceGetProperty     device ch isInput)+  where +    isInput = fromDir dir +    ch = fromIntegral channel++audioDeviceGetPropertyCFString :: Device -> Int -> Direction -> String -> IO (Maybe String)+audioDeviceGetPropertyCFString device channel dir = +  audioGetPropertyCFString +    (c_AudioDeviceGetPropertyInfo device ch isInput) +    (c_AudioDeviceGetProperty     device ch isInput)+  where +    isInput = fromDir dir +    ch = fromIntegral channel+  +audioDeviceGetPropertyList :: Storable a => Device -> Int -> Direction -> String -> IO (Maybe [a])+audioDeviceGetPropertyList device channel dir =+  audioGetPropertyList+    (c_AudioDeviceGetPropertyInfo device ch isInput) +    (c_AudioDeviceGetProperty     device ch isInput)+  where +    isInput = fromDir dir +    ch = fromIntegral channel++audioDeviceGetProperty +  :: Storable a +  => Device       -- ^ device id+  -> Int          -- ^ channel+  -> Direction    -- ^ direction (input\/output)+  -> String       -- ^ four character ID of the property+  -> IO (Maybe a)+audioDeviceGetProperty device channel dir =+  audioGetProperty+    (c_AudioDeviceGetPropertyInfo device ch isInput) +    (c_AudioDeviceGetProperty     device ch isInput)+  where +    isInput = fromDir dir +    ch = fromIntegral channel++{-+audioDeviceGetPropertyUnsafe         d c i id = liftM fromJust $ audioDeviceGetProperty         d c i id+audioDeviceGetPropertyListUnsafe     d c i id = liftM fromJust $ audioDeviceGetPropertyList     d c i id+audioDeviceGetPropertyStringUnsafe   d c i id = liftM fromJust $ audioDeviceGetPropertyString   d c i id+audioDeviceGetPropertyCFStringUnsafe d c i id = liftM fromJust $ audioDeviceGetPropertyCFString d c i id+-}++audioDeviceName :: Device -> IO String+audioDeviceName dev = liftM fromJust $ audioDeviceGetPropertyString dev 0 Out "name" ++foreign import ccall safe "AudioHardware.h AudioDeviceSetProperty"+  c_AudioDeviceSetProperty +    :: Device -> Ptr AudioTimeStamp -> UInt32 -> Boolean -> UInt32 -> UInt32 -> Ptr a -> IO OSStatus++audioDeviceSetProperty :: Storable a => Device -> UInt32 -> Direction -> String -> a -> IO OSStatus+audioDeviceSetProperty dev channel dir id x = do+  os <- with x $ \p -> c_AudioDeviceSetProperty +    dev nullPtr channel (fromDir dir) (fromFourCharacterID id) (fromIntegral $ sizeOf x) p+  return os+ +-- | input and output streams+enumerateAudioStreams :: Device -> IO ([Stream],[Stream])+enumerateAudioStreams dev = do+  inp <- audioDeviceGetPropertyList dev 0 In  "stm#"+  out <- audioDeviceGetPropertyList dev 0 Out "stm#"+  return ( fromJust inp , fromJust out )++  +----- AudioStream -----++{-+foreign import ccall safe "AudioHardware.h AudioStreamGetPropertyInfo" +  c_AudioStreamGetPropertyInfo +    :: UInt32 -> UInt32 -> UInt32 -> Ptr UInt32 -> Ptr Boolean -> IO OSStatus++foreign import ccall safe "AudioHardware.h AudioStreamGetProperty" +  c_AudioStreamGetProperty +    :: UInt32 -> UInt32 -> UInt32 -> Ptr UInt32 -> Ptr a -> IO OSStatus++audioStreamGetPropertyList stream channel = +  audioGetPropertyList+    (c_AudioStreamGetPropertyInfo stream channel) +    (c_AudioStreamGetProperty     stream channel)+          +-}
System/MacOSX/CoreFoundation.hs view
@@ -1,19 +1,11 @@ --- |Partial binding to CoreFoundation, as required for `System.MIDI`. +-- |Partial binding to CoreFoundation.  -- At the moment only CFString is supported.--- In the future this module should grow into a separate entity.  {-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} module System.MacOSX.CoreFoundation -  ( newCFString-  , releaseCFString-  , peekCFString-  , withCFString-  -  , osStatusString-  , osStatusError-  -  , UInt8  +  ( -- * types+    UInt8     , UInt16     , UInt32    , UInt64@@ -27,9 +19,22 @@   , CFIndex   , ItemCount   , ByteCount+--  , CFString   , CFDataRef   , CFStringRef   , CFAllocatorRef+  , Boolean+  , Float32+  , Float64+    -- * CFString+  , newCFString+  , releaseCFString+  , peekCFString+  , withCFString+    -- * OSStatus+  , osStatusString+  , osStatusError+     ) where  import Data.Bits@@ -54,6 +59,10 @@  type OSErr    = SInt16 type OSStatus = SInt32++type Boolean  = Bool+type Float32  = Float+type Float64  = Double  type UniChar   = Char type CFIndex   = SInt32
System/MacOSX/CoreMIDI.hs view
@@ -1,6 +1,6 @@ --- |Low-level binding to the CoreMIDI services present in Mac OS X.--- Error handling is via `fail`-s in the IO monad. +-- |Low-level (partial) binding to the CoreMIDI services present in Mac OS X.+-- Error \"handling\" is via `fail`-s in the IO monad.   {-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}@@ -24,9 +24,9 @@   , connectToSource   , disconnectFromSource   , midiSend-  , midiSend'+  , midiSendStamped   , midiSendList-  , midiSendList'+  , midiSendListStamped   , midiSendSysEx    -- types  @@ -51,6 +51,8 @@   , Source(..)   , Destination(..) +  , ShortMessage(..)+     -- helper functions to write callbacks   , depackMIDIPacketList   , depackSingleMIDIPacket@@ -62,10 +64,11 @@ import Control.Concurrent.MVar import Foreign import Foreign.Marshal-import System.IO.Unsafe+import System.IO.Unsafe as Unsafe -import System.MIDI.Base+--import System.MIDI.Base import System.MacOSX.CoreFoundation+import System.MacOSX.CoreAudio  data OpaqueMIDIClient data OpaqueMIDIObject@@ -105,9 +108,9 @@ 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+kMIDIPropertyName         = Unsafe.unsafePerformIO $ peek ptr_kMIDIPropertyName+kMIDIPropertyManufacturer = Unsafe.unsafePerformIO $ peek ptr_kMIDIPropertyManufacturer+kMIDIPropertyModel        = Unsafe.unsafePerformIO $ peek ptr_kMIDIPropertyModel  ----- Send @@ -153,7 +156,8 @@   c_MIDISourceCreate      :: MIDIClientRef -> CFStringRef -> Ptr MIDIEndpointRef -> IO OSStatus  foreign import ccall unsafe "MIDIServices.h MIDIDestinationCreate" -  c_MIDIDestinationCreate :: MIDIClientRef -> CFStringRef -> Ptr MIDIEndpointRef -> IO OSStatus+  c_MIDIDestinationCreate +    :: MIDIClientRef -> CFStringRef -> FunPtr (MIDIReadProc r s) -> Ptr r -> Ptr MIDIEndpointRef -> IO OSStatus  foreign import ccall unsafe "MIDIServices.h MIDIEndpointDispose"    c_MIDIEndpointDispose   :: MIDIEndpointRef -> IO OSStatus@@ -274,35 +278,45 @@  data Notification = Notification NotificationMessageID (Maybe [Word8]) -data NotificationMessageID 
-  = SetupChanged 
-  | ObjectAdded  
-  | ObjectRemoved
-  | PropertyChanged 
-  | ThruConnectionsChanged  
-  | SerialPortOwnerChanged  
+data NotificationMessageID +  = SetupChanged +  | ObjectAdded  +  | ObjectRemoved+  | PropertyChanged +  | ThruConnectionsChanged  +  | SerialPortOwnerChanged     | MIDIMsgIOError +  deriving Show   ----- encode / decode  +-- |Short message in low level format.+data ShortMessage = ShortMessage +  { sm_channel :: Word8+  , sm_msg     :: Word8 +  , sm_byte1   :: Word8+  , sm_byte2   :: Word8 +  } deriving Show+   encodeShortMessageList :: [ShortMessage] -> [Word8] encodeShortMessageList list = concatMap encodeShortMessage list  encodeShortMessage :: ShortMessage -> [Word8]-encodeShortMessage (ShortMessage chn' msg' bt1 bt2) =+encodeShortMessage sm@(ShortMessage chn' msg' bt1 bt2) =   case msg of-    8  -> [cmd,bt1,bt2]   -- ?!-    9  -> [cmd,bt1,bt2]  -    10 -> [cmd,bt1,bt2]  -    11 -> [cmd,bt1,bt2]  -    12 -> [cmd,bt1]  -    13 -> [cmd,bt1]  -    14 -> [cmd,bt1,bt2]  +    8  -> [cmd,bt1,bt2]     -- note off+    9  -> [cmd,bt1,bt2]     -- note on+    10 -> [cmd,bt1,bt2]     -- aftertouch+    11 -> [cmd,bt1,bt2]     -- control change+    12 -> [cmd,bt1]         -- program chane+    13 -> [cmd,bt1]         -- channel pressure+    14 -> [cmd,bt1,bt2]     -- pitchwheel     15 -> case chn of-      2 -> [cmd,bt1,bt2]-      3 -> [cmd,bt1]+      2 -> [cmd,bt1,bt2]  -- song position+      3 -> [cmd,bt1]      -- song select       0 -> error "SysEx is not a short message!"-      _ -> [cmd]+      _ -> [cmd]          -- all the rest are one-byte messages+    _ -> error $ "invalid MIDI message high nibble: " ++ show sm    where      chn = 15 .&. chn'     msg = 15 .&. msg'@@ -368,7 +382,7 @@         return $ ( k , xs  )    case hi of        -    8  -> ret 3  -- ?!+    8  -> ret 3       9  -> ret 3       10 -> ret 3       11 -> ret 3 @@ -385,28 +399,34 @@ -- does not include the terminating 0xf7 byte!       sysex :: Ptr Word8 -> IO (Int,[Word8]) sysex p = do -  n <- sysexloop p 2 +  n <- sysexHelper p 2    xs <- mapM (peekElemOff p) [0..n]   return ( n+2 , xs )  -sysexloop :: Ptr Word8 -> Int -> IO Int-sysexloop q i = do+sysexHelper :: Ptr Word8 -> Int -> IO Int+sysexHelper q i = do   x <- peekElemOff q i-  if x == 0xf7 then return (i-1) else sysexloop q (i+1) +  if x == 0xf7 then return (i-1) else sysexHelper 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-+--midiSend port dst msg     = midiSendStamped port dst 0 msg+midiSend port dst msg = do+  timestamp <- audioGetCurrentHostTime        -- see https://forum.ableton.com/viewtopic.php?p=1426466+  midiSendStamped port dst timestamp msg+   -- |Sends a list of short messages with timestamp "now". midiSendList :: MIDIPortRef -> Destination -> [ShortMessage] -> IO () -midiSendList port dst msglist = midiSendList' port dst 0 msglist+--midiSendList port dst msglist = midiSendListStamped port dst 0 msglist+midiSendList port dst msglist = do+  timestamp <- audioGetCurrentHostTime        -- see https://forum.ableton.com/viewtopic.php?p=1426466+  midiSendListStamped port dst timestamp msglist  -- |Sends a short message with the given timestamp.-midiSend' :: MIDIPortRef -> Destination -> MIDITimeStamp -> ShortMessage -> IO ()-midiSend' port (Destination dst) ts msg = do+midiSendStamped :: MIDIPortRef -> Destination -> MIDITimeStamp -> ShortMessage -> IO ()+midiSendStamped port (Destination dst) ts msg = do   let encoded = encodeShortMessage msg       n = length encoded   allocaBytes (4 + 8 + 2 + n) $ \p -> do@@ -418,8 +438,8 @@     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+midiSendListStamped :: MIDIPortRef -> Destination -> MIDITimeStamp -> [ShortMessage] -> IO ()+midiSendListStamped port (Destination dst) ts msglist = do   let encoded = encodeShortMessageList msglist       n = length encoded   allocaBytes (4 + 8 + 2 + n) $ \p -> do@@ -439,7 +459,7 @@ midiSendSysExCallback p = do   free p   --- Sends a system exclusive message. You shouldn't include the starting/trailing bytes 0xF0 and 0xF7.  +-- |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)@@ -516,7 +536,7 @@ ----- 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@@ -542,7 +562,8 @@   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 @@ -564,7 +585,33 @@ newDestination client name = do   dst <- newEndpoint c_MIDIDestinationCreate client name          return $ Destination dst+-}+   +-- | Creates a new MIDI destination (to which other programs can connect to,+-- so that it is a source for /us/) +-- with the given name.+newDestination ::  MIDIClientRef -> String -> FunPtr (MIDIReadProc r s) -> Ptr r -> IO Source --Destination +newDestination client name proc ref = liftM Source $ do+  withCFString name $ \cfname -> do+    alloca $ \ptr_endpoint -> do +      osstatus <- c_MIDIDestinationCreate client cfname proc ref ptr_endpoint+      if osstatus /= 0+        then osStatusError osstatus+        else peek ptr_endpoint++-- | Creates a new MIDI source (to which other programs can connect to, so that+-- it is a destination for /us/) with the given name.+newSource :: MIDIClientRef -> String -> IO Destination -- Source+newSource client name = liftM Destination $ do+  withCFString name $ \cfname -> do+    alloca $ \ptr_endpoint -> do +      osstatus <- c_MIDISourceCreate client cfname ptr_endpoint+      if osstatus /= 0+        then osStatusError osstatus+        else peek ptr_endpoint++ -- |Disposes an existing MIDI endpoint. disposeEndpoint :: Endpoint a => a -> IO ()   disposeEndpoint x = do
examples/GM.hs view
@@ -1,5 +1,5 @@   --- |Part of the General MIDI specs.  +-- | Part of the General MIDI specs.      module GM    ( gmInstrumentByNumber@@ -14,8 +14,12 @@      ) where +--------------------------------------------------------------------------------+ import qualified Data.Map as Map +--------------------------------------------------------------------------------+ swap :: (a,b) -> (b,a) swap (x,y) = (y,x) @@ -48,7 +52,7 @@   , ( 5 , "Electric Piano 2" )   , ( 6 , "Harpsichord" )   , ( 7 , "Clavi" )-  -- (Chromatic Percussion)
+  -- (Chromatic Percussion)   , ( 8 , "Celesta" )   , ( 9 , "Glockenspiel" )   , ( 10 , "Music Box" )@@ -57,7 +61,7 @@   , ( 13 , "Xylophone" )   , ( 14 , "Tubular Bells" )   , ( 15 , "Dulcimer" )-  -- (Organs)
+  -- (Organs)   , ( 16 , "Drawbar Organ" )   , ( 17 , "Percussive Organ" )   , ( 18 , "Rock Organ" )@@ -66,7 +70,7 @@   , ( 21 , "Accordion" )   , ( 22 , "Harmonica" )   , ( 23 , "Tango Accordion" )-  -- (Guitars)
+  -- (Guitars)   , ( 24 , "Acoustic Guitar (nylon)" )   , ( 25 , "Acoustic Guitar (steel)" )   , ( 26 , "Electric Guitar (jazz)" )@@ -75,7 +79,7 @@   , ( 29 , "Overdriven Guitar" )   , ( 30 , "Distortion Guitar" )   , ( 31 , "Guitar harmonics" )-  -- (Bass)
+  -- (Bass)   , ( 32 , "Acoustic Bass" )   , ( 33 , "Fingered Bass" )   , ( 34 , "Picked Bass" )@@ -84,7 +88,7 @@   , ( 37 , "Slap Bass 2" )   , ( 38 , "Synth Bass 1" )   , ( 39 , "Synth Bass 2" )-  -- (Orchestral)
+  -- (Orchestral)   , ( 40 , "Violin" )   , ( 41 , "Viola" )   , ( 42 , "Cello" )@@ -93,7 +97,7 @@   , ( 45 , "Pizzicato Strings" )   , ( 46 , "Orchestral Harp" )   , ( 47 , "Timpani" )-  -- (Ensembles)
+  -- (Ensembles)   , ( 48 , "String Ensemble 1" )   , ( 49 , "String Ensemble 2" )   , ( 50 , "SynthStrings 1" )@@ -102,7 +106,7 @@   , ( 53 , "Voice Oohs" )   , ( 54 , "Synth Voice" )   , ( 55 , "Orchestra Hit" )-  -- (Brass)
+  -- (Brass)   , ( 56 , "Trumpet" )   , ( 57 , "Trombone" )   , ( 58 , "Tuba" )@@ -111,7 +115,7 @@   , ( 61 , "Brass Section" )   , ( 62 , "SynthBrass 1" )   , ( 63 , "SynthBrass 2" )-  -- (Reeds)
+  -- (Reeds)   , ( 64 , "Soprano Sax" )   , ( 65 , "Alto Sax" )   , ( 66 , "Tenor Sax" )@@ -120,7 +124,7 @@   , ( 69 , "English Horn" )   , ( 70 , "Bassoon" )   , ( 71 , "Clarinet" )-  -- (Pipes)
+  -- (Pipes)   , ( 72 , "Piccolo" )   , ( 73 , "Flute" )   , ( 74 , "Recorder" )@@ -129,7 +133,7 @@   , ( 77 , "Shakuhachi" )   , ( 78 , "Whistle" )   , ( 79 , "Ocarina" )-  -- (Synth Leads)
+  -- (Synth Leads)   , ( 80 , "Lead 1 (square)" )   , ( 81 , "Lead 2 (sawtooth)" )   , ( 82 , "Lead 3 (calliope)" )@@ -138,7 +142,7 @@   , ( 85 , "Lead 6 (voice)" )   , ( 86 , "Lead 7 (fifths)" )   , ( 87 , "Lead 8 (bass + lead)" )-  -- (Synth Pads)
+  -- (Synth Pads)   , ( 88 , "Pad 1 (new age)" )   , ( 89 , "Pad 2 (warm)" )   , ( 90 , "Pad 3 (polysynth)" )@@ -147,7 +151,7 @@   , ( 93 , "Pad 6 (metallic)" )   , ( 94 , "Pad 7 (halo)" )   , ( 95 , "Pad 8 (sweep)" )-  -- (Synth FX)
+  -- (Synth FX)   , ( 96 , "FX 1 (rain)" )   , ( 97 , "FX 2 (soundtrack)" )   , ( 98 , "FX 3 (crystal)" )@@ -156,7 +160,7 @@   , ( 101 , "FX 6 (goblins)" )   , ( 102 , "FX 7 (echoes)" )   , ( 103 , "FX 8 (sci-fi)" )-  -- (Ethnic)
+  -- (Ethnic)   , ( 104 , "Sitar" )   , ( 105 , "Banjo" )   , ( 106 , "Shamisen" )@@ -165,7 +169,7 @@   , ( 109 , "Bag pipe" )   , ( 110 , "Fiddle" )   , ( 111 , "Shanai" )-  -- (Percussive)
+  -- (Percussive)   , ( 112 , "Tinkle Bell" )   , ( 113 , "Agogo" )   , ( 114 , "Steel Drums" )@@ -174,7 +178,7 @@   , ( 117 , "Melodic Tom" )   , ( 118 , "Synth Drum" )   , ( 119 , "Reverse Cymbal" )-  -- (Sound Effects)
+  -- (Sound Effects)   , ( 120 , "Guitar Fret Noise" )   , ( 121 , "Breath Noise" )   , ( 122 , "Seashore" )@@ -240,16 +244,20 @@ -- |General MIDI Level 1 specific controllers gm1ControllerList :: [(Int,String)] gm1ControllerList = -  [ ( 1 , "Modulation" )
-  , ( 6 , "Data Entry MSB" )
-  , ( 7 , "Volume" )
-  , ( 10 , "Pan" )
-  , ( 11 , "Expression" )
-  , ( 38 , "Data Entry LSB" )
-  , ( 64 , "Sustain" )
-  , ( 100 , "RPN LSB" )
-  , ( 101 , "RPN MSB" )
-  , ( 121 , "Reset all controllers" )
+  [ ( 1 , "Modulation" )+  , ( 6 , "Data Entry MSB" )+  , ( 7 , "Volume" )+  , ( 10 , "Pan" )+  , ( 11 , "Expression" )+  , ( 38 , "Data Entry LSB" )+  , ( 64 , "Sustain" )+  , ( 100 , "RPN LSB" )+  , ( 101 , "RPN MSB" )+  , ( 121 , "Reset all controllers" )   , ( 123 , "All notes off" )   ]++--------------------------------------------------------------------------------++
examples/SMF.hs view
@@ -3,6 +3,7 @@ -- Implemented as a quick-and-dirty (and ugly) Parsec parser on strings, because  -- I'm lazy and efficiency is (hopefully) not that important in this case. +{-# LANGUAGE PackageImports #-} module SMF   ( module System.MIDI.Base   , MidiEvent'(..)@@ -14,18 +15,22 @@   , timestampUnitInMilisecs   ) where +--------------------------------------------------------------------------------+ import Data.Bits import Data.Char import Data.Int import Data.Word  import Control.Monad-import Text.ParserCombinators.Parsec hiding (Parser) import System.IO +import "parsec2" Text.ParserCombinators.Parsec hiding (Parser)+ import System.MIDI.Base ------ Types+--------------------------------------------------------------------------------+-- Types  -- |SMF meta events data MetaEvent @@ -83,12 +88,13 @@   hClose h  -- hGetContents is lazy, so we should close the file before doing the parsing...   return y    --- |Timestamps in the resulting list of `MidiEvent'`-s are in the SMF units, so most +-- | Timestamps in the resulting list of `MidiEvent'`-s are in the SMF units, so most  -- probably you have to convert them, using `timestampUnitInMilisecs`.   parseSMF :: [Char] -> Either ParseError ((Int,TimeBase),[Track])    parseSMF txt = runParser smf 0 "" txt ------ Parsec parser+--------------------------------------------------------------------------------+-- Parsec parser  smf = do   (typ,trk,div) <- header@@ -159,7 +165,7 @@       msg <- message' hi lo       return $ Right msg   -message' 8  chn = do { k <- int8 ; v <- int8 ; return $ MidiMessage (chn+1) $ NoteOff k          }  +message' 8  chn = do { k <- int8 ; v <- int8 ; return $ MidiMessage (chn+1) $ NoteOff k v        }   message' 9  chn = do { k <- int8 ; v <- int8 ; return $ MidiMessage (chn+1) $ NoteOn  k v        }   message' 10 chn = do { k <- int8 ; v <- int8 ; return $ MidiMessage (chn+1) $ PolyAftertouch k v }   message' 11 chn = do { k <- int8 ; v <- int8 ; return $ MidiMessage (chn+1) $ CC k v             }  @@ -287,4 +293,6 @@   d <- int8   bigendian' (d + shiftL m 8) (l-1)   +--------------------------------------------------------------------------------+
examples/chords.hs view
@@ -8,9 +8,14 @@  module Main where +--------------------------------------------------------------------------------+ import Control.Monad+ import System.MIDI+import System.MIDI.Utility +-------------------------------------------------------------------------------- -- the essence  chord = [0,4,7]@@ -18,48 +23,19 @@  mycallback outconn event@(MidiEvent _ (MidiMessage chn msg)) = do   case msg of-    NoteOff k   -> forM_ chord $ \j -> send outconn $ MidiMessage output_channel $ NoteOff (k+j)+    NoteOff k v -> forM_ chord $ \j -> send outconn $ MidiMessage output_channel $ NoteOff (k+j) v     NoteOn  k v -> forM_ chord $ \j -> send outconn $ MidiMessage output_channel $ NoteOn  (k+j) v     _           -> return ()  mycallback _ _ = return ()---- source / destination selection--maybeRead :: Read a => String -> Maybe a-maybeRead s = case reads s of -  [(x,"")] -> Just x-  _        -> Nothing-  -select srclist = do-  names <- mapM getName srclist-  forM_ (zip [1..] names) $ \(i,name) -> putStrLn $ show i ++ ": " ++ name-  let nsrc = length srclist-  src <- case srclist of-    []  -> fail "no midi devices found"-    [x] -> return x-    _   -> do-      putStrLn "please select a midi device"-      l <- getLine-      let k = case maybeRead l of-        { Nothing -> nsrc-        ; Just m  -> if m<1 || m>nsrc then nsrc else m-        }-      putStrLn $ "device #" ++ show k ++ " selected."-      return $ srclist!!(k-1)-  return src       +-------------------------------------------------------------------------------- -- main              main = do -  srclist <- enumerateSources-  putStrLn "midi sources:"-  src <- select srclist--  dstlist <- enumerateDestinations-  putStrLn "\nmidi destinations:"-  dst <- select dstlist-+  src <- selectInputDevice Nothing+  dst <- selectOutputDevice Nothing+     outconn <- openDestination dst   inconn  <- openSource src $ Just (mycallback outconn)   putStrLn "connected"
examples/monitor.hs view
@@ -6,11 +6,15 @@  module Main where +--------------------------------------------------------------------------------+ import Control.Monad import Control.Concurrent  import System.MIDI+import System.MIDI.Utility +-------------------------------------------------------------------------------- -- the essence  mythread conn = do@@ -18,39 +22,13 @@   mapM_ print events   (threadDelay 5000)   mythread conn---- source / destination selection--maybeRead :: Read a => String -> Maybe a-maybeRead s = case reads s of -  [(x,"")] -> Just x-  _        -> Nothing-  -select srclist = do-  names <- mapM getName srclist-  forM_ (zip [1..] names) $ \(i,name) -> putStrLn $ show i ++ ": " ++ name-  let nsrc = length srclist-  src <- case srclist of-    []  -> fail "no midi devices found"-    [x] -> return x-    _   -> do-      putStrLn "please select a midi device"-      l <- getLine-      let k = case maybeRead l of-        { Nothing -> nsrc-        ; Just m  -> if m<1 || m>nsrc then nsrc else m-        }-      putStrLn $ "device #" ++ show k ++ " selected."-      return $ srclist!!(k-1)-  return src-      +     +-------------------------------------------------------------------------------- -- main              main = do -  srclist <- enumerateSources-  putStrLn "midi sources:"-  src <- select srclist+  src <- selectInputDevice Nothing    conn <- openSource src Nothing   putStrLn "connected"
examples/playmidi.hs view
@@ -1,11 +1,12 @@ ------ A simplified MID file player, as an example application using System.MIDI.+-- | A simplified MID file player, as an example application using System.MIDI. -- You will need a GM (General MIDI) capable synth, or something like that (Windows has one built-in). --  module Main where +--------------------------------------------------------------------------------+ import Data.Ord import Data.List import Control.Concurrent@@ -15,8 +16,11 @@ import System.Exit  import System.MIDI+import System.MIDI.Utility import SMF +--------------------------------------------------------------------------------+ -- player thread  player :: Connection -> MVar [MidiEvent] -> IO ()@@ -71,32 +75,7 @@   meta = map (filterMap tmeta) tracks   midi = map (filterMap tmidi) tracks --- source / destination selection--maybeRead :: Read a => String -> Maybe a-maybeRead s = case reads s of -  [(x,"")] -> Just x-  _        -> Nothing-  -select devlist = do-  names <- mapM getName devlist-  forM_ (zip [1..] names) $ \(i,name) -> putStrLn $ show i ++ ": " ++ name-  let ndev = length devlist-  dev <- case devlist of-    []  -> fail "no midi devices found"-    [x] -> return x-    _   -> do-      putStrLn "please select a midi device"-      l <- getLine-      let k = case maybeRead l of-        { Nothing -> 1-        ; Just m  -> if m<1 || m>ndev then 1 else m-        }-      putStrLn $ "device #" ++ show k ++ " selected."-      return $ devlist!!(k-1)-  return dev---- main+--------------------------------------------------------------------------------  main = do   args <- getArgs@@ -113,8 +92,7 @@   let events = sortBy (comparing $ \(MidiEvent t _) -> t) $ concat (song_tracks song)   mv <- newMVar events   -  dstlist <- enumerateDestinations-  dst <- select dstlist+  dst <- selectOutputDevice Nothing        conn <- openDestination dst   start conn
hmidi.cabal view
@@ -1,40 +1,60 @@ -Name:                hmidi
-Version:             0.1
+Name:                hmidi+Version:             0.2.0.0 Synopsis:            Binding to the OS level MIDI services Description:         Partial implementation of the MIDI 1.0 standard to communicate                       with physical or virtual MIDI devices, eg. MIDI keyboards. -                     Supported operating systems are Mac OS X and Win32 (not tested-                     under Leopard and Vista). See also the alsa-midi library for similar+                     Supported operating systems are Mac OS X and Windows.+                     See also the alsa-midi library for similar                      function under Linux. Please note that there was no effort made (yet) to                      be compatible with the other existing Haskell MIDI libraries. -License:             BSD3
-License-file:        LICENSE
+License:             BSD3+License-file:        LICENSE Author:              Balazs Komuves-Copyright:           (c) 2008 Balazs Komuves
-Maintainer:          bkomuves+hmidi@gmail.com-Stability:           Unstable
+Copyright:           (c) 2008-2013 Balazs Komuves+Maintainer:          bkomuves (plus) hackage (at) gmail (dot) com+Homepage:            http://code.haskell.org/~bkomuves/+Stability:           Experimental Category:            Sound, System-Tested-With:         GHC == 6.8.2-Cabal-Version:       >= 1.2+Tested-With:         GHC == 7.4.2+Cabal-Version:       >= 1.6 Build-Type:          Simple-extra-source-files:  examples/monitor.hs, examples/chords.hs, examples/playmidi.hs, -                     examples/SMF.hs, examples/GM.hs   -Flag NoNoteOff
-  Description:           Translates NoteOff events to NoteOn events with velocity=0.-  Default:               False+extra-source-files:  examples/monitor.hs, +                     examples/chords.hs, +                     examples/playmidi.hs, +                     examples/SMF.hs, +                     examples/GM.hs   +source-repository head+  type:     darcs+  location: http://code.haskell.org/~bkomuves/projects/hmidi/++Flag splitBase+  Description: Choose the new smaller, split-up base package.++Flag noNoteOff+  Description:         Translates NoteOff events to NoteOn events with velocity=0.+  Default:             False+ Library+  if flag(splitBase)+    Build-Depends: base >= 3 && < 5+  else+    Build-Depends: base <  3 -  Build-Depends:       base-  Exposed-Modules:     System.MIDI.Base, System.MIDI-  
+  Exposed-Modules:     System.MIDI.Base, +                       System.MIDI, +                       System.MIDI.Sync,+                       System.MIDI.Utility+   if os(darwin)-    Exposed-Modules:     System.MacOSX.CoreFoundation, System.MacOSX.CoreAudio, System.MacOSX.CoreMIDI -    other-modules:       System.MIDI.MacOSX-    frameworks:          CoreFoundation, CoreAudio, CoreMIDI-    +    Frameworks:          CoreFoundation, CoreAudio, CoreMIDI+    other-modules:       System.MIDI.MacOSX,+                         System.MacOSX.CoreAudio,+                         System.MacOSX.CoreMIDI,+                         System.MacOSX.CoreFoundation+         if os(windows)      Build-Depends:       Win32     Exposed-Modules:     System.Win32.MIDI@@ -45,11 +65,10 @@   if !os(darwin) && !os(windows)     other-modules:       System.MIDI.Placeholder     -  Extensions:            ForeignFunctionInterface, CPP, TypeSynonymInstances, FlexibleInstances, EmptyDataDecls-  ghc-options:         -threaded -  if flag(NoNoteOff)-    cpp-options:           -DHMIDI_NO_NOTEOFF - +  Extensions:          ForeignFunctionInterface, CPP, TypeSynonymInstances, FlexibleInstances, EmptyDataDecls +  ghc-options:         -threaded  +  if flag(noNoteOff)+    cpp-options:         -DHMIDI_NO_NOTEOFF