hmidi 0.2.0.0 → 0.2.1.0
raw patch · 6 files changed
+154/−109 lines, 6 filesdep +stmdep ~base
Dependencies added: stm
Dependency ranges changed: base
Files
- System/MIDI.hs +7/−4
- System/MIDI/Base.hs +4/−0
- System/MIDI/MacOSX.hs +45/−44
- System/MIDI/Utility.hs +26/−14
- System/MIDI/Win32.hs +69/−38
- hmidi.cabal +3/−9
System/MIDI.hs view
@@ -1,17 +1,20 @@ -- -- Module : System.MIDI--- Version : 0.2+-- Version : 0.2.1 -- License : BSD3 -- Author : Balazs Komuves -- Maintainer : bkomuves (plus) hackage (at) gmail (dot) com -- Stability : experimental -- Portability : not portable--- Tested with : GHC 6.8.3+-- Tested with : GHC 7.4.2 -- --- |A lowest common denominator interface to the Win32 and MacOSX MIDI bindings. --- Error handling is via `fail`-s in the IO monad. +-- | A lowest common denominator interface to the Win32 and MacOSX MIDI bindings. +-- Error handling is via `fail`-s in the IO monad. .+--+-- Always link with the threaded runtime! (use the -threaded GHC option)+-- {-# LANGUAGE CPP #-} module System.MIDI
System/MIDI/Base.hs view
@@ -14,10 +14,14 @@ , shortMessage ) where +--------------------------------------------------------------------------------+ import Data.Bits import Data.Word type TimeStamp = Word32 ++-------------------------------------------------------------------------------- -- |A \"regular\" MIDI message. --
System/MIDI/MacOSX.hs view
@@ -28,6 +28,12 @@ , checkNextEvent , getEvents , getEventsUntil ++ , getNextEvent'+ , checkNextEvent'+ , getEvents'+ , getEventsUntil' + , currentTime , createSource@@ -41,7 +47,11 @@ import Control.Monad import Control.Concurrent.MVar-import Control.Concurrent.Chan+--import Control.Concurrent.Chan++import Control.Concurrent.STM+import Control.Concurrent.STM.TChan+ import Data.List import Foreign import Foreign.StablePtr@@ -64,78 +74,68 @@ -------------------------------------------------------------------------------- -{---- |Gets all the events from the buffer. getEvents :: Connection -> IO [MidiEvent]-getEvents conn = do- m <- getNextEvent conn- case m of- Nothing -> return []- Just ev -> do- evs <- getEvents conn- return (ev:evs)- --- |Gets the next event from a buffered connection.+getEvents conn = atomically $ getEvents' conn++getEventsUntil :: Connection -> TimeStamp -> IO [MidiEvent]+getEventsUntil conn tstamp = atomically $ getEventsUntil' conn tstamp+ 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)--}+getNextEvent conn = atomically $ getNextEvent' conn +checkNextEvent :: Connection -> IO (Maybe MidiEvent)+checkNextEvent conn = atomically $ checkNextEvent' conn++--------------------------------------------------------------------------------+ -- | Gets all the events from the buffer.-getEvents :: Connection -> IO [MidiEvent]-getEvents conn = do- m <- getNextEvent conn+getEvents' :: Connection -> STM [MidiEvent]+getEvents' conn = do+ m <- getNextEvent' conn case m of Nothing -> return [] Just ev -> do- evs <- getEvents conn+ 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+getEventsUntil' :: Connection -> TimeStamp -> STM [MidiEvent]+getEventsUntil' conn until = do+ m <- checkNextEvent' conn case m of Nothing -> return [] Just ev@(MidiEvent ts _) -> do if ts < until then do- getNextEvent conn -- remove from the buffer- evs <- getEventsUntil conn until+ 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+getNextEvent' :: Connection -> STM (Maybe MidiEvent)+getNextEvent' conn = case cn_fifo_cb conn of Right _ -> fail "this is not a buffered connection" Left chan -> do- b <- isEmptyChan chan+ b <- isEmptyTChan chan if b then return Nothing else do- x <- readChan chan+ x <- readTChan 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+checkNextEvent' :: Connection -> STM (Maybe MidiEvent)+checkNextEvent' conn = case cn_fifo_cb conn of Right _ -> fail "this is not a buffered connection" Left chan -> do- b <- isEmptyChan chan+ b <- isEmptyTChan chan if b then return Nothing else do- x <- readChan chan- unGetChan chan x+ x <- readTChan chan+ unGetTChan chan x return (Just x) --------------------------------------------------------------------------------@@ -152,13 +152,14 @@ , cn_endpoint :: MIDIEndpointRef , cn_time :: MVar UInt64 -- measured in nanosecs , cn_alive :: MVar Bool- , cn_fifo_cb :: Either (Chan MidiEvent) ClientCallback+ , cn_fifo_cb :: Either (TChan MidiEvent) ClientCallback , cn_midiproc :: FunPtr (MIDIReadProc () ()) , cn_mydata :: StablePtr (MVar Connection) } ----- automatic client creation +client :: MVar Client client = Unsafe.unsafePerformIO $ newEmptyMVar :: MVar Client {-@@ -217,7 +218,7 @@ normals <- mapM (convertShortMessage time0) normal let events = sysexs ++ normals case (cn_fifo_cb conn) of- Left chan -> writeList2Chan chan events + Left chan -> atomically $ mapM_ (writeTChan chan) events -- writeList2Chan chan events Right call -> mapM_ call events putMVar mv conn -- do not forget to put it back! @@ -238,7 +239,7 @@ fifo_cb <- case mcallback of Just cb -> return $ Right cb- Nothing -> liftM Left $ newChan + Nothing -> liftM Left $ newTChanIO inport <- newInputPort client "Input Port" the_callback (castStablePtrToPtr sp) @@ -330,7 +331,7 @@ fifo_cb <- case mcallback of Just cb -> return $ Right cb- Nothing -> liftM Left $ newChan + Nothing -> liftM Left $ newTChanIO Source endpoint <- newDestination client name the_callback (castStablePtrToPtr sp)
System/MIDI/Utility.hs view
@@ -15,6 +15,8 @@ import Control.Monad import Control.Concurrent +import System.IO+ import System.MIDI import System.MIDI.Base @@ -29,20 +31,32 @@ -- 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+selectMidiDevice + :: MIDIHasName a + => String -- ^ prompt+ -> Maybe String -- ^ default device name+ -> [a] -- ^ list of devices+ -> IO a +selectMidiDevice prompt mbdefault srclist = do names <- mapM getName srclist- forM_ (zip [1..] names) $ \(i,name) -> putStrLn $ show i ++ ": " ++ name let nsrc = length srclist+ putStrLn prompt src <- case srclist of- [] -> fail "no midi devices found"- [x] -> return x+ [] -> do+ putStrLn "no midi devices found"+ fail "no midi devices found"+ [x] -> do+ putStrLn $ "device #1 (" ++ head names ++ ") selected."+ return x _ -> do k <- case findIndex (==mbdefault) (map Just names) of Just i -> return (i+1) Nothing -> do- putStrLn "please select a midi device"+ forM_ (zip [1..] names) $ \(i,name) -> putStrLn $ show i ++ ": " ++ name+ putStr "please select a midi device: "+ hFlush stdout l <- getLine+ putStrLn "" let k = case maybeRead l of Nothing -> nsrc Just m -> if m<1 || m>nsrc then nsrc else m@@ -52,19 +66,17 @@ return src -- | Select a MIDI input device (source) -selectInputDevice :: Maybe String -> IO Source -selectInputDevice mbdefault = do+selectInputDevice :: String -> Maybe String -> IO Source +selectInputDevice prompt mbdefault = do srclist <- enumerateSources- putStrLn "midi sources:"- src <- selectMidiDevice mbdefault srclist+ src <- selectMidiDevice prompt mbdefault srclist return src -- | Select a MIDI output device (destination)-selectOutputDevice :: Maybe String -> IO Destination -selectOutputDevice mbdefault = do+selectOutputDevice :: String -> Maybe String -> IO Destination +selectOutputDevice prompt mbdefault = do dstlist <- enumerateDestinations- putStrLn "\nmidi destinations:"- dst <- selectMidiDevice mbdefault dstlist+ dst <- selectMidiDevice prompt mbdefault dstlist return dst --------------------------------------------------------------------------------
System/MIDI/Win32.hs view
@@ -28,12 +28,26 @@ , checkNextEvent , getEvents , getEventsUntil ++ , getNextEvent'+ , checkNextEvent'+ , getEvents'+ , getEventsUntil' + , currentTime+ ) where +--------------------------------------------------------------------------------+ import Control.Monad import Control.Concurrent.MVar-import Control.Concurrent.Chan++--import Control.Concurrent.Chan -- for sysex only++import Control.Concurrent.STM+import Control.Concurrent.STM.TChan+ import Data.List import Foreign import Foreign.StablePtr@@ -46,59 +60,73 @@ -------------------------------------------------------------------------------- --- | Gets all the events from the buffer.+ getEvents :: Connection -> IO [MidiEvent]-getEvents conn = do- m <- getNextEvent conn+getEvents conn = atomically $ getEvents' conn++getEventsUntil :: Connection -> TimeStamp -> IO [MidiEvent]+getEventsUntil conn tstamp = atomically $ getEventsUntil' conn tstamp++getNextEvent :: Connection -> IO (Maybe MidiEvent)+getNextEvent conn = atomically $ getNextEvent' conn++checkNextEvent :: Connection -> IO (Maybe MidiEvent)+checkNextEvent conn = atomically $ checkNextEvent' conn++--------------------------------------------------------------------------------++-- | Gets all the events from the buffer.+getEvents' :: Connection -> STM [MidiEvent]+getEvents' conn = do+ m <- getNextEvent' conn case m of Nothing -> return [] Just ev -> do- evs <- getEvents conn+ 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+getEventsUntil' :: Connection -> TimeStamp -> STM [MidiEvent]+getEventsUntil' conn until = do+ m <- checkNextEvent' conn case m of Nothing -> return [] Just ev@(MidiEvent ts _) -> do if ts < until then do- getNextEvent conn -- remove from the buffer- evs <- getEventsUntil conn until+ 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+getNextEvent' :: Connection -> STM (Maybe MidiEvent)+getNextEvent' conn = case cn_fifo_cb conn of Right _ -> fail "this is not a buffered connection" Left chan -> do- b <- isEmptyChan chan+ b <- isEmptyTChan chan if b then return Nothing else do- x <- readChan chan+ x <- readTChan 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+checkNextEvent' :: Connection -> STM (Maybe MidiEvent)+checkNextEvent' conn = case cn_fifo_cb conn of Right _ -> fail "this is not a buffered connection" Left chan -> do- b <- isEmptyChan chan+ b <- isEmptyTChan chan if b then return Nothing else do- x <- readChan chan- unGetChan chan x+ x <- readTChan chan+ unGetTChan chan x return (Just x) -------------------------------------------------------------------------------- - waitFor :: IO Bool -> IO () waitFor check = do b <- check@@ -109,11 +137,11 @@ { cn_isInput :: Bool , cn_handle :: HMIDI , cn_time :: MVar Word32 -- measured in milisecs - , cn_fifo_cb :: Either (Chan MidiEvent) ClientCallback+ , cn_fifo_cb :: Either (TChan MidiEvent) ClientCallback , cn_midiproc :: FunPtr (MIDIINPROC ()) , cn_mydata :: StablePtr (MVar Connection) , cn_inbuf :: MVar (Ptr MIDIHDR)- , cn_sysex :: Chan Word8 -- channel for temporarily storing sysex messages (they can be arbritrary long, but the buffer has fixed size)+ , cn_sysex :: TChan Word8 -- channel for temporarily storing sysex messages (they can be arbritrary long, but the buffer has fixed size) , cn_alive :: MVar Bool } @@ -139,7 +167,7 @@ let tmsg = translateShortMessage $ decodeShortMessage param1 let event = MidiEvent param2 tmsg case (cn_fifo_cb conn) of- Left chan -> writeChan chan event + Left chan -> atomically $ writeTChan chan event Right call -> call event MIM_LONGDATA -> do@@ -152,7 +180,7 @@ forM_ sysexs $ \dat -> do let event = MidiEvent param2 (SysEx dat) case (cn_fifo_cb conn) of- Left chan -> writeChan chan event + Left chan -> atomically $ writeTChan chan event Right call -> call event -- reportedly we are not supposed to call midiInAddBuffer and the like from here, @@ -174,30 +202,33 @@ when (msg /= MIM_CLOSE) $ putMVar mv conn -- do not forget !!! -- I'm not sure, but getChanContents seems to be too lazy for our purposes -readChanList :: Chan a -> IO [a]-readChanList chan = do- b <- isEmptyChan chan +readTChanList' :: TChan a -> STM [a]+readTChanList' chan = do+ b <- isEmptyTChan chan if b then return [] else do- x <- readChan chan- xs <- readChanList chan+ x <- readTChan chan+ xs <- readTChanList' chan return (x:xs) +processSysEx :: TChan Word8 -> [Word8] -> IO [[Word8]]+processSysEx chan dat = atomically $ processSysEx' chan dat + -- the Win32 SysEx support is somewhat brain-dead...-processSysEx :: Chan Word8 -> [Word8] -> IO [[Word8]]-processSysEx _ [] = return []-processSysEx chan dat = do+processSysEx' :: TChan Word8 -> [Word8] -> STM [[Word8]]+processSysEx' _ [] = return []+processSysEx' chan dat = do case (findIndex (==0xf7) dat) of Nothing -> do- writeList2Chan chan dat+ mapM_ (writeTChan chan) dat -- writeList2Chan chan dat return [] Just k -> do- xs <- readChanList chan + xs <- readTChanList' chan let (aa,bb) = splitAt k dat ys = xs ++ aa ev = if (head ys == 0xf0) then tail ys else ys - evs <- processSysEx chan (tail bb)+ evs <- processSysEx' chan (tail bb) return (ev:evs) midiInBufferSize = 64@@ -213,11 +244,11 @@ alive <- newMVar True fifo_cb <- case mcallback of Just cb -> return $ Right cb- Nothing -> liftM Left $ newChan + Nothing -> liftM Left $ newTChanIO time <- newEmptyMVar handle <- midiInOpen src the_callback (castStablePtrToPtr sp) (CALLBACK_FUNCTION False) bufmv <- newEmptyMVar - sysex <- newChan -- channel for temporarily storing sysex messages (they can be arbritrary long, but the buffer has fixed size)+ sysex <- newTChanIO -- channel for temporarily storing sysex messages (they can be arbritrary long, but the buffer has fixed size) let conn = Connection True handle time fifo_cb the_callback sp bufmv sysex alive putMVar myData conn return conn
hmidi.cabal view
@@ -1,6 +1,6 @@ Name: hmidi-Version: 0.2.0.0+Version: 0.2.1.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. @@ -30,19 +30,13 @@ 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 >= 3 && <= 5, stm+ Exposed-Modules: System.MIDI.Base, System.MIDI, System.MIDI.Sync,