diff --git a/System/MIDI.hs b/System/MIDI.hs --- a/System/MIDI.hs +++ b/System/MIDI.hs @@ -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 diff --git a/System/MIDI/Base.hs b/System/MIDI/Base.hs --- a/System/MIDI/Base.hs +++ b/System/MIDI/Base.hs @@ -14,10 +14,14 @@ , shortMessage ) where +-------------------------------------------------------------------------------- + import Data.Bits import Data.Word type TimeStamp = Word32 + +-------------------------------------------------------------------------------- -- |A \"regular\" MIDI message. -- diff --git a/System/MIDI/MacOSX.hs b/System/MIDI/MacOSX.hs --- a/System/MIDI/MacOSX.hs +++ b/System/MIDI/MacOSX.hs @@ -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) diff --git a/System/MIDI/Utility.hs b/System/MIDI/Utility.hs --- a/System/MIDI/Utility.hs +++ b/System/MIDI/Utility.hs @@ -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 -------------------------------------------------------------------------------- diff --git a/System/MIDI/Win32.hs b/System/MIDI/Win32.hs --- a/System/MIDI/Win32.hs +++ b/System/MIDI/Win32.hs @@ -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 diff --git a/hmidi.cabal b/hmidi.cabal --- a/hmidi.cabal +++ b/hmidi.cabal @@ -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,