hmidi 0.2.1.0 → 0.2.2.0
raw patch · 11 files changed
+233/−64 lines, 11 files
Files
- System/MIDI.hs +20/−5
- System/MIDI/MacOSX.hs +30/−10
- System/MIDI/Placeholder.hs +36/−20
- System/MIDI/Win32.hs +1/−0
- System/MacOSX/CoreFoundation.hs +28/−7
- System/MacOSX/CoreMIDI.hs +61/−16
- examples/chords.hs +2/−2
- examples/monitor.hs +1/−1
- examples/osx_host.hs +50/−0
- examples/playmidi.hs +1/−1
- hmidi.cabal +3/−2
System/MIDI.hs view
@@ -20,38 +20,49 @@ module System.MIDI ( module System.MIDI.Base + -- * MIDI sources and destionations , Source , Destination , Connection- , enumerateSources , enumerateDestinations + -- * names of MIDI devices , S.MIDIHasName , getName , getModel , getManufacturer + -- * connecting to a MIDI source or destination , openSource , openDestination+ , start+ , stop , close++ -- * sending messages , send , sendSysEx- , start- , stop- ++ -- * manual polling of events , getNextEvent , checkNextEvent , getEvents , getEventsUntil+ + -- * querying time , currentTime #ifdef darwin_HOST_OS + -- * creating a MIDI host (OSX only) , createDestination , createSource+ , disposeConnection #endif - ) where + ) + where+ -------------------------------------------------------------------------------- import Data.Word (Word8,Word32)@@ -170,6 +181,10 @@ -- | 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++-- | Dispose a connection we created earlier.+disposeConnection :: Connection -> IO ()+disposeConnection = S.disposeConnection #endif
System/MIDI/MacOSX.hs view
@@ -4,6 +4,7 @@ module System.MIDI.MacOSX ( module System.MIDI.Base + -- * MIDI sources and destionations , Source , Destination , Connection@@ -16,14 +17,18 @@ , getModel , getManufacturer + -- * connecting to a MIDI source or destination , openSource , openDestination , close- , send- , sendSysEx , start , stop + -- * sending messages+ , send+ , sendSysEx+ + -- * manual polling of events , getNextEvent , checkNextEvent , getEvents @@ -33,11 +38,14 @@ , checkNextEvent' , getEvents' , getEventsUntil' - + + -- * querying time , currentTime + -- * creating a MIDI host (OSX only) , createSource , createDestination+ , disposeConnection ) where @@ -262,8 +270,12 @@ 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) (_to_CM_SM msg)- + False -> case cn_isNew conn of + False -> midiSend (cn_port conn) (Destination $ cn_endpoint conn) (_to_CM_SM msg)+ True -> do+ tstamp <- audioGetCurrentTimeInNanos + midiReceivedStamped (Destination $ cn_endpoint conn) tstamp (_to_CM_SM msg) + -- |Sends a short message. The connection must be a `Destination`. send :: Connection -> MidiMessage -> IO () send conn msg = sendShortMessage conn (untranslateShortMessage msg)@@ -300,24 +312,26 @@ else putStrLn "warning: you shouldn't call stop twice" -- |Closes a MIDI Connection+close :: Connection -> IO () close conn = do when (cn_isInput conn) $ do b <- isEmptyMVar (cn_time conn)- when (not b) (stop conn) - disposePort (cn_port conn)+ when (not b) (stop conn) + unless (cn_isNew conn && cn_isInput conn) $ disposePort (cn_port conn) -- inport was undefined in new & input case (see below) cleanup conn -- called by "close"; not exposed. cleanup :: Connection -> IO ()-cleanup conn = case (cn_isInput conn) of+cleanup conn = case cn_isInput conn of True -> do freeHaskellFunPtr (cn_midiproc conn) freeStablePtr (cn_mydata conn) False -> return () --------------------------------------------------------------------------------+-- * Being a MIDI host (so other programs can connect to us). OSX only --- | Creates a new MIDI destination (which is a source for /us/), to which other programs can connect to.+-- | Creates a new MIDI destination (which is a source for /us/), to which other programs can connect to (OSX only). createDestination :: String -> Maybe ClientCallback -> IO Connection createDestination name mcallback = do client <- getClient@@ -341,7 +355,7 @@ return conn --- | Creates a new MIDI source (which is a destination for /us/), to which other programs can connect to.+-- | Creates a new MIDI source (which is a destination for /us/), to which other programs can connect to (OSX only). createSource :: String -> IO Connection createSource name = do client <- getClient@@ -354,4 +368,10 @@ let conn = Connection False True outport endpoint time alive undefined undefined undefined return conn +-- | Dispose a connection we created earlier.+disposeConnection :: Connection -> IO ()+disposeConnection conn = do+ disposeEndpoint (cn_endpoint conn)+ +--------------------------------------------------------------------------------
System/MIDI/Placeholder.hs view
@@ -1,7 +1,8 @@ --- |This is just to be able to produce a Haddock documentation on a Linux system+-- | This is just to be able to produce a Haddock documentation on a Linux system.+-- Linux is not supported at all the moment. -module System.MIDI.Placeholder+module System.MIDI.Placeholder {-# WARNING "Linux is not supported by hmidi at the moment!" #-} ( module System.MIDI.Base , Source@@ -32,9 +33,13 @@ ) where +--------------------------------------------------------------------------------+ import Data.Word import System.MIDI.Base +--------------------------------------------------------------------------------+ -- |The opaque data type representing a MIDI source. data Source @@ -46,74 +51,85 @@ class MIDIHasName c +instance MIDIHasName Source+instance MIDIHasName Destination++--------------------------------------------------------------------------------++linuxUndefined :: a+linuxUndefined = error "hmidi: Linux is not supported"++--------------------------------------------------------------------------------+ -- |Enumerates the MIDI sources present in the system. enumerateSources :: IO [Source]-enumerateSources = undefined+enumerateSources = linuxUndefined -- |Enumerates the MIDI destinations present in the system. enumerateDestinations :: IO [Destination]-enumerateDestinations = undefined+enumerateDestinations = linuxUndefined -- |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 :: MIDIHasName a => a -> IO String+getName :: MIDIHasName a => a -> IO String getModel :: MIDIHasName a => a -> IO String getManufacturer :: MIDIHasName a => a -> IO String -getName = undefined-getModel = undefined-getManufacturer = undefined+getName = linuxUndefined+getModel = linuxUndefined+getManufacturer = linuxUndefined -- |Opens a MIDI Source. -- There are two possibilites to receive MIDI messages. The user can either supply a callback function, -- or get the messages from an asynchronous buffer. However, mixing the two approaches is not allowed. openSource :: Source -> Maybe ClientCallback -> IO Connection -openSource = undefined+openSource = linuxUndefined -- |Opens a MIDI Destination. openDestination :: Destination -> IO Connection -openDestination = undefined+openDestination = linuxUndefined -- |Gets the next event from a buffered connection (see also `openSource`) getNextEvent :: Connection -> IO (Maybe MidiEvent)-getNextEvent = undefined+getNextEvent = linuxUndefined -- | Checks the next event from a buffered connection, but does not remove it from the buffer. checkNextEvent :: Connection -> IO (Maybe MidiEvent)-checkNextEvent = undefined+checkNextEvent = linuxUndefined -- | Gets all the events with timestamp less than the specified from the buffer. getEventsUntil :: Connection -> TimeStamp -> IO [MidiEvent]-getEventsUntil = undefined+getEventsUntil = linuxUndefined -- |Gets all the events from the buffer (see also `openSource`) getEvents :: Connection -> IO [MidiEvent]-getEvents = undefined+getEvents = linuxUndefined -- |Sends a short message. The connection must be a `Destination`. send :: Connection -> MidiMessage -> IO ()-send = undefined+send = linuxUndefined -- |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 :: Connection -> [Word8] -> IO ()-sendSysEx = undefined+sendSysEx = linuxUndefined -- |Starts a connection. This is required for receiving MIDI messages, and also for starting the clock. start :: Connection -> IO ()-start = undefined+start = linuxUndefined -- |Stops a connection. stop :: Connection -> IO ()-stop = undefined+stop = linuxUndefined -- |Closes a MIDI Connection. close :: Connection -> IO ()-close = undefined+close = linuxUndefined -- |Returns the time elapsed since the last `start` call, in milisecs. currentTime :: Connection -> IO Word32-currentTime = undefined+currentTime = linuxUndefined +--------------------------------------------------------------------------------
System/MIDI/Win32.hs view
@@ -339,3 +339,4 @@ freeStablePtr (cn_mydata conn) False -> return () +--------------------------------------------------------------------------------
System/MacOSX/CoreFoundation.hs view
@@ -34,10 +34,14 @@ -- * OSStatus , osStatusString , osStatusError+ , osStatusReport ) where +--------------------------------------------------------------------------------+ import Data.Bits+import Data.Char import Data.Word import Data.Int @@ -47,6 +51,8 @@ import Foreign.C import Foreign.Marshal +--------------------------------------------------------------------------------+ type UInt8 = Word8 type UInt16 = Word16 type UInt32 = Word32@@ -64,7 +70,7 @@ type Float32 = Float type Float64 = Double -type UniChar = Char+type UniChar = UInt16 -- utf16 char, not utf32 !!! type CFIndex = SInt32 type ItemCount = UInt32 type ByteCount = UInt32@@ -77,6 +83,9 @@ type CFStringRef = Ptr CFString type CFAllocatorRef = Ptr CFAllocator +--------------------------------------------------------------------------------++kCFAllocatorDefault :: CFAllocatorRef kCFAllocatorDefault = nullPtr ----- error "handling" :) -----@@ -87,8 +96,15 @@ osStatusError :: OSStatus -> IO a osStatusError osstatus = fail $ osStatusString osstatus +osStatusReport :: OSStatus -> IO ()+osStatusReport osstatus = when (osstatus/=0) $ putStrLn $ osStatusString osstatus+ ----- Base ----- +-- CFDataRef CFDataCreate ( CFAllocatorRef allocator, const UInt8 *bytes, CFIndex length ); +foreign import ccall unsafe "CFBase.h CFDataCreate"+ c_CFDataCreate :: CFAllocatorRef -> Ptr UInt8 -> CFIndex -> IO CFDataRef+ foreign import ccall unsafe "CFBase.h CFRelease" c_CFRelease :: Ptr a -> IO () @@ -113,17 +129,20 @@ -- | Peeks a CFString. peekCFString :: CFStringRef -> IO String peekCFString cfstring = do- n <- c_CFStringGetLength cfstring+ n <- c_CFStringGetLength cfstring p <- c_CFStringGetCharactersPtr cfstring+ -- print (n,p) if p /= nullPtr - then forM [0..n-1] $ \i -> peekElemOff p (fromIntegral i)- else forM [0..n-1] $ \i -> c_CFStringGetCharacterAtIndex cfstring i+ then forM [0..n-1] $ \i -> liftM (chr . fromIntegral) $ peekElemOff p (fromIntegral i)+ else forM [0..n-1] $ \i -> liftM (chr . fromIntegral) $ c_CFStringGetCharacterAtIndex cfstring i -- | Creates a new CFString. You have to release it manually. newCFString :: String -> IO CFStringRef-newCFString string = - let n = length string in allocaArray n $ \p ->- c_CFStringCreateWithCharacters kCFAllocatorDefault p (fromIntegral n)+newCFString string = do+ let n = length string + allocaArray n $ \p -> do+ pokeArray p [ fromIntegral (ord c) | c <- string ]+ c_CFStringCreateWithCharacters kCFAllocatorDefault p (fromIntegral n) -- | Safe passing of a CFString to the OS (releases it afterwards). withCFString :: String -> (CFStringRef -> IO a) -> IO a@@ -132,3 +151,5 @@ x <- action cfstring releaseCFString cfstring return x++--------------------------------------------------------------------------------
System/MacOSX/CoreMIDI.hs view
@@ -13,6 +13,7 @@ , getName , getModel , getManufacturer+ , newSource , newDestination , disposeEndpoint@@ -23,11 +24,14 @@ , disposePort , connectToSource , disconnectFromSource+ , midiSend , midiSendStamped , midiSendList , midiSendListStamped , midiSendSysEx+ , midiReceivedStamped+ , midiReceivedListStamped -- types , OpaqueMIDIClient@@ -60,6 +64,8 @@ , isShortMessage ) where +--------------------------------------------------------------------------------+ import Control.Monad import Control.Concurrent.MVar import Foreign@@ -70,6 +76,8 @@ import System.MacOSX.CoreFoundation import System.MacOSX.CoreAudio +--------------------------------------------------------------------------------+ data OpaqueMIDIClient data OpaqueMIDIObject data OpaqueMIDIDevice@@ -102,7 +110,8 @@ foreign import ccall safe "wrapper" mkMIDIReadProc :: MIDIReadProc () () -> IO (FunPtr (MIDIReadProc () ())) ------ Properties ----- +--------------------------------------------------------------------------------+-- * Properties foreign import ccall "&kMIDIPropertyName" ptr_kMIDIPropertyName :: Ptr CFStringRef foreign import ccall "&kMIDIPropertyManufacturer" ptr_kMIDIPropertyManufacturer :: Ptr CFStringRef@@ -112,7 +121,7 @@ kMIDIPropertyManufacturer = Unsafe.unsafePerformIO $ peek ptr_kMIDIPropertyManufacturer kMIDIPropertyModel = Unsafe.unsafePerformIO $ peek ptr_kMIDIPropertyModel ------ Send+-- * Send foreign import ccall unsafe "MIDIServices.h MIDISend" c_MIDISend :: MIDIPortRef -> MIDIEndpointRef -> Ptr MIDIPacket -> IO OSStatus@@ -120,15 +129,24 @@ foreign import ccall unsafe "MIDIServices.h MIDISendSysex" c_MIDISendSysex :: Ptr MIDISysexSendRequest -> IO OSStatus ------ Clients+-- | Distributes incoming MIDI from a source to the client input ports which are connected to that source+--+-- After creating a virtual source, use MIDIReceived to transmit MIDI messages from your+-- virtual source to any clients connected to the virtual source.+--+-- Unlike @MIDISend()@, a timestamp of 0 is not equivalent to "now"; the driver or virtual.+foreign import ccall unsafe "MIDIServices.h MIDIReceived" + c_MIDIReceived :: MIDIEndpointRef -> Ptr MIDIPacket -> IO OSStatus +-- * Clients+ foreign import ccall unsafe "MIDIServices.h MIDIClientCreate" c_MIDIClientCreate :: CFStringRef -> FunPtr (MIDINotifyProc a) -> Ptr a -> Ptr MIDIClientRef -> IO OSStatus foreign import ccall unsafe "MIDIServices.h MIDIClientDispose" c_MIDIClientDispose :: MIDIClientRef -> IO OSStatus ------ Devices+-- * Devices foreign import ccall unsafe "MIDIServices.h MIDIGetNumberOfDevices" c_MIDIGetNumberOfDevices :: IO ItemCount@@ -136,7 +154,7 @@ foreign import ccall unsafe "MIDIServices.h MIDIGetDevice" c_MIDIGetDevice :: ItemCount -> IO MIDIDeviceRef ------ Endpoints+-- * Endpoints foreign import ccall unsafe "MIDIServices.h MIDIGetNumberOfSources" c_MIDIGetNumberOfSources :: IO ItemCount@@ -166,7 +184,7 @@ foreign import ccall unsafe "MIDIServices.h MIDIEndpointGetEntity" c_MIDIEndpointGetEntity :: MIDIEndpointRef -> Ptr MIDIEntityRef -> IO OSStatus ------- Ports+-- * Ports foreign import ccall safe "MIDIServices.h MIDIInputPortCreate" c_MIDIInputPortCreate :: MIDIClientRef -> CFStringRef -> FunPtr (MIDIReadProc r s) -> Ptr r @@ -184,7 +202,8 @@ foreign import ccall safe "MIDIServices.h MIDIPortDisconnectSource" c_MIDIPortDisconnectSource :: MIDIPortRef -> MIDIEndpointRef -> IO OSStatus ------- Objects+--------------------------------------------------------------------------------+-- * Objects foreign import ccall unsafe "MIDIServices.h MIDIObjectFindByUniqueID" c_MIDIObjectFindByUniqueID :: MIDIUniqueID -> Ptr MIDIObjectRef -> Ptr MIDIObjectType -> IO OSStatus@@ -209,6 +228,7 @@ foreign import ccall unsafe "MIDIServices.h MIDIObjectSetStringProperty" c_MIDIObjectSetStringProperty :: MIDIObjectRef -> CFStringRef -> CFStringRef -> IO OSStatus +-------------------------------------------------------------------------------- midiObjectGetStringProperty :: MIDIObjectRef -> CFStringRef -> IO String midiObjectGetStringProperty object propertyid = @@ -232,8 +252,8 @@ sint32 <- peek ptr_sint32 return sint32 - ----------- exported Haskell functions ----------+-------------------------------------------------------------------------------- +-- * exported Haskell functions newtype Source = Source MIDIEndpointRef deriving (Eq,Show) newtype Destination = Destination MIDIEndpointRef deriving (Eq,Show)@@ -288,7 +308,8 @@ | MIDIMsgIOError deriving Show ------ encode / decode +--------------------------------------------------------------------------------+-- * encode / decode -- |Short message in low level format. data ShortMessage = ShortMessage @@ -408,23 +429,24 @@ x <- peekElemOff q i if x == 0xf7 then return (i-1) else sysexHelper q (i+1) ------ Send+--------------------------------------------------------------------------------+-- * Send messages to destinations we connected to --- |Sends a short message with timestamp "now".+-- | Sends a short message with timestamp "now". midiSend :: MIDIPortRef -> Destination -> ShortMessage -> IO () --midiSend port dst msg = midiSendStamped port dst 0 msg midiSend port dst msg = do timestamp <- audioGetCurrentHostTime -- see https://forum.ableton.com/viewtopic.php?p=1426466 midiSendStamped port dst timestamp msg --- |Sends a list of short messages with timestamp "now".+-- | Sends a list of short messages with timestamp "now". midiSendList :: MIDIPortRef -> Destination -> [ShortMessage] -> IO () --midiSendList port dst msglist = midiSendListStamped port dst 0 msglist midiSendList port dst msglist = do timestamp <- audioGetCurrentHostTime -- see https://forum.ableton.com/viewtopic.php?p=1426466 midiSendListStamped port dst timestamp msglist --- |Sends a short message with the given timestamp.+-- | Sends a short message with the given timestamp. midiSendStamped :: MIDIPortRef -> Destination -> MIDITimeStamp -> ShortMessage -> IO () midiSendStamped port (Destination dst) ts msg = do let encoded = encodeShortMessage msg@@ -437,7 +459,7 @@ osstatus <- c_MIDISend port dst (castPtr p) when (osstatus /= 0) $ osStatusError osstatus --- |Sends a list of short messages with the given timestamp.+-- | Sends a list of short messages with the given timestamp. midiSendListStamped :: MIDIPortRef -> Destination -> MIDITimeStamp -> [ShortMessage] -> IO () midiSendListStamped port (Destination dst) ts msglist = do let encoded = encodeShortMessageList msglist@@ -450,6 +472,27 @@ osstatus <- c_MIDISend port dst (castPtr p) when (osstatus /= 0) $ osStatusError osstatus +--------------------------------------------------------------------------------+-- * sending (short) messages to other programs connected to us++midiReceivedStamped :: Destination -> MIDITimeStamp -> ShortMessage -> IO ()+midiReceivedStamped dst tstamp msg = midiReceivedListStamped dst tstamp [msg]++-- | "Distributes [incoming MIDI from a source] to the client input ports which are connected to that source."+midiReceivedListStamped :: Destination -> MIDITimeStamp -> [ShortMessage] -> IO ()+midiReceivedListStamped (Destination dst) ts msglist = do+ let encoded = encodeShortMessageList msglist+ n = length encoded+ allocaBytes (4 + 8 + 2 + n) $ \p -> do+ poke ( p :: Ptr UInt32) 1+ poke (castPtr p `plusPtr` 4 :: Ptr UInt64) ts+ poke (castPtr p `plusPtr` 12 :: Ptr UInt16) (fromIntegral n)+ pokeArray (castPtr p `plusPtr` 14 :: Ptr Word8 ) encoded + osstatus <- c_MIDIReceived dst (castPtr p)+ when (osstatus /= 0) $ osStatusError osstatus++--------------------------------------------------------------------------------+ type MIDISendSysExCallback = Ptr Word8 -> IO () foreign import ccall safe "wrapper" @@ -480,7 +523,8 @@ osstatus <- c_MIDISendSysex p -- this is asynchronous! (returns immediately before data has been sent) when (osstatus /= 0) $ osStatusError osstatus ------ Ports +--------------------------------------------------------------------------------+-- * Ports -- |Creates a new input port. newInputPort :: MIDIClientRef -> String -> FunPtr (MIDIReadProc r s) -> Ptr r -> IO MIDIPortRef@@ -618,3 +662,4 @@ osstatus <- c_MIDIEndpointDispose (endpoint x) when (osstatus /= 0) $ osStatusError osstatus +--------------------------------------------------------------------------------
examples/chords.hs view
@@ -33,8 +33,8 @@ main = do - src <- selectInputDevice Nothing- dst <- selectOutputDevice Nothing+ src <- selectInputDevice "please select an input device" Nothing+ dst <- selectOutputDevice "please select an output device" Nothing outconn <- openDestination dst inconn <- openSource src $ Just (mycallback outconn)
examples/monitor.hs view
@@ -28,7 +28,7 @@ main = do - src <- selectInputDevice Nothing+ src <- selectInputDevice "please select an input device" Nothing conn <- openSource src Nothing putStrLn "connected"
+ examples/osx_host.hs view
@@ -0,0 +1,50 @@++-- | This example is a MIDI host (unlike the other, which are MIDI clients).+-- This only works on OSX.++module Main where++--------------------------------------------------------------------------------++import Control.Monad++import System.MIDI+import System.MIDI.Utility++--------------------------------------------------------------------------------++myCallback :: Connection -> ClientCallback+myCallback outconn event@(MidiEvent tstamp msg) = do+ print event+ case msg of+ MidiMessage chn short -> do+ putStrLn "forwarding message"+ send outconn msg+ _ -> return ()++--------------------------------------------------------------------------------++main :: IO ()+main = do++ outconn <- createSource "hmidi host out" + inconn <- createDestination "hmidi host in" (Just (myCallback outconn))+ + start outconn + start inconn + putStrLn "started. Press 'ENTER' to exit."+ + getLine+ + stop inconn + stop outconn + putStrLn "stopped."++ close inconn + close outconn+ putStrLn "closed."++ disposeConnection inconn+ disposeConnection outconn+ +--------------------------------------------------------------------------------
examples/playmidi.hs view
@@ -92,7 +92,7 @@ let events = sortBy (comparing $ \(MidiEvent t _) -> t) $ concat (song_tracks song) mv <- newMVar events - dst <- selectOutputDevice Nothing+ dst <- selectOutputDevice "please select an output device" Nothing conn <- openDestination dst start conn
hmidi.cabal view
@@ -1,6 +1,6 @@ Name: hmidi-Version: 0.2.1.0+Version: 0.2.2.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. @@ -11,7 +11,7 @@ License: BSD3 License-file: LICENSE Author: Balazs Komuves-Copyright: (c) 2008-2013 Balazs Komuves+Copyright: (c) 2008-2015 Balazs Komuves Maintainer: bkomuves (plus) hackage (at) gmail (dot) com Homepage: http://code.haskell.org/~bkomuves/ Stability: Experimental@@ -25,6 +25,7 @@ examples/playmidi.hs, examples/SMF.hs, examples/GM.hs + examples/osx_host.hs source-repository head type: darcs