diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2008-2013, Balazs Komuves, Hans Höglund + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither names of the copyright holders nor the names of the contributors +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 +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 +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/examples/GM.hs b/examples/GM.hs new file mode 100644 --- /dev/null +++ b/examples/GM.hs @@ -0,0 +1,255 @@ + +-- |Part of the General MIDI specs. + +module GM + ( gmInstrumentByNumber + , gmInstrumentByName + , gmInstrumentList + + , gmPercussionByKey + , gmPercussionByName + , gmPercussionList + + , gm1ControllerList + + ) where + +import qualified Data.Map as Map + +swap :: (a,b) -> (b,a) +swap (x,y) = (y,x) + +-- |Map of GM instruments, indexed by number +gmInstrumentByNumber :: Map.Map Int String +gmInstrumentByNumber = Map.fromList gmInstrumentList + +-- |Map of GM instruments, indexed by name. +gmInstrumentByName :: Map.Map String Int +gmInstrumentByName = Map.fromList $ map swap gmInstrumentList + +-- |Map of GM percussions, indexed by key. +gmPercussionByKey :: Map.Map Int String +gmPercussionByKey = Map.fromList $ gmPercussionList + +-- |Map of GM percussions, indexed by name. +gmPercussionByName :: Map.Map String Int +gmPercussionByName = Map.fromList $ map swap gmPercussionList + +-- |List of instruments as specified in General MIDI Level 1 +gmInstrumentList :: [(Int,String)] +gmInstrumentList = + [ + -- (Piano) + ( 0 , "Acoustic Grand Piano" ) + , ( 1 , "Bright Acoustic Piano" ) + , ( 2 , "Electric Grand Piano" ) + , ( 3 , "Honky-tonk Piano" ) + , ( 4 , "Electric Piano 1" ) + , ( 5 , "Electric Piano 2" ) + , ( 6 , "Harpsichord" ) + , ( 7 , "Clavi" ) + -- (Chromatic Percussion) + , ( 8 , "Celesta" ) + , ( 9 , "Glockenspiel" ) + , ( 10 , "Music Box" ) + , ( 11 , "Vibraphone" ) + , ( 12 , "Marimba" ) + , ( 13 , "Xylophone" ) + , ( 14 , "Tubular Bells" ) + , ( 15 , "Dulcimer" ) + -- (Organs) + , ( 16 , "Drawbar Organ" ) + , ( 17 , "Percussive Organ" ) + , ( 18 , "Rock Organ" ) + , ( 19 , "Church Organ" ) + , ( 20 , "Reed Organ" ) + , ( 21 , "Accordion" ) + , ( 22 , "Harmonica" ) + , ( 23 , "Tango Accordion" ) + -- (Guitars) + , ( 24 , "Acoustic Guitar (nylon)" ) + , ( 25 , "Acoustic Guitar (steel)" ) + , ( 26 , "Electric Guitar (jazz)" ) + , ( 27 , "Electric Guitar (clean)" ) + , ( 28 , "Electric Guitar (muted)" ) + , ( 29 , "Overdriven Guitar" ) + , ( 30 , "Distortion Guitar" ) + , ( 31 , "Guitar harmonics" ) + -- (Bass) + , ( 32 , "Acoustic Bass" ) + , ( 33 , "Fingered Bass" ) + , ( 34 , "Picked Bass" ) + , ( 35 , "Fretless Bass" ) + , ( 36 , "Slap Bass 1" ) + , ( 37 , "Slap Bass 2" ) + , ( 38 , "Synth Bass 1" ) + , ( 39 , "Synth Bass 2" ) + -- (Orchestral) + , ( 40 , "Violin" ) + , ( 41 , "Viola" ) + , ( 42 , "Cello" ) + , ( 43 , "Contrabass" ) + , ( 44 , "Tremolo Strings" ) + , ( 45 , "Pizzicato Strings" ) + , ( 46 , "Orchestral Harp" ) + , ( 47 , "Timpani" ) + -- (Ensembles) + , ( 48 , "String Ensemble 1" ) + , ( 49 , "String Ensemble 2" ) + , ( 50 , "SynthStrings 1" ) + , ( 51 , "SynthStrings 2" ) + , ( 52 , "Choir Aahs" ) + , ( 53 , "Voice Oohs" ) + , ( 54 , "Synth Voice" ) + , ( 55 , "Orchestra Hit" ) + -- (Brass) + , ( 56 , "Trumpet" ) + , ( 57 , "Trombone" ) + , ( 58 , "Tuba" ) + , ( 59 , "Muted Trumpet" ) + , ( 60 , "French Horn" ) + , ( 61 , "Brass Section" ) + , ( 62 , "SynthBrass 1" ) + , ( 63 , "SynthBrass 2" ) + -- (Reeds) + , ( 64 , "Soprano Sax" ) + , ( 65 , "Alto Sax" ) + , ( 66 , "Tenor Sax" ) + , ( 67 , "Baritone Sax" ) + , ( 68 , "Oboe" ) + , ( 69 , "English Horn" ) + , ( 70 , "Bassoon" ) + , ( 71 , "Clarinet" ) + -- (Pipes) + , ( 72 , "Piccolo" ) + , ( 73 , "Flute" ) + , ( 74 , "Recorder" ) + , ( 75 , "Pan Flute" ) + , ( 76 , "Blown Bottle" ) + , ( 77 , "Shakuhachi" ) + , ( 78 , "Whistle" ) + , ( 79 , "Ocarina" ) + -- (Synth Leads) + , ( 80 , "Lead 1 (square)" ) + , ( 81 , "Lead 2 (sawtooth)" ) + , ( 82 , "Lead 3 (calliope)" ) + , ( 83 , "Lead 4 (chiff)" ) + , ( 84 , "Lead 5 (charang)" ) + , ( 85 , "Lead 6 (voice)" ) + , ( 86 , "Lead 7 (fifths)" ) + , ( 87 , "Lead 8 (bass + lead)" ) + -- (Synth Pads) + , ( 88 , "Pad 1 (new age)" ) + , ( 89 , "Pad 2 (warm)" ) + , ( 90 , "Pad 3 (polysynth)" ) + , ( 91 , "Pad 4 (choir)" ) + , ( 92 , "Pad 5 (bowed)" ) + , ( 93 , "Pad 6 (metallic)" ) + , ( 94 , "Pad 7 (halo)" ) + , ( 95 , "Pad 8 (sweep)" ) + -- (Synth FX) + , ( 96 , "FX 1 (rain)" ) + , ( 97 , "FX 2 (soundtrack)" ) + , ( 98 , "FX 3 (crystal)" ) + , ( 99 , "FX 4 (atmosphere)" ) + , ( 100 , "FX 5 (brightness)" ) + , ( 101 , "FX 6 (goblins)" ) + , ( 102 , "FX 7 (echoes)" ) + , ( 103 , "FX 8 (sci-fi)" ) + -- (Ethnic) + , ( 104 , "Sitar" ) + , ( 105 , "Banjo" ) + , ( 106 , "Shamisen" ) + , ( 107 , "Koto" ) + , ( 108 , "Kalimba" ) + , ( 109 , "Bag pipe" ) + , ( 110 , "Fiddle" ) + , ( 111 , "Shanai" ) + -- (Percussive) + , ( 112 , "Tinkle Bell" ) + , ( 113 , "Agogo" ) + , ( 114 , "Steel Drums" ) + , ( 115 , "Woodblock" ) + , ( 116 , "Taiko Drum" ) + , ( 117 , "Melodic Tom" ) + , ( 118 , "Synth Drum" ) + , ( 119 , "Reverse Cymbal" ) + -- (Sound Effects) + , ( 120 , "Guitar Fret Noise" ) + , ( 121 , "Breath Noise" ) + , ( 122 , "Seashore" ) + , ( 123 , "Bird Tweet" ) + , ( 124 , "Telephone Ring" ) + , ( 125 , "Helicopter" ) + , ( 126 , "Applause" ) + , ( 127 , "Gunshot" ) + ] + +-- |List of percussions (channel 10, key\/name pairs) as specified in General MIDI Level 1. +gmPercussionList :: [(Int,String)] +gmPercussionList = + [ ( 35 , "Acoustic Bass Drum" ) + , ( 36 , "Bass Drum 1" ) + , ( 37 , "Side Stick" ) + , ( 38 , "Acoustic Snare" ) + , ( 39 , "Hand Clap" ) + , ( 40 , "Electric Snare" ) + , ( 41 , "Low Floor Tom" ) + , ( 42 , "Closed Hi-Hat" ) + , ( 43 , "High Floor Tom" ) + , ( 44 , "Pedal Hi-Hat" ) + , ( 45 , "Low Tom" ) + , ( 46 , "Open Hi-Hat" ) + , ( 47 , "Low-Mid Tom" ) + , ( 48 , "Hi-Mid Tom" ) + , ( 49 , "Crash Cymbal 1" ) + , ( 50 , "High Tom" ) + , ( 51 , "Ride Cymbal 1" ) + , ( 52 , "Chinese Cymbal" ) + , ( 53 , "Ride Bell" ) + , ( 54 , "Tambourine" ) + , ( 55 , "Splash Cymbal" ) + , ( 56 , "Cowbell" ) + , ( 57 , "Crash Cymbal 2" ) + , ( 58 , "Vibraslap" ) + , ( 59 , "Ride Cymbal 2" ) + , ( 60 , "Hi Bongo" ) + , ( 61 , "Low Bongo" ) + , ( 62 , "Mute Hi Conga" ) + , ( 63 , "Open Hi Conga" ) + , ( 64 , "Low Conga" ) + , ( 65 , "High Timbale" ) + , ( 66 , "Low Timbale" ) + , ( 67 , "High Agogo" ) + , ( 68 , "Low Agogo" ) + , ( 69 , "Cabasa" ) + , ( 70 , "Maracas" ) + , ( 71 , "Short Whistle" ) + , ( 72 , "Long Whistle" ) + , ( 73 , "Short Guiro" ) + , ( 74 , "Long Guiro" ) + , ( 75 , "Claves" ) + , ( 76 , "Hi Wood Block" ) + , ( 77 , "Low Wood Block" ) + , ( 78 , "Mute Cuica" ) + , ( 79 , "Open Cuica" ) + , ( 80 , "Mute Triangle" ) + , ( 81 , "Open Triangle" ) + ] + +-- |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" ) + , ( 123 , "All notes off" ) + ] + diff --git a/examples/SMF.hs b/examples/SMF.hs new file mode 100644 --- /dev/null +++ b/examples/SMF.hs @@ -0,0 +1,290 @@ + +-- |Decoding the Standard MIDI File (SMF) Format. +-- 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. + +module SMF + ( module System.MIDI.Base + , MidiEvent'(..) + , MetaEvent(..) + , Track + , TimeBase(..) + , parseSMF + , loadSMF + , 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 System.MIDI.Base + +----- Types + +-- |SMF meta events +data MetaEvent + = SequenceNo Int + | Text String + | Copyright String + | TrackName String + | Instrument String + | Lyric String + | Marker String + | CuePoint String + | ProgramName String + | DeviceName String + | EndOfTrack + | Tempo Int -- ^ measured in microseconds per quarter note + | SMPTE Int Int Int Float -- ^ hours, minutes, seconds, frames + | TimeSig Int Int Int Int -- ^ numerator, denominator, ... + | KeySig Int Bool -- ^ negative: flats, positive: sharps. True if major, False if minor + | PropEvent String + | MIDIChannel Int -- ^ obsolate + | MIDIPort Int -- ^ obsolate + deriving (Show,Eq) + +-- |A timetamped SMF event. The meaning of the timestamp depends on the file, see `Tempo` and `TimeSig` (?) +data MidiEvent' = MidiEvent' Int (Either MetaEvent MidiMessage) deriving Show +type Track = [MidiEvent'] + +type Parser a = GenParser Char Word8 a -- state = running status + +mthd = do { string "MThd" ; return () } +mtrk = do { string "MTrk" ; return () } + +data TimeBase = PPQN Int | SMPTE' Int Int deriving Show + +timebase :: TimeBase -> Int +timebase (PPQN n) = n +timebase (SMPTE' fr sf) = fr * sf + +-- |First argument is the division (from the SMF header), second is the tempo (from the `Tempo` meta event). +-- Returns the milisecs per SMF timestamp unit. +timestampUnitInMilisecs :: TimeBase -> Int -> Float +timestampUnitInMilisecs division tempo = case division of + PPQN ppqn -> fromIntegral tempo * 0.001 / fromIntegral ppqn + SMPTE' fr sf -> fromIntegral tempo * 0.001 / fromIntegral (fr*sf) + +loadSMF :: FilePath -> IO ((Int,TimeBase),[Track]) +loadSMF fpath = do + h <- openBinaryFile fpath ReadMode + mid <- hGetContents h + + y <- case runParser smf 0 fpath mid of + Left err -> fail $ show err + Right xx -> return xx + + 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 +-- probably you have to convert them, using `timestampUnitInMilisecs`. +parseSMF :: [Char] -> Either ParseError ((Int,TimeBase),[Track]) +parseSMF txt = runParser smf 0 "" txt + +----- Parsec parser + +smf = do + (typ,trk,div) <- header + when (typ/=1) $ unexpected "only SMF files of type 1 are supported at the moment" + tracks <- replicateM (fromIntegral trk) track + return ((fromIntegral typ,div),tracks) + +header = do + mthd + len <- int32 + when (len/=6) $ fail "invalid header" + typ <- int16 + trk <- int16 + res <- lookAhead int16 + div <- if res>0 + then liftM (PPQN . fromIntegral) int16 + else do + f <- int8 + s <- int8 + return $ SMPTE' (-f) s + return (typ,trk,div) + +track = do + mtrk + len <- liftM fromIntegral int32 + dat <- replicateM len anyChar + withInput dat eventlist + +withInput :: String -> Parser a -> Parser a +withInput s parser = do + inp <- getInput + setInput s + x <- parser + setInput inp + return x + +eventlist = eventlist' 0 + +eventlist' :: Int -> Parser [MidiEvent'] +eventlist' time = do + m <- liftM Just (event time) <|> do { eof ; return Nothing } + case m of + Nothing -> return [] + Just (time',ev) -> do + evs <- eventlist' time' + return (ev:evs) + +event :: Int -> Parser (Int,MidiEvent') +event time = do + delta <- variable + msg <- message + let time' = time + delta + return (time' , MidiEvent' time' msg) + +message :: Parser (Either MetaEvent MidiMessage) +message = do + next <- lookAhead byte + cmd <- if next<128 then getState else byte -- running status hack + let hi = fromIntegral $ shiftR cmd 4 :: Int + lo = fromIntegral $ cmd .&. 15 :: Int + if cmd == 255 + then do + meta <- byte + me <- metaevent meta + return $ Left me + else do + setState cmd + msg <- message' hi lo + return $ Right msg + +message' 8 chn = do { k <- int8 ; v <- int8 ; return $ MidiMessage (chn+1) $ NoteOff k } +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 } +message' 12 chn = do { p <- int8 ; return $ MidiMessage (chn+1) $ ProgramChange p } +message' 13 chn = do { v <- int8 ; return $ MidiMessage (chn+1) $ Aftertouch v } +message' 14 chn = do { l <- int8 ; h <- int8 ; return $ MidiMessage (chn+1) $ PitchWheel (l + shiftL h 7 - 8192) } +message' 15 lo = system lo +message' _ _ = unexpected "expected something at least 0x80" + +system 0 = do { m <- sysex ; return $ SysEx m } +system 1 = return Undefined +system 2 = do { l <- int8 + ; h <- int8 ; return $ SongPosition (l + shiftL h 7) } +system 3 = do { s <- int8 ; return $ SongSelect s } +system 4 = return Undefined +system 5 = return Undefined +system 6 = return TuneRequest +system 7 = return Undefined -- end of SysEx +system 8 = return SRTClock +system 9 = return Undefined +system 10 = return SRTStart +system 11 = return SRTContinue +system 12 = return SRTStop +system 13 = return Undefined +system 14 = return ActiveSensing + +constbyte n = do + b <- byte + when (b /= n) $ unexpected $ "expected " ++ show b + +metaevent 0 = do + l <- byte + case l of + 0 -> return $ SequenceNo (-1) + 2 -> do + l <- int8 + h <- int8 + return $ SequenceNo (l + shiftL h 8) + _ -> unexpected "0 or 2 expected" + +metaevent 1 = do { s <- vstring ; return $ Text s } +metaevent 2 = do { s <- vstring ; return $ Copyright s } +metaevent 3 = do { s <- vstring ; return $ TrackName s } +metaevent 4 = do { s <- vstring ; return $ Instrument s } +metaevent 5 = do { s <- vstring ; return $ Lyric s } +metaevent 6 = do { s <- vstring ; return $ Marker s } +metaevent 7 = do { s <- vstring ; return $ CuePoint s } +metaevent 8 = do { s <- vstring ; return $ ProgramName s } +metaevent 9 = do { s <- vstring ; return $ DeviceName s } +metaevent 0x7f = do { s <- vstring ; return $ PropEvent s } + +metaevent 0x20 = do { constbyte 1 ; l <- int8 ; return $ MIDIChannel l } +metaevent 0x21 = do { constbyte 1 ; l <- int8 ; return $ MIDIPort l } +metaevent 0x2f = do { constbyte 0 ; return EndOfTrack } +metaevent 0x51 = do + constbyte 3 + a <- int8 + b <- int8 + c <- int8 + return $ Tempo $ shiftL a 16 + shiftL b 8 + c +metaevent 0x54 = do + constbyte 5 + hr <- int8 + mn <- int8 + ss <- int8 + fr <- int8 + ff <- int8 + return $ SMPTE hr mn ss (fromIntegral fr + 0.01 * fromIntegral ff) +metaevent 0x58 = do + constbyte 4 + n <- int8 + d <- int8 + c <- int8 + b <- int8 + return $ TimeSig n d c b +metaevent 0x59 = do + constbyte 2 + sf <- int8 + mi <- int8 + x <- case mi of + 0 -> return True -- major + 1 -> return False -- minor + _ -> unexpected "0 or 1 expected" + return $ KeySig sf x + +metaevent k = unexpected $ "unexpected Meta Event " ++ show k + +vstring :: Parser String +vstring = do + l <- variable + s <- replicateM l anyChar + return s + +sysex :: Parser [Word8] +sysex = do + d <- byte + if d /= 0xf7 + then do { ds <- sysex ; return (d:ds) } + else return [] + +byte :: Parser Word8 +byte = liftM (fromIntegral.ord) anyChar + +-- actually, this always give a positive Int! +int8 :: Parser Int +int8 = liftM ord anyChar + +variable :: Parser Int +variable = variable' 0 + +variable' k = do + d <- int8 + let m = (shiftL k 7) + (d .&. 127) + if d .&. 128 == 0 then return m else variable' m + +int16 = liftM fromIntegral (bigendian 2) :: Parser Int16 +int32 = liftM fromIntegral (bigendian 4) :: Parser Int32 + +bigendian :: Int -> Parser Int +bigendian l = bigendian' 0 l + +bigendian' :: Int -> Int -> Parser Int +bigendian' m 0 = return m +bigendian' m l = do + d <- int8 + bigendian' (d + shiftL m 8) (l-1) + + diff --git a/examples/chords.hs b/examples/chords.hs new file mode 100644 --- /dev/null +++ b/examples/chords.hs @@ -0,0 +1,73 @@ + +-- +-- A very simple example application using System.MIDI. +-- +-- It accepts NoteOn / NoteOff messages from a MIDI source and +-- sends corresponding chords to a MIDI destination. +-- + +module Main where + +import Control.Monad +import System.MIDI + +-- the essence + +chord = [0,4,7] +output_channel = 1 + +mycallback outconn event@(MidiEvent _ (MidiMessage chn msg)) = do + case msg of + NoteOff k -> forM_ chord $ \j -> send outconn $ MidiMessage output_channel $ NoteOff (k+j) + 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 + + outconn <- openDestination dst + inconn <- openSource src $ Just (mycallback outconn) + putStrLn "connected" + + start inconn ; putStrLn "started. Press 'ENTER' to exit." + getLine + stop inconn ; putStrLn "stopped." + + close inconn ; putStrLn "closed." + close outconn + diff --git a/examples/monitor.hs b/examples/monitor.hs new file mode 100644 --- /dev/null +++ b/examples/monitor.hs @@ -0,0 +1,67 @@ + +-- +-- A very simple example application using System.MIDI. +-- It's a basic MIDI monitor: prints all the incoming messages. +-- + +module Main where + +import Control.Monad +import Control.Concurrent + +import System.MIDI + +-- the essence + +mythread conn = do + events <- getEvents conn + 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 + + conn <- openSource src Nothing + putStrLn "connected" + + threadid <- forkIO (mythread conn) + + start conn ; putStrLn "started. Press 'ENTER' to exit." + getLine + stop conn ; putStrLn "stopped." + + killThread threadid + + close conn ; putStrLn "closed." + diff --git a/examples/playmidi.hs b/examples/playmidi.hs new file mode 100644 --- /dev/null +++ b/examples/playmidi.hs @@ -0,0 +1,132 @@ + +-- +-- 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 +import Control.Monad +import System.IO +import System.Environment +import System.Exit + +import System.MIDI +import SMF + +-- player thread + +player :: Connection -> MVar [MidiEvent] -> IO () +player conn mv = do + t <- currentTime conn + evs <- readMVar mv + case evs of + [] -> do + putStrLn "the song ended." + return () + (MidiEvent s ev):evs' -> do + when (s<=t) $ do + swapMVar mv evs' + case ev of + SysEx _ -> return () + Undefined -> return () + _ -> send conn ev + threadDelay 1000 + player conn mv + +-- song + +data Song = Song + { song_bpm :: Float + , song_tracks :: [[MidiEvent]] + } + +filterMap :: (a -> Maybe b) -> [a] -> [b] +filterMap f xs = map (fromJust . f) $ filter test xs where + test x = case f x of + Just _ -> True + Nothing -> False + fromJust (Just x) = x + +tmeta (MidiEvent' ts (Left x)) = Just (ts,x) +tmeta (MidiEvent' _ (Right _)) = Nothing + +tmidi (MidiEvent' _ (Left _)) = Nothing +tmidi (MidiEvent' ts (Right y)) = Just $ MidiEvent (fromIntegral ts) y + +toSong :: TimeBase -> [[MidiEvent']] -> Song +toSong division tracks = Song bpm $ map convert midi where + convert = map (\(MidiEvent ts ev) -> MidiEvent (round $ pertick * fromIntegral ts) ev) + tTempo (_,Tempo tempo) = Just tempo + tTempo _ = Nothing + tempos = filterMap tTempo metaAll + (tempo,bpm) = case tempos of + [] -> ( 500000 , 120 ) + t:_ -> ( t , 60000000 / fromIntegral t ) + pertick = timestampUnitInMilisecs division tempo + metaAll = concat meta + 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 + fname <- case args of + [s] -> return s + _ -> do + putStrLn "Usage: playmidi " + exitFailure + + ((_,division),tracks) <- loadSMF fname + let song = toSong division tracks + putStrLn $ "bpm = " ++ show (song_bpm song) + + let events = sortBy (comparing $ \(MidiEvent t _) -> t) $ concat (song_tracks song) + mv <- newMVar events + + dstlist <- enumerateDestinations + dst <- select dstlist + + conn <- openDestination dst + start conn + + thread <- forkIO (player conn mv) + + putStrLn "Press 'ENTER' to exit." + getLine + + killThread thread + + close conn + + + diff --git a/hamid.cabal b/hamid.cabal new file mode 100644 --- /dev/null +++ b/hamid.cabal @@ -0,0 +1,76 @@ + +name: hamid +version: 0.7 +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 + function under Linux. Please note that there was no effort made (yet) to + be compatible with the other existing Haskell MIDI libraries. + + Fork by Hans Höglund, adding support for Codec.Midi types et al. + +license: BSD3 +license-file: LICENSE +author: Balazs Komuves +copyright: (c) 2008 Balazs Komuves +maintainer: hans@hanshoglund.se +stability: Unstable +category: Sound, System +tested-with: GHC == 6.8.2 +cabal-version: >= 1.2 +build-type: Simple + +extra-source-files: examples/monitor.hs, + examples/chords.hs, + examples/playmidi.hs, + examples/SMF.hs, + examples/GM.hs + +library + build-depends: + base >= 4 && < 5, + HCodecs, + newtype + hs-source-dirs: src + exposed-modules: + System.MIDI + other-modules: + System.MIDI.Base + extensions: + ForeignFunctionInterface, + CPP, + TypeSynonymInstances, + FlexibleInstances, + EmptyDataDecls + ghc-options: + -threaded + + if os(darwin) + other-modules: + System.MacOSX.CoreFoundation, + System.MacOSX.CoreAudio, + System.MacOSX.CoreMIDI + System.MIDI.MacOSX + frameworks: + CoreFoundation, + CoreAudio, + CoreMIDI + + if os(windows) + build-depends: + Win32 + other-modules: + System.Win32.MIDI + System.MIDI.Win32 + extra-libraries: + winmm + + if !os(darwin) && ! os(windows) + other-modules: + System.MIDI.Placeholder + + + diff --git a/src/System/MIDI.hs b/src/System/MIDI.hs new file mode 100644 --- /dev/null +++ b/src/System/MIDI.hs @@ -0,0 +1,226 @@ + +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-} + + +-- +-- Module : System.MIDI +-- Version : 0.1 +-- License : BSD3 +-- Author : Balazs Komuves +-- Maintainer : bkomuves+hmidi@gmail.com +-- Stability : experimental +-- Portability : not portable +-- Tested with : GHC 6.8.2 +-- + +-- | A lowest common denominator interface to the Win32 and MacOSX MIDI bindings. +-- Error handling is via `fail`-s in the IO monad. + +module System.MIDI ( + -- * Messages + MidiTime, + MidiMessage, + MidiEvent, + + -- * Input and output + MidiHasName(..), + + -- ** Sources and Destinations + Source, + sources, + Destination, + destinations, + + -- ** Streams + openSource, + openDestination, + Stream, + close, + start, + stop, + + -- * Sending + send, + -- sendSysEx, + + -- * Receiving + getNextEvent, + getEvents, + + -- * Timer + currentTime, + ) where + +import Data.Word (Word8,Word32) +import System.MIDI.Base hiding (MidiEvent, MidiMessage) +import System.IO.Unsafe (unsafePerformIO) + +import qualified Codec.Midi as C + +#ifdef mingw32_HOST_OS +import qualified System.MIDI.Win32 as S +#define HMIDI_SUPPORTED_OS +#endif + +#ifdef darwin_HOST_OS +import qualified System.MIDI.MacOSX as S +#define HMIDI_SUPPORTED_OS +#endif + +-- this is just to be able to produce a Haddock documentation on a not supported system (eg. Linux) +#ifndef HMIDI_SUPPORTED_OS +import qualified System.MIDI.Placeholder as S +#endif + +type MidiTime = Word32 +type MidiMessage = C.Message +type MidiEvent = (MidiTime, C.Message) + +class MidiHasName a where + name :: a -> IO String + +instance MidiHasName Source where + name = S.getName . getSource + +instance MidiHasName Destination where + name = S.getName . getDestination + + +-- All the definitions in this file are neccessary to be able to have a nice Haddock-generated +-- documentation independently of the platform. Though I still don't know how to generate documentation +-- for a platform-specific module while being on an a different platform (probably not at all possible +-- at present?) + +-- | The opaque data type representing a MIDI source. +newtype Source = Source { getSource :: S.Source } + deriving (Eq) + +-- | The opaque data type representing a MIDI destination. +newtype Destination = Destination { getDestination :: S.Destination } + deriving (Eq) + +instance Show Source where + show = (\n -> "") . unsafePerformIO . name + +instance Show Destination where + show = (\n -> "") . unsafePerformIO . name + +-- | The opaque data type representing a MIDI connection. +newtype Stream = Stream { getStream :: S.Connection } + +-- | Enumerates the MIDI sources present in the system. +sources :: IO [Source] +sources = fmap (fmap Source) S.enumerateSources + +-- | Enumerates the MIDI destinations present in the system. +destinations :: IO [Destination] +destinations = fmap (fmap Destination) S.enumerateDestinations + +-- | These functions return the name, model and manufacturer of a MIDI source \/ destination. +-- +-- Note: On Win32, only `getName` returns a somewhat meaningful string at the moment. +getName :: S.MIDIHasName a => a -> IO String +getModel :: S.MIDIHasName a => a -> IO String +getManufacturer :: S.MIDIHasName a => a -> IO String + +getName = S.getName +getModel = S.getModel +getManufacturer = S.getManufacturer + +-- | Opens a MIDI Source. +-- There are two possibilites to receive MIDI messages. The user can either support a callback function, +-- or get the messages from an asynchronous buffer. However, mixing the two approaches is not allowed. + +openSource :: Source -> Maybe (MidiTime -> C.Message -> IO ()) -> IO Stream +openSource s cb = fmap Stream $ S.openSource (getSource s) (fmap mkCb cb) + where + mkCb f (S.MidiEvent ts msg) = f ts (expMsg msg) + + +-- | Opens a MIDI Destination. +openDestination :: Destination -> IO Stream +openDestination = fmap Stream . S.openDestination . getDestination + + +-- | Gets the next event from a buffered connection (see also `openSource`) +getNextEvent :: Stream -> IO (Maybe MidiEvent) +getNextEvent = fmap (fmap g) . S.getNextEvent . getStream + where + g (S.MidiEvent ts msg) = (ts, expMsg msg) + +-- | Gets all the events from the buffer (see also `openSource`) +getEvents :: Stream -> IO [MidiEvent] +getEvents = fmap (fmap g) . S.getEvents . getStream + where + g (S.MidiEvent ts msg) = (ts, expMsg msg) + +-- | Sends a short message. The connection must be a `Destination`. +send :: Stream -> C.Message -> IO () +send c = S.send (getStream c) . impMsg + +{- +-- | Sends a system exclusive message. You shouldn't include the starting \/ trailing bytes 0xF0 and 0xF7. +-- +-- Note: On Win32, the connection must be a `Destination` +sendSysEx :: Stream -> [Word8] -> IO () +sendSysEx = S.sendSysEx +-} + +-- | Starts a connection. This is required for receiving MIDI messages, and also for starting the clock. +start :: Stream -> IO () +start = S.start . getStream + +-- | Stops a connection. +stop :: Stream -> IO () +stop = S.stop . getStream + +-- | Closes a MIDI Stream. +close :: Stream -> IO () +close = S.close . getStream + +-- | Returns the time elapsed since the last `start` call, in milisecs. +currentTime :: Stream -> IO MidiTime +currentTime = S.currentTime . getStream + + + +impMsg :: C.Message -> S.MidiMessage +impMsg (C.NoteOff ch k _) = S.MidiMessage ch (S.NoteOff k) +impMsg (C.NoteOn ch k v) = S.MidiMessage ch (S.NoteOn k v) +impMsg (C.ControlChange ch c v) = S.MidiMessage ch (S.CC c v) +impMsg (C.ProgramChange ch a) = S.MidiMessage ch (S.ProgramChange a) +impMsg (C.PitchWheel ch a) = S.MidiMessage ch (S.PitchWheel a) + +expMsg :: S.MidiMessage -> C.Message +expMsg (S.MidiMessage ch (S.NoteOff k) ) = C.NoteOff ch k 0 +expMsg (S.MidiMessage ch (S.NoteOn k v) ) = C.NoteOn ch k v +expMsg (S.MidiMessage ch (S.CC c v) ) = C.ControlChange ch c v +expMsg (S.MidiMessage ch (S.ProgramChange a) ) = C.ProgramChange ch a +expMsg (S.MidiMessage ch (S.PitchWheel a) ) = C.PitchWheel ch a +-- expMsg (S.MidiMessage ch (S.PolyAftertouch k v) ) = undefined +-- expMsg (S.MidiMessage ch (S.Aftertouch a) ) = undefined +-- expMsg (S.SysEx [Word8] ) = undefined +-- expMsg (S.SongPosition p ) = undefined +-- expMsg (S.SongSelect s ) = undefined +-- expMsg (S.TuneRequest ) = undefined +-- expMsg (S.SRTClock ) = undefined +-- expMsg (S.SRTStart ) = undefined +-- expMsg (S.SRTContinue ) = undefined +-- expMsg (S.SRTStop ) = undefined +-- expMsg (S.ActiveSensing ) = undefined +-- expMsg (S.Reset ) = undefined +-- expMsg (S.Undefined ) = undefined + + + + + + + + + + + + + + diff --git a/src/System/MIDI/Base.hs b/src/System/MIDI/Base.hs new file mode 100644 --- /dev/null +++ b/src/System/MIDI/Base.hs @@ -0,0 +1,138 @@ + +-- |The hardware-independent part of the MIDI binding. + +{-# LANGUAGE CPP #-} +module System.MIDI.Base + ( TimeStamp + , MidiMessage'(..) + , MidiMessage(..) + , MidiEvent(..) + , ClientCallback + , ShortMessage(..) + , translateShortMessage + , untranslateShortMessage + , shortMessage + ) where + +import Data.Bits +import Data.Word + +type TimeStamp = Word32 + +-- |A \"regular\" MIDI message. +-- +-- Remark: `NoteOff` not having a velocity field is a design decision, and a questionable one. According to the +-- MIDI standard, NoteOff also has a velocity. However, most keyboards do not use this feature (send the default +-- value 64), and there are keyboards which do not send NoteOff messages at all, but send NoteOn messages with +-- zero velocity instead (for example the EMU Xboard series). I don't know what would be a good solution. +-- At the moment, the code auto-translates NoteOn messages with zero velocity to NoteOff messages, and the +-- NoteOff velocity is ignored. This behaviour can be inverted with the Cabal flag NoNoteOff. +data MidiMessage' + = NoteOff !Int -- ^ Note Off (key) + | NoteOn !Int !Int -- ^ Note On (key, velocity) + | PolyAftertouch !Int !Int -- ^ Polyphonic key pressure (key, pressure) + | CC !Int !Int -- ^ Control Change (controller, value) + | ProgramChange !Int -- ^ Program Change (program) + | Aftertouch !Int -- ^ Global aftertouch (pressure) + | PitchWheel !Int -- ^ Pitch wheel (value, from -8192..+8191) + deriving (Show,Eq) + +-- |The type representing a MIDI message. +data MidiMessage + = MidiMessage !Int !MidiMessage' -- ^ first argument is the MIDI channel (1..16) + | SysEx [Word8] -- ^ not including the bytes 0xf0, 0xf7 + | SongPosition !Int + | SongSelect !Int + | TuneRequest + | SRTClock + | SRTStart + | SRTContinue + | SRTStop + | ActiveSensing + | Reset + | Undefined + deriving (Show,Eq) + +-- |The type representing a timestamped MIDI message. +-- Time is measured in milisecs elapsed since the last call to `System.MIDI.start`. +data MidiEvent = MidiEvent !TimeStamp !MidiMessage deriving (Show,Eq) + +-- |Type of the user callback function. +type ClientCallback = MidiEvent -> IO () + +translateShortMessage :: ShortMessage -> MidiMessage +translateShortMessage (ShortMessage chn msg bt1 bt2) = + if msg < 15 + then MidiMessage (fromIntegral chn + 1) $ translate' msg k v + else translate'' chn k v + where + k = fromIntegral bt1 + v = fromIntegral bt2 + +translate' msg k v = case msg of +#ifdef HMIDI_NO_NOTEOFF + 8 -> NoteOn k 0 + 9 -> NoteOn k v +#else + 8 -> NoteOff k + 9 -> if v>0 then NoteOn k v else NoteOff k +#endif + 10 -> PolyAftertouch k v + 11 -> CC k v + 12 -> ProgramChange k + 13 -> Aftertouch k + 14 -> PitchWheel (k + shiftL v 7 - 8192) + +translate'' lo a b = case lo of + 0 -> Undefined + 1 -> Undefined + 2 -> SongPosition (a + shiftL b 7) + 3 -> SongSelect a + 4 -> Undefined + 5 -> Undefined + 6 -> TuneRequest + 7 -> Undefined + 8 -> SRTClock + 9 -> Undefined + 10 -> SRTStart + 11 -> SRTContinue + 12 -> SRTStop + 13 -> Undefined + 14 -> ActiveSensing + 15 -> Reset + +untranslateShortMessage :: MidiMessage -> ShortMessage +untranslateShortMessage (MidiMessage chn msg') = + case msg' of + NoteOff k -> shortMessage chn 8 k 64 + NoteOn k v -> shortMessage chn 9 k v + PolyAftertouch k v -> shortMessage chn 10 k v + CC k v -> shortMessage chn 11 k v + ProgramChange k -> shortMessage chn 12 k 0 + Aftertouch k -> shortMessage chn 13 k 0 + PitchWheel n -> let m = min 16383 $ max 0 $ n + 8192 in shortMessage chn 14 (m.&.127) (shiftR m 7) + +untranslateShortMessage (SongPosition p) = shortMessage 15 3 (p.&.7) (shiftR p 7) +untranslateShortMessage (SongSelect s) = shortMessage 15 3 (fromIntegral s) 0 +untranslateShortMessage TuneRequest = shortMessage 15 6 0 0 +untranslateShortMessage SRTClock = shortMessage 15 8 0 0 +untranslateShortMessage SRTStart = shortMessage 15 10 0 0 +untranslateShortMessage SRTContinue = shortMessage 15 11 0 0 +untranslateShortMessage SRTStop = shortMessage 15 12 0 0 +untranslateShortMessage ActiveSensing = shortMessage 15 14 0 0 +untranslateShortMessage Reset = shortMessage 15 15 0 0 +untranslateShortMessage Undefined = error "cannot untranslate Undefined" +untranslateShortMessage (SysEx _) = error "cannot untranslate SysEx" + +shortMessage :: Int -> Int -> Int -> Int -> ShortMessage +shortMessage chn msg bt1 bt2 = + ShortMessage (fromIntegral chn - 1) (fromIntegral msg) (fromIntegral bt1) (fromIntegral bt2) + +-- |Low level stuff. +data ShortMessage = ShortMessage + { sm_channel :: Word8 + , sm_msg :: Word8 + , sm_byte1 :: Word8 + , sm_byte2 :: Word8 + } deriving Show + diff --git a/src/System/MIDI/MacOSX.hs b/src/System/MIDI/MacOSX.hs new file mode 100644 --- /dev/null +++ b/src/System/MIDI/MacOSX.hs @@ -0,0 +1,236 @@ + +-- |A lowest common denominator interface to the Win32 and MacOSX MIDI bindings, MacOSX part. + +module System.MIDI.MacOSX + ( module System.MIDI.Base + + , Source + , Destination + , Connection + + , enumerateSources + , enumerateDestinations + + , MIDIHasName(..) + + , openSource + , openDestination + , close + , send + , sendSysEx + , start + , stop + + , getNextEvent + , getEvents + , currentTime + + ) where + +import System.MIDI.Base + +import Control.Monad +import Control.Concurrent.MVar +import Control.Concurrent.Chan +import Data.List +import Foreign hiding (unsafePerformIO) +import Foreign.StablePtr +import System.IO.Unsafe + +import System.MacOSX.CoreFoundation +import System.MacOSX.CoreAudio +import System.MacOSX.CoreMIDI + +-- |Gets all the events from the buffer. +getEvents :: Connection -> IO [MidiEvent] +getEvents conn = do + m <- getNextEvent conn + case m of + Nothing -> return [] + Just ev -> do + evs <- getEvents conn + return (ev:evs) + +-- |Gets the next event from a buffered connection. +getNextEvent :: Connection -> IO (Maybe MidiEvent) +getNextEvent conn = case cn_fifo_cb conn of + Right _ -> fail "this is not a buffered connection" + Left chan -> do + b <- isEmptyChan chan + if b + then return Nothing + else do + x <- readChan chan + return (Just x) + +type Client = MIDIClientRef +type Device = MIDIDeviceRef +type Port = MIDIPortRef + +-- |The opaque data type representing a MIDI connection +data Connection = Connection + { cn_isInput :: Bool + , cn_port :: MIDIPortRef + , cn_endpoint :: MIDIEndpointRef + , cn_time :: MVar UInt64 -- measured in nanosecs + , cn_alive :: MVar Bool + , cn_fifo_cb :: Either (Chan MidiEvent) ClientCallback + , cn_midiproc :: FunPtr (MIDIReadProc () ()) + , cn_mydata :: StablePtr (MVar Connection) + } + +----- automatic client creation + +client = unsafePerformIO $ newEmptyMVar :: MVar Client + +{- +#ifdef __GLASGOW_HASKELL__ +clientFinalizer :: IO () +clientFinalizer = do + c <- readMVar client + disposeClient c +#endif +-} + +getClient :: IO MIDIClientRef +getClient = do + b <- isEmptyMVar client + if b + then do + x <- newClient "HaskellMidi" + putMVar client x +{- +#ifdef __GLASGOW_HASKELL__ + addMVarFinalizer client clientFinalizer -- uh-oh, that's not a good idea (not in the present form) +#endif +-} + return x + else readMVar client + +-- |Returns the time elapsed since the last `start` call, in milisecs. +currentTime :: Connection -> IO Word32 +currentTime conn = do + t <- audioGetCurrentTimeInNanos + t0 <- readMVar (cn_time conn) + return (nanoToMili $ t-t0) + +nanoToMili :: UInt64 -> Word32 +nanoToMili n = fromIntegral $ div n 1000000 + +convertShortMessage :: UInt64 -> (MIDITimeStamp,[Word8]) -> IO MidiEvent +convertShortMessage t0 (ts',bytes) = do + ts <- audioConvertHostTimeToNanos ts' + return $ MidiEvent (nanoToMili $ ts-t0) (translateShortMessage $ decodeShortMessage bytes) + +myMIDIReadProc :: Ptr MIDIPacket -> Ptr () -> Ptr () -> IO () +myMIDIReadProc packets myptr _ = do + let stabptr = castPtrToStablePtr myptr :: StablePtr (MVar Connection) + mv <- deRefStablePtr stabptr :: IO (MVar Connection) + mconn <- tryTakeMVar mv -- we are also "blocking" (handling) further callbacks this way + case mconn of + Nothing -> return () + Just conn -> do + time0 <- readMVar (cn_time conn) + list1 <- depackMIDIPacketList packets + let (normal,sysex') = partition (\(_,bytes) -> isShortMessage bytes) list1 + sysexs <- forM sysex' $ \(ts',bytes) -> do + ts <- audioConvertHostTimeToNanos ts' + return $ MidiEvent (nanoToMili $ ts-time0) (SysEx $ tail bytes) + normals <- mapM (convertShortMessage time0) normal + let events = sysexs ++ normals + case (cn_fifo_cb conn) of + Left chan -> writeList2Chan chan events + Right call -> mapM_ call events + putMVar mv conn -- do not forget to put it back! + +-- |Opens a MIDI Source. +-- There are two possibilites to receive MIDI messages. The user can either support a callback function, +-- or get the messages from an asynchronous buffer. However, mixing the two approaches is not allowed. +openSource :: Source -> Maybe ClientCallback -> IO Connection +openSource src@(Source endpoint) mcallback = do + + client <- getClient + + myData <- newEmptyMVar :: IO (MVar Connection) + sp <- newStablePtr myData + the_callback <- mkMIDIReadProc myMIDIReadProc + + time <- newEmptyMVar + alive <- newMVar True + + fifo_cb <- case mcallback of + Just cb -> return $ Right cb + Nothing -> liftM Left $ newChan + + inport <- newInputPort client "Input Port" the_callback (castStablePtrToPtr sp) + + let conn = Connection True inport endpoint time alive fifo_cb the_callback sp + putMVar myData conn + return conn + +-- |Opens a MIDI Destination. +openDestination :: Destination -> IO Connection +openDestination dst@(Destination endpoint) = do + + client <- getClient + outport <- newOutputPort client "Output Port" + alive <- newMVar True + time <- newEmptyMVar + + let conn = Connection False outport endpoint time alive undefined undefined undefined + return conn + +sendShortMessage :: Connection -> ShortMessage -> IO () +sendShortMessage conn msg = case cn_isInput conn of + True -> fail "sending short messages to midi sources is not supported" + False -> midiSend (cn_port conn) (Destination $ cn_endpoint conn) msg + +-- |Sends a short message. The connection must be a `Destination`. +send :: Connection -> MidiMessage -> IO () +send conn msg = sendShortMessage conn (untranslateShortMessage msg) + +-- |Sends a system exclusive message. You shouldn't include the starting \/ trailing bytes 0xF0 and 0xF7. +sendSysEx :: Connection -> [Word8] -> IO () +sendSysEx conn dat = midiSendSysEx (cn_endpoint conn) dat + +-- |Starts a connection. This is required for receiving MIDI messages, and also for starting the clock. +start :: Connection -> IO () +start conn = do + b <- isEmptyMVar (cn_time conn) + if b + then do + hosttime <- audioGetCurrentTimeInNanos + putMVar (cn_time conn) hosttime + case cn_isInput conn of + True -> connectToSource (cn_port conn) (Source $ cn_endpoint conn) nullPtr + False -> return () + else putStrLn "warning: you shouldn't call start twice" + +-- |Stops a connection. +stop :: Connection -> IO () +stop conn = do + b <- isEmptyMVar (cn_time conn) + if not b + then do + takeMVar (cn_time conn) + case cn_isInput conn of + True -> disconnectFromSource (cn_port conn) (Source $ cn_endpoint conn) + False -> return () + else putStrLn "warning: you shouldn't call stop twice" + +-- |Closes a MIDI Connection +close conn = do + when (cn_isInput conn) $ do + b <- isEmptyMVar (cn_time conn) + when (not b) (stop conn) + disposePort (cn_port conn) + cleanup conn + +-- called by "close"; not exposed. +cleanup :: Connection -> IO () +cleanup conn = case (cn_isInput conn) of + True -> do + freeHaskellFunPtr (cn_midiproc conn) + freeStablePtr (cn_mydata conn) + False -> return () + diff --git a/src/System/MIDI/Placeholder.hs b/src/System/MIDI/Placeholder.hs new file mode 100644 --- /dev/null +++ b/src/System/MIDI/Placeholder.hs @@ -0,0 +1,111 @@ + +-- | This is just to be able to produce a Haddock documentation on a Linux system + +module System.MIDI.Placeholder + ( module System.MIDI.Base + + , Source + , Destination + , Connection + + , enumerateSources + , enumerateDestinations + + , MIDIHasName + , getName + , getModel + , getManufacturer + + , openSource + , openDestination + , close + , send + , sendSysEx + , start + , stop + + , getNextEvent + , getEvents + , currentTime + + ) where + +import Data.Word +import System.MIDI.Base + +-- | The opaque data type representing a MIDI source. +data Source + +-- | The opaque data type representing a MIDI destination. +data Destination + +-- | The opaque data type representing a MIDI connection. +data Connection + +-- Placeholder +class MIDIHasName c where + +-- | Enumerates the MIDI sources present in the system. +enumerateSources :: IO [Source] +enumerateSources = undefined + +-- | Enumerates the MIDI destinations present in the system. +enumerateDestinations :: IO [Destination] +enumerateDestinations = undefined + +-- | 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 +getModel :: MIDIHasName a => a -> IO String +getManufacturer :: MIDIHasName a => a -> IO String + +getName = undefined +getModel = undefined +getManufacturer = undefined + +-- | +-- Opens a MIDI Source. +-- There are two possibilites to receive MIDI messages. The user can either support a callback function, +-- or get the messages from an asynchronous buffer. However, mixing the two approaches is not allowed. +openSource :: Source -> Maybe ClientCallback -> IO Connection +openSource = undefined + +-- | Opens a MIDI Destination. +openDestination :: Destination -> IO Connection +openDestination = undefined + +-- | Gets the next event from a buffered connection (see also `openSource`) +getNextEvent :: Connection -> IO (Maybe MidiEvent) +getNextEvent = undefined + +-- | Gets all the events from the buffer (see also `openSource`) +getEvents :: Connection -> IO [MidiEvent] +getEvents = undefined + +-- | Sends a short message. The connection must be a `Destination`. +send :: Connection -> MidiMessage -> IO () +send = undefined + +-- | 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 + +-- | Starts a connection. This is required for receiving MIDI messages, and also for starting the clock. +start :: Connection -> IO () +start = undefined + +-- | Stops a connection. +stop :: Connection -> IO () +stop = undefined + +-- | Closes a MIDI Connection. +close :: Connection -> IO () +close = undefined + +-- | Returns the time elapsed since the last `start` call, in milisecs. +currentTime :: Connection -> IO Word32 +currentTime = undefined + diff --git a/src/System/MIDI/Win32.hs b/src/System/MIDI/Win32.hs new file mode 100644 --- /dev/null +++ b/src/System/MIDI/Win32.hs @@ -0,0 +1,275 @@ + +-- |A lowest common denominator interface to the Win32 and MacOSX MIDI bindings, Win32 part. + +module System.MIDI.Win32 + ( module System.MIDI.Base + + , Source + , Destination + , Connection + + , enumerateSources + , enumerateDestinations + + , MIDIHasName + , getName + , getModel + , getManufacturer + + , openSource + , openDestination + , close + , send + , sendSysEx + , start + , stop + + , getNextEvent + , getEvents + , currentTime + ) where + +import Control.Monad +import Control.Concurrent.MVar +import Control.Concurrent.Chan +import Data.List +import Foreign +import Foreign.StablePtr +import System.IO.Unsafe + +import System.Win32.Types +import System.Win32.MIDI + +import System.MIDI.Base + +-- |Gets all the events from the buffer. +getEvents :: Connection -> IO [MidiEvent] +getEvents conn = do + m <- getNextEvent conn + case m of + Nothing -> return [] + Just ev -> do + evs <- getEvents conn + return (ev:evs) + +-- |Gets the next event from a buffered connection. +getNextEvent :: Connection -> IO (Maybe MidiEvent) +getNextEvent conn = case cn_fifo_cb conn of + Right _ -> fail "this is not a buffered connection" + Left chan -> do + b <- isEmptyChan chan + if b + then return Nothing + else do + x <- readChan chan + return (Just x) + +waitFor :: IO Bool -> IO () +waitFor check = do + b <- check + unless b $ waitFor check + +-- |The opaque data type representing a MIDI connection. +data Connection = Connection + { cn_isInput :: Bool + , cn_handle :: HMIDI + , cn_time :: MVar Word32 -- measured in milisecs + , cn_fifo_cb :: Either (Chan MidiEvent) ClientCallback + , cn_midiproc :: FunPtr (MIDIINPROC ()) + , cn_mydata :: StablePtr (MVar Connection) + , cn_inbuf :: MVar (Ptr MIDIHDR) + , cn_sysex :: Chan Word8 -- channel for temporarily storing sysex messages (they can be arbritrary long, but the buffer has fixed size) + , cn_alive :: MVar Bool + } + +-- |Returns the time elapsed since the last `start` call, in milisecs. +currentTime :: Connection -> IO Word32 +currentTime conn = do + t <- timeGetTime + t0 <- readMVar (cn_time conn) + return (t-t0) + +myMidiCallback :: HMIDIIN -> UINT -> Ptr () -> DWORD -> DWORD -> IO () +myMidiCallback hmidi msg' myptr param1 param2 = do + let stabptr = castPtrToStablePtr myptr :: StablePtr (MVar Connection) + mv <- deRefStablePtr stabptr :: IO (MVar Connection) + mconn <- tryTakeMVar mv -- we are also "blocking" (handling) further callbacks this way + case mconn of + Nothing -> return () + Just conn -> do + let msg = mim msg' + case msg of + + MIM_DATA -> do + let tmsg = translateShortMessage $ decodeShortMessage param1 + let event = MidiEvent param2 tmsg + case (cn_fifo_cb conn) of + Left chan -> writeChan chan event + Right call -> call event + + MIM_LONGDATA -> do + let ptr = wordPtrToPtr (fromIntegral param1) :: Ptr MIDIHDR + q <- peek (castPtr ptr ) :: IO (Ptr Word8) + n <- peek (castPtr ptr `plusPtr` 8) :: IO DWORD + dat <- peekArray (fromIntegral n) q + + sysexs <- processSysEx (cn_sysex conn) dat + forM_ sysexs $ \dat -> do + let event = MidiEvent param2 (SysEx dat) + case (cn_fifo_cb conn) of + Left chan -> writeChan chan event + Right call -> call event + + -- reportedly we are not supposed to call midiInAddBuffer and the like from here, + -- but well, this is the simplest solution and it seems to work pretty well... + -- (may not work on ancient versions of Windows) + b <- isEmptyMVar (cn_time conn) -- not really elegant hack, but the emptyness of this is also used for syncing purposes + unless b $ do -- this is here because midiInReset can block if we want to free them before it returned... + freeMidiInHeader hmidi ptr + new <- midiInAddBuffer hmidi midiInBufferSize + swapMVar (cn_inbuf conn) new + return () + + MIM_CLOSE -> do + swapMVar (cn_alive conn) False + return () + + _ -> return () + + when (msg /= MIM_CLOSE) $ putMVar mv conn -- do not forget !!! + +-- I'm not sure, but getChanContents seems to be too lazy for our purposes +readChanList :: Chan a -> IO [a] +readChanList chan = do + b <- isEmptyChan chan + if b + then return [] + else do + x <- readChan chan + xs <- readChanList chan + return (x:xs) + +-- the Win32 SysEx support is somewhat brain-dead... +processSysEx :: Chan Word8 -> [Word8] -> IO [[Word8]] +processSysEx _ [] = return [] +processSysEx chan dat = do + case (findIndex (==0xf7) dat) of + Nothing -> do + writeList2Chan chan dat + return [] + Just k -> do + xs <- readChanList chan + let (aa,bb) = splitAt k dat + ys = xs ++ aa + ev = if (head ys == 0xf0) then tail ys else ys + evs <- processSysEx chan (tail bb) + return (ev:evs) + +midiInBufferSize = 64 + +-- |Opens a MIDI source. +-- There are two possibilites to receive MIDI messages. The user can either support a callback function, +-- or get the messages from an asynchronous buffer. However, mixing the two approaches is not allowed. +openSource :: Source -> Maybe ClientCallback -> IO Connection +openSource src mcallback = do + myData <- newEmptyMVar :: IO (MVar Connection) + sp <- newStablePtr myData + the_callback <- mkMIDIPROC myMidiCallback + alive <- newMVar True + fifo_cb <- case mcallback of + Just cb -> return $ Right cb + Nothing -> liftM Left $ newChan + time <- newEmptyMVar + handle <- midiInOpen src the_callback (castStablePtrToPtr sp) (CALLBACK_FUNCTION False) + bufmv <- newEmptyMVar + sysex <- newChan -- channel for temporarily storing sysex messages (they can be arbritrary long, but the buffer has fixed size) + let conn = Connection True handle time fifo_cb the_callback sp bufmv sysex alive + putMVar myData conn + return conn + +-- |Opens a MIDI destination. +openDestination :: Destination -> IO Connection +openDestination dst = do + alive <- newMVar True + handle <- midiOutOpen dst nullFunPtr nullPtr CALLBACK_NULL + time <- newEmptyMVar + let conn = Connection False handle time undefined undefined undefined undefined undefined alive + return conn + +sendShortMessage :: Connection -> ShortMessage -> IO () +sendShortMessage conn msg = case (cn_isInput conn) of + True -> fail "sending short messages to midi sources is not supported" + False -> midiOutSend (cn_handle conn) msg + +-- |Sends a short message. The connection must be a `Destination`. +send :: Connection -> MidiMessage -> IO () +send conn msg = sendShortMessage conn (untranslateShortMessage msg) + +-- |Sends a System Exclusive message. You shouldn't include the starting/trailing bytes 0xf0 and 0xf7 in the data. +sendSysEx :: Connection -> [Word8] -> IO () +sendSysEx conn msg = do + let handle = cn_handle conn + case cn_isInput conn of + True -> fail "sending SysEx messages to midi sources is not supported under Win32" + False -> midiOutSendSysEx handle msg + +-- |Starts a connection. This is required for receiving MIDI messages, and also for starting the clock. +start :: Connection -> IO () +start conn = do + let handle = cn_handle conn + b <- isEmptyMVar (cn_time conn) + if b + then do + time <- timeGetTime + putMVar (cn_time conn) time + case cn_isInput conn of + True -> do + buf <- midiInAddBuffer handle midiInBufferSize + putMVar (cn_inbuf conn) buf + midiInStart handle + False -> return () + else putStrLn "warning: you shouldn't call start twice" + +-- |Starts a connection. This is required for receiving MIDI messages, and also for starting the clock. +stop :: Connection -> IO () +stop conn = do + let handle = cn_handle conn + b <- isEmptyMVar (cn_time conn) + if not b + then do + takeMVar (cn_time conn) -- also used for syncing! + case cn_isInput conn of + True -> do + midiInReset handle + hdr <- takeMVar (cn_inbuf conn) + freeMidiInHeader handle hdr + midiInStop handle + False -> return () + return () + else putStrLn "warning: you shouldn't call stop twice" + +-- |Resets a `Connection`. +reset :: Connection -> IO () +reset conn = do + let handle = cn_handle conn + case cn_isInput conn of + True -> midiInReset handle + False -> midiOutReset handle + +-- |Closes a `Connection` +close :: Connection -> IO () +close conn = do + let handle = cn_handle conn + case cn_isInput conn of + True -> midiInClose handle + False -> midiOutClose handle + +-- called by "close" +cleanup :: Connection -> IO () +cleanup conn = case (cn_isInput conn) of + True -> do + waitFor (liftM not $ readMVar $ cn_alive conn) + freeHaskellFunPtr (cn_midiproc conn) + freeStablePtr (cn_mydata conn) + False -> return () + diff --git a/src/System/MacOSX/CoreAudio.hs b/src/System/MacOSX/CoreAudio.hs new file mode 100644 --- /dev/null +++ b/src/System/MacOSX/CoreAudio.hs @@ -0,0 +1,28 @@ + +-- |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. + +{-# LANGUAGE ForeignFunctionInterface #-} +module System.MacOSX.CoreAudio + ( audioGetCurrentHostTime + , audioConvertHostTimeToNanos + , audioConvertNanosToHostTime + , audioGetCurrentTimeInNanos + ) + where + +import System.MacOSX.CoreFoundation + +foreign import ccall unsafe "HostTime.h AudioGetCurrentHostTime" + audioGetCurrentHostTime :: IO UInt64 + +foreign import ccall unsafe "HostTime.h AudioConvertHostTimeToNanos" + audioConvertHostTimeToNanos :: UInt64 -> IO UInt64 + +foreign import ccall unsafe "HostTime.h AudioConvertNanosToHostTime" + audioConvertNanosToHostTime :: UInt64 -> IO UInt64 + +audioGetCurrentTimeInNanos :: IO UInt64 +audioGetCurrentTimeInNanos = ( audioGetCurrentHostTime >>= audioConvertHostTimeToNanos ) + diff --git a/src/System/MacOSX/CoreFoundation.hs b/src/System/MacOSX/CoreFoundation.hs new file mode 100644 --- /dev/null +++ b/src/System/MacOSX/CoreFoundation.hs @@ -0,0 +1,125 @@ + +-- |Partial binding to CoreFoundation, as required for `System.MIDI`. +-- 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 + , UInt16 + , UInt32 + , UInt64 + , SInt8 + , SInt16 + , SInt32 + , SInt64 + , OSErr + , OSStatus + , UniChar + , CFIndex + , ItemCount + , ByteCount + , CFDataRef + , CFStringRef + , CFAllocatorRef + ) where + +import Data.Bits +import Data.Word +import Data.Int + +import Control.Monad + +import Foreign +import Foreign.C +import Foreign.Marshal + +type UInt8 = Word8 +type UInt16 = Word16 +type UInt32 = Word32 +type UInt64 = Word64 + +type SInt8 = Int8 +type SInt16 = Int16 +type SInt32 = Int32 +type SInt64 = Int64 + +type OSErr = SInt16 +type OSStatus = SInt32 + +type UniChar = Char +type CFIndex = SInt32 +type ItemCount = UInt32 +type ByteCount = UInt32 + +data CFData +data CFString +data CFAllocator + +type CFDataRef = Ptr CFData +type CFStringRef = Ptr CFString +type CFAllocatorRef = Ptr CFAllocator + +kCFAllocatorDefault = nullPtr + +----- error "handling" :) ----- + +osStatusString :: OSStatus -> String +osStatusString osstatus = "OSStatus = " ++ show osstatus + +osStatusError :: OSStatus -> IO a +osStatusError osstatus = fail $ osStatusString osstatus + +----- Base ----- + +foreign import ccall unsafe "CFBase.h CFRelease" + c_CFRelease :: Ptr a -> IO () + +----- CFStrings ----- + +foreign import ccall unsafe "CFString.h CFStringGetLength" + c_CFStringGetLength :: CFStringRef -> IO CFIndex + +foreign import ccall unsafe "CFString.h CFStringGetCharactersPtr" + c_CFStringGetCharactersPtr :: CFStringRef -> IO (Ptr UniChar) + +foreign import ccall unsafe "CFString.h CFStringGetCharacterAtIndex" + c_CFStringGetCharacterAtIndex :: CFStringRef -> CFIndex -> IO UniChar + +foreign import ccall unsafe "CFString.h CFStringCreateWithCharacters" + c_CFStringCreateWithCharacters :: CFAllocatorRef -> Ptr UniChar -> CFIndex -> IO CFStringRef + +-- | Manually releasing a CFString. +releaseCFString :: CFStringRef -> IO () +releaseCFString = c_CFRelease + +-- | Peeks a CFString. +peekCFString :: CFStringRef -> IO String +peekCFString cfstring = do + n <- c_CFStringGetLength cfstring + p <- c_CFStringGetCharactersPtr cfstring + if p /= nullPtr + then forM [0..n-1] $ \i -> peekElemOff p (fromIntegral i) + else forM [0..n-1] $ \i -> 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) + +-- | Safe passing of a CFString to the OS (releases it afterwards). +withCFString :: String -> (CFStringRef -> IO a) -> IO a +withCFString string action = do + cfstring <- newCFString string + x <- action cfstring + releaseCFString cfstring + return x diff --git a/src/System/MacOSX/CoreMIDI.hs b/src/System/MacOSX/CoreMIDI.hs new file mode 100644 --- /dev/null +++ b/src/System/MacOSX/CoreMIDI.hs @@ -0,0 +1,573 @@ + +-- |Low-level binding to the CoreMIDI services present in Mac OS X. +-- Error handling is via `fail`-s in the IO monad. + +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +module System.MacOSX.CoreMIDI + ( + enumerateDevices + , enumerateSources + , enumerateDestinations + , MIDIHasName(..) + -- , getName + -- , getModel + -- , getManufacturer + , newSource + , newDestination + , disposeEndpoint + , newClient + , disposeClient + , newInputPort + , newOutputPort + , disposePort + , connectToSource + , disconnectFromSource + , midiSend + , midiSend' + , midiSendList + , midiSendList' + , midiSendSysEx + + -- types + , OpaqueMIDIClient + , OpaqueMIDIObject + , OpaqueMIDIDevice + , OpaqueMIDIEntity + , OpaqueMIDIEndpoint + , OpaqueMIDIPort + + , MIDIClientRef + , MIDIObjectRef + , MIDIDeviceRef + , MIDIEntityRef + , MIDIEndpointRef + , MIDIPortRef + + , MIDITimeStamp + , MIDIReadProc + , mkMIDIReadProc + , MIDIPacket + , Source(..) + , Destination(..) + + -- helper functions to write callbacks + , depackMIDIPacketList + , depackSingleMIDIPacket + , decodeShortMessage + , isShortMessage + ) where + +import Control.Monad +import Control.Concurrent.MVar +import Foreign hiding (unsafePerformIO) +import Foreign.Marshal +import System.IO.Unsafe + +import System.MIDI.Base +import System.MacOSX.CoreFoundation + +data OpaqueMIDIClient +data OpaqueMIDIObject +data OpaqueMIDIDevice +data OpaqueMIDIEntity +data OpaqueMIDIEndpoint +data OpaqueMIDIPort + +type MIDIClientRef = Ptr OpaqueMIDIClient +type MIDIObjectRef = Ptr OpaqueMIDIObject +type MIDIDeviceRef = Ptr OpaqueMIDIDevice +type MIDIEntityRef = Ptr OpaqueMIDIEntity +type MIDIEndpointRef = Ptr OpaqueMIDIEndpoint +type MIDIPortRef = Ptr OpaqueMIDIPort + +type MIDIUniqueID = SInt32 +type MIDIObjectType = SInt32 + +type MIDITimeStamp = UInt64 + +data MIDINotification +type MIDINotifyProc a = Ptr MIDINotification -> Ptr a -> IO () + +data MIDIPacket +data MIDISysexSendRequest + +-- | 'r' is readProcRefCon (The refCon you passed to MIDIInputPortCreate or MIDIDestinationCreate); +-- 's' is srcConnRefCon (A refCon you passed to MIDIPortConnectSource, which identifies the source of the data). +type MIDIReadProc r s = Ptr MIDIPacket -> Ptr r -> Ptr s -> IO () + +foreign import ccall safe "wrapper" + mkMIDIReadProc :: MIDIReadProc () () -> IO (FunPtr (MIDIReadProc () ())) + +----- Properties ----- + +foreign import ccall "&kMIDIPropertyName" ptr_kMIDIPropertyName :: Ptr CFStringRef +foreign import ccall "&kMIDIPropertyManufacturer" ptr_kMIDIPropertyManufacturer :: Ptr CFStringRef +foreign import ccall "&kMIDIPropertyModel" ptr_kMIDIPropertyModel :: Ptr CFStringRef + +kMIDIPropertyName = unsafePerformIO $ peek ptr_kMIDIPropertyName +kMIDIPropertyManufacturer = unsafePerformIO $ peek ptr_kMIDIPropertyManufacturer +kMIDIPropertyModel = unsafePerformIO $ peek ptr_kMIDIPropertyModel + +----- Send + +foreign import ccall unsafe "MIDIServices.h MIDISend" + c_MIDISend :: MIDIPortRef -> MIDIEndpointRef -> Ptr MIDIPacket -> IO OSStatus + +foreign import ccall unsafe "MIDIServices.h MIDISendSysex" + c_MIDISendSysex :: Ptr MIDISysexSendRequest -> IO OSStatus + +----- Clients + +foreign import ccall unsafe "MIDIServices.h MIDIClientCreate" + c_MIDIClientCreate :: CFStringRef -> FunPtr (MIDINotifyProc a) -> Ptr a -> Ptr MIDIClientRef -> IO OSStatus + +foreign import ccall unsafe "MIDIServices.h MIDIClientDispose" + c_MIDIClientDispose :: MIDIClientRef -> IO OSStatus + +----- Devices + +foreign import ccall unsafe "MIDIServices.h MIDIGetNumberOfDevices" + c_MIDIGetNumberOfDevices :: IO ItemCount + +foreign import ccall unsafe "MIDIServices.h MIDIGetDevice" + c_MIDIGetDevice :: ItemCount -> IO MIDIDeviceRef + +----- Endpoints + +foreign import ccall unsafe "MIDIServices.h MIDIGetNumberOfSources" + c_MIDIGetNumberOfSources :: IO ItemCount + +foreign import ccall unsafe "MIDIServices.h MIDIGetNumberOfDestinations" + c_MIDIGetNumberOfDestinations :: IO ItemCount + + +foreign import ccall unsafe "MIDIServices.h MIDIGetSource" + c_MIDIGetSource :: ItemCount -> IO MIDIEndpointRef + +foreign import ccall unsafe "MIDIServices.h MIDIGetDestination" + c_MIDIGetDestination :: ItemCount -> IO MIDIEndpointRef + + +foreign import ccall unsafe "MIDIServices.h MIDISourceCreate" + c_MIDISourceCreate :: MIDIClientRef -> CFStringRef -> Ptr MIDIEndpointRef -> IO OSStatus + +foreign import ccall unsafe "MIDIServices.h MIDIDestinationCreate" + c_MIDIDestinationCreate :: MIDIClientRef -> CFStringRef -> Ptr MIDIEndpointRef -> IO OSStatus + +foreign import ccall unsafe "MIDIServices.h MIDIEndpointDispose" + c_MIDIEndpointDispose :: MIDIEndpointRef -> IO OSStatus + + +foreign import ccall unsafe "MIDIServices.h MIDIEndpointGetEntity" + c_MIDIEndpointGetEntity :: MIDIEndpointRef -> Ptr MIDIEntityRef -> IO OSStatus + +------ Ports + +foreign import ccall safe "MIDIServices.h MIDIInputPortCreate" + c_MIDIInputPortCreate :: MIDIClientRef -> CFStringRef -> FunPtr (MIDIReadProc r s) -> Ptr r + -> Ptr MIDIPortRef -> IO OSStatus + +foreign import ccall safe "MIDIServices.h MIDIOutputPortCreate" + c_MIDIOutputPortCreate :: MIDIClientRef -> CFStringRef -> Ptr MIDIPortRef -> IO OSStatus + +foreign import ccall unsafe "MIDIServices.h MIDIPortDispose" + c_MIDIPortDispose :: MIDIPortRef -> IO OSStatus + +foreign import ccall safe "MIDIServices.h MIDIPortConnectSource" + c_MIDIPortConnectSource :: MIDIPortRef -> MIDIEndpointRef -> Ptr a -> IO OSStatus + +foreign import ccall safe "MIDIServices.h MIDIPortDisconnectSource" + c_MIDIPortDisconnectSource :: MIDIPortRef -> MIDIEndpointRef -> IO OSStatus + +------ Objects + +foreign import ccall unsafe "MIDIServices.h MIDIObjectFindByUniqueID" + c_MIDIObjectFindByUniqueID :: MIDIUniqueID -> Ptr MIDIObjectRef -> Ptr MIDIObjectType -> IO OSStatus + + +foreign import ccall unsafe "MIDIServices.h MIDIObjectGetDataProperty" + c_MIDIObjectGetDataProperty :: MIDIObjectRef -> CFStringRef -> Ptr CFDataRef -> IO OSStatus + +foreign import ccall unsafe "MIDIServices.h MIDIObjectGetIntegerProperty" + c_MIDIObjectGetIntegerProperty :: MIDIObjectRef -> CFStringRef -> Ptr SInt32 -> IO OSStatus + +foreign import ccall unsafe "MIDIServices.h MIDIObjectGetStringProperty" + c_MIDIObjectGetStringProperty :: MIDIObjectRef -> CFStringRef -> Ptr CFStringRef -> IO OSStatus + + +foreign import ccall unsafe "MIDIServices.h MIDIObjectSetDataProperty" + c_MIDIObjectSetDataProperty :: MIDIObjectRef -> CFStringRef -> CFDataRef -> IO OSStatus + +foreign import ccall unsafe "MIDIServices.h MIDIObjectSetIntegerProperty" + c_MIDIObjectSetIntegerProperty :: MIDIObjectRef -> CFStringRef -> SInt32 -> IO OSStatus + +foreign import ccall unsafe "MIDIServices.h MIDIObjectSetStringProperty" + c_MIDIObjectSetStringProperty :: MIDIObjectRef -> CFStringRef -> CFStringRef -> IO OSStatus + + +midiObjectGetStringProperty :: MIDIObjectRef -> CFStringRef -> IO String +midiObjectGetStringProperty object propertyid = + alloca $ \ptr_cfstringref -> do + osstatus <- c_MIDIObjectGetStringProperty object propertyid ptr_cfstringref + if osstatus /= 0 + then osStatusError osstatus + else do + cfstringref <- peek ptr_cfstringref + string <- peekCFString cfstringref + releaseCFString cfstringref + return string + +midiObjectGetIntegerProperty :: MIDIObjectRef -> CFStringRef -> IO SInt32 +midiObjectGetIntegerProperty object propertyid = + alloca $ \ptr_sint32 -> do + osstatus <- c_MIDIObjectGetIntegerProperty object propertyid ptr_sint32 + if osstatus /= 0 + then osStatusError osstatus + else do + sint32 <- peek ptr_sint32 + return sint32 + + +---------- exported Haskell functions ---------- + +newtype Source = Source MIDIEndpointRef deriving (Eq,Show) +newtype Destination = Destination MIDIEndpointRef deriving (Eq,Show) + +class Endpoint a where endpoint :: a -> MIDIEndpointRef + +instance Endpoint Source where endpoint (Source src) = src +instance Endpoint Destination where endpoint (Destination src) = src +instance Endpoint MIDIEndpointRef where endpoint = id + +class MIDIObject a where midiObject :: a -> MIDIObjectRef + +instance MIDIObject MIDIClientRef where midiObject = castPtr +instance MIDIObject MIDIDeviceRef where midiObject = castPtr +instance MIDIObject MIDIPortRef where midiObject = castPtr +instance MIDIObject MIDIEndpointRef where midiObject = castPtr +instance MIDIObject MIDIEntityRef where midiObject = castPtr + +instance MIDIObject Source where midiObject (Source src) = castPtr src +instance MIDIObject Destination where midiObject (Destination dst) = castPtr dst + +-- |MIDI objects which can have a name, model name and manufacturer +class MIDIObject a => MIDIHasName a where + getName :: a -> IO String + getModel :: a -> IO String + getManufacturer :: a -> IO String + + getName = genericGetName . midiObject + getModel = genericGetModel . midiObject + getManufacturer = genericGetManufacturer . midiObject + +instance MIDIHasName MIDIDeviceRef +instance MIDIHasName MIDIEntityRef +instance MIDIHasName MIDIPortRef +instance MIDIHasName MIDIEndpointRef +instance MIDIHasName Source +instance MIDIHasName Destination + +genericGetName obj = midiObjectGetStringProperty obj kMIDIPropertyName +genericGetModel obj = midiObjectGetStringProperty obj kMIDIPropertyModel +genericGetManufacturer obj = midiObjectGetStringProperty obj kMIDIPropertyManufacturer + +data Notification = Notification NotificationMessageID (Maybe [Word8]) + +data NotificationMessageID + = SetupChanged + | ObjectAdded + | ObjectRemoved + | PropertyChanged + | ThruConnectionsChanged + | SerialPortOwnerChanged + | MIDIMsgIOError + +----- encode / decode + +encodeShortMessageList :: [ShortMessage] -> [Word8] +encodeShortMessageList list = concatMap encodeShortMessage list + +encodeShortMessage :: ShortMessage -> [Word8] +encodeShortMessage (ShortMessage chn' msg' bt1 bt2) = + case msg of + 8 -> [cmd,bt1,bt2] -- ?! + 9 -> [cmd,bt1,bt2] + 10 -> [cmd,bt1,bt2] + 11 -> [cmd,bt1,bt2] + 12 -> [cmd,bt1] + 13 -> [cmd,bt1] + 14 -> [cmd,bt1,bt2] + 15 -> case chn of + 2 -> [cmd,bt1,bt2] + 3 -> [cmd,bt1] + 0 -> error "SysEx is not a short message!" + _ -> [cmd] + where + chn = 15 .&. chn' + msg = 15 .&. msg' + cmd = chn + shiftL msg 4 + +isShortMessage :: [Word8] -> Bool +isShortMessage msg = (head msg /= 0xf0) + +decodeShortMessage :: [Word8] -> ShortMessage +decodeShortMessage bytes = ShortMessage chn msg bt1 bt2 where + cmd = head bytes + chn = cmd .&. 15 + msg = shiftR cmd 4 + (bt1,bt2) = case tail bytes of + [] -> (0,0) + [a] -> (a,0) + [a,b] -> (a,b) + _ -> error "a short message shouldn't be longer than 3 bytes!" + +depackMIDIPacketList :: Ptr MIDIPacket -> IO [ (MIDITimeStamp, [Word8]) ] +depackMIDIPacketList p = + do + npackets <- peek (castPtr p) :: IO UInt32 + depack' (p `plusPtr` 4) npackets + where + depack' _ 0 = return [] + depack' p k = do + ( n , ts , msgs ) <- depackSingleMIDIPacket p + let xs = zip (repeat ts) msgs + ys <- depack' (p `plusPtr` n) (k-1) + return (xs++ys) + +-- decodes a single MIDIPacket, and returns the length (in bytes), the timestamp, and the list of midi messages +depackSingleMIDIPacket :: Ptr MIDIPacket -> IO ( Int , MIDITimeStamp , [[Word8]] ) +depackSingleMIDIPacket p = do + ts <- peek (castPtr p ) :: IO MIDITimeStamp + len' <- peek (castPtr p `plusPtr` 8) :: IO UInt16 + let len = fromIntegral len' + msglist <- depackMsgList (castPtr p `plusPtr` 10 :: Ptr Word8) len + return ( len + 8 + 2, ts, msglist ) + +-- helper function +depackMsgList :: Ptr Word8 -> Int -> IO [[Word8]] +depackMsgList _ 0 = return [] +depackMsgList p n = if n < 0 + then fail "fatal error while depacking MIDI messages" + else do + (k,x) <- depackSingleMessage p + xs <- depackMsgList (p `plusPtr` k) (n-k) + return (x:xs) + +depackSingleMessage :: Ptr Word8 -> IO (Int,[Word8]) +depackSingleMessage p = do + + cmd <- peek p + + let hi = shiftR cmd 4 + lo = cmd .&. 15 + + let ret :: Int -> IO (Int,[Word8]) + ret k = do + xs <- mapM (peekElemOff p) [0..k-1] + return $ ( k , xs ) + + case hi of + 8 -> ret 3 -- ?! + 9 -> ret 3 + 10 -> ret 3 + 11 -> ret 3 + 12 -> ret 2 + 13 -> ret 2 + 14 -> ret 3 + 15 -> case lo of + 2 -> ret 3 + 3 -> ret 2 + 0 -> sysex p + _ -> ret 1 + _ -> fail "fatal error while interpreting a MIDI message" + +-- does not include the terminating 0xf7 byte! +sysex :: Ptr Word8 -> IO (Int,[Word8]) +sysex p = do + n <- sysexloop p 2 + xs <- mapM (peekElemOff p) [0..n] + return ( n+2 , xs ) + +sysexloop :: Ptr Word8 -> Int -> IO Int +sysexloop q i = do + x <- peekElemOff q i + if x == 0xf7 then return (i-1) else sysexloop q (i+1) + +----- Send + +-- |Sends a short message with timestamp "now". +midiSend :: MIDIPortRef -> Destination -> ShortMessage -> IO () +midiSend port dst msg = midiSend' port dst 0 msg + +-- |Sends a list of short messages with timestamp "now". +midiSendList :: MIDIPortRef -> Destination -> [ShortMessage] -> IO () +midiSendList port dst msglist = midiSendList' port dst 0 msglist + +-- |Sends a short message with the given timestamp. +midiSend' :: MIDIPortRef -> Destination -> MIDITimeStamp -> ShortMessage -> IO () +midiSend' port (Destination dst) ts msg = do + let encoded = encodeShortMessage msg + n = length encoded + allocaBytes (4 + 8 + 2 + n) $ \p -> do + poke ( p :: Ptr UInt32) 1 + poke (castPtr p `plusPtr` 4 :: Ptr UInt64) ts + poke (castPtr p `plusPtr` 12 :: Ptr UInt16) (fromIntegral n) + pokeArray (castPtr p `plusPtr` 14 :: Ptr Word8 ) encoded + osstatus <- c_MIDISend port dst (castPtr p) + when (osstatus /= 0) $ osStatusError osstatus + +-- |Sends a list of short messages with the given timestamp. +midiSendList' :: MIDIPortRef -> Destination -> MIDITimeStamp -> [ShortMessage] -> IO () +midiSendList' port (Destination dst) ts msglist = do + let encoded = encodeShortMessageList msglist + n = length encoded + allocaBytes (4 + 8 + 2 + n) $ \p -> do + poke ( p :: Ptr UInt32) 1 + poke (castPtr p `plusPtr` 4 :: Ptr UInt64) ts + poke (castPtr p `plusPtr` 12 :: Ptr UInt16) (fromIntegral n) + pokeArray (castPtr p `plusPtr` 14 :: Ptr Word8 ) encoded + osstatus <- c_MIDISend port dst (castPtr p) + when (osstatus /= 0) $ osStatusError osstatus + +type MIDISendSysExCallback = Ptr Word8 -> IO () + +foreign import ccall safe "wrapper" + mkMidiSendSysExCallback :: MIDISendSysExCallback -> IO (FunPtr MIDISendSysExCallback) + +midiSendSysExCallback :: MIDISendSysExCallback +midiSendSysExCallback p = do + free p + +-- Sends a system exclusive message. You shouldn't include the starting/trailing bytes 0xF0 and 0xF7. +midiSendSysEx :: Endpoint a => a -> [Word8] -> IO () +midiSendSysEx dst dat' = do + let ptrsize = sizeOf (undefined :: Ptr Word8) + n = length dat + k = 4*ptrsize + 8 + ep = endpoint dst + dat = 0xf0 : (dat' ++ [0xf7]) + cb <- mkMidiSendSysExCallback midiSendSysExCallback + p <- mallocBytes (k + n) + let q = (castPtr p `plusPtr` k) :: Ptr Word8 + pokeArray q dat + poke (castPtr p) ep ; r <- return (p `plusPtr` ptrsize) + poke (castPtr r) q ; r <- return (r `plusPtr` ptrsize) + poke (castPtr r) n ; r <- return (r `plusPtr` 4 ) + poke (castPtr r) (0::Int32) ; r <- return (r `plusPtr` 4 ) + poke (castPtr r) cb ; r <- return (r `plusPtr` ptrsize) + poke (castPtr r) p -- not used (?) + osstatus <- c_MIDISendSysex p -- this is asynchronous! (returns immediately before data has been sent) + when (osstatus /= 0) $ osStatusError osstatus + +----- Ports + +-- |Creates a new input port. +newInputPort :: MIDIClientRef -> String -> FunPtr (MIDIReadProc r s) -> Ptr r -> IO MIDIPortRef +newInputPort client name proc ref = do + withCFString name $ \cfname -> alloca $ \pport -> do + osstatus <- c_MIDIInputPortCreate client cfname proc ref pport + when (osstatus /= 0) $ osStatusError osstatus + peek pport + +-- |Creates a new output port. +newOutputPort :: MIDIClientRef -> String -> IO MIDIPortRef +newOutputPort client name = do + withCFString name $ \cfname -> alloca $ \pport -> do + osstatus <- c_MIDIOutputPortCreate client cfname pport + when (osstatus /= 0) $ osStatusError osstatus + peek pport + +-- |Disposes an existing port. +disposePort :: MIDIPortRef -> IO () +disposePort port = do + osstatus <- c_MIDIPortDispose port + when (osstatus /= 0) $ osStatusError osstatus + +-- |Connects an input port to a source. +connectToSource :: MIDIPortRef -> Source -> Ptr a -> IO () +connectToSource port (Source src) ref = do + osstatus <- c_MIDIPortConnectSource port src ref + when (osstatus /= 0) $ osStatusError osstatus + +-- |Disconnects an input port from a source. +disconnectFromSource :: MIDIPortRef -> Source -> IO () +disconnectFromSource port (Source src) = do + osstatus <- c_MIDIPortDisconnectSource port src + when (osstatus /= 0) $ osStatusError osstatus + +----- Clients + +-- |Creates a new MIDI client with the given name. +newClient :: String -> IO MIDIClientRef +newClient name = do + withCFString name $ \cfname -> alloca $ \pclient -> do + osstatus <- c_MIDIClientCreate cfname nullFunPtr nullPtr pclient + when (osstatus /= 0) $ osStatusError osstatus + peek pclient + +-- |Disposes an existing MIDI client. +disposeClient :: MIDIClientRef -> IO () +disposeClient client = do + osstatus <- c_MIDIClientDispose client + when (osstatus /= 0) $ osStatusError osstatus + + +----- Devices + +-- |Note: If a client iterates through the devices and entities in the system, it will not ever visit any virtual sources and destinations created by other clients. Also, a device iteration will return devices which are offline (were present in the past but are not currently present), while iterations through the system's sources and destinations will not include the endpoints of offline devices. +-- +-- Thus clients should usually use `enumerateSources` and `enumerateDestinations`, rather iterating through devices and entities to locate endpoints. +enumerateDevices :: IO [MIDIDeviceRef] +enumerateDevices = do + n <- c_MIDIGetNumberOfDevices + if n > 0 -- n is unsigned => (n-1)=(2^32)-1 !! + then forM [0..n-1] c_MIDIGetDevice + else return [] + +----- Endpoints + +-- |Enumaretes the MIDI sources present. +enumerateSources :: IO [Source] +enumerateSources = do + n <- c_MIDIGetNumberOfSources + if n > 0 -- n is unsigned => (n-1)=(2^32)-1 !! + then forM [0..n-1] $ \i -> liftM Source (c_MIDIGetSource i) + else return [] + +-- |Enumaretes the MIDI destinations present. +enumerateDestinations :: IO [Destination] +enumerateDestinations = do + n <- c_MIDIGetNumberOfSources + if n > 0 -- n is unsigned => (n-1)=(2^32)-1 !! + then forM [0..n-1] $ \i -> liftM Destination (c_MIDIGetDestination i) + else return [] + +-- a helper function; not exposed. +newEndpoint :: (MIDIClientRef -> CFStringRef -> Ptr MIDIEndpointRef -> IO OSStatus) + -> MIDIClientRef -> String -> IO MIDIEndpointRef +newEndpoint createEndpoint client name = withCFString name $ \cfname -> do + alloca $ \ptr_endpoint -> do + osstatus <- createEndpoint client cfname ptr_endpoint + if osstatus /= 0 + then osStatusError osstatus + else peek ptr_endpoint + +-- |Creates a new MIDI source with the given name. +newSource :: MIDIClientRef -> String -> IO Source +newSource client name = do + src <- newEndpoint c_MIDISourceCreate client name + return $ Source src + +-- |Creates a new MIDI destination with the given name. +newDestination :: MIDIClientRef -> String -> IO Destination +newDestination client name = do + dst <- newEndpoint c_MIDIDestinationCreate client name + return $ Destination dst + +-- |Disposes an existing MIDI endpoint. +disposeEndpoint :: Endpoint a => a -> IO () +disposeEndpoint x = do + osstatus <- c_MIDIEndpointDispose (endpoint x) + when (osstatus /= 0) $ osStatusError osstatus + diff --git a/src/System/Win32/MIDI.hs b/src/System/Win32/MIDI.hs new file mode 100644 --- /dev/null +++ b/src/System/Win32/MIDI.hs @@ -0,0 +1,508 @@ + +-- |Low-level binding to the Win32 MIDI services. +-- Error handling is via `fail`-s in the IO monad. + +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} +module System.Win32.MIDI + ( Source(..) + , Destination(..) + , enumerateSources + , enumerateDestinations + , MIDIHasName + , getName + , getModel + , getManufacturer + , getMidiInCaps + , getMidiOutCaps + , MidiInCaps(..) + , MidiOutCaps(..) + , midiInOpen + , midiOutOpen + , Callback(..) + , midiInClose + , midiOutClose + , midiInStart + , midiInStop + , midiInReset + , midiOutReset + , midiOutSend + + , midiInAddBuffer + , midiOutSendSysEx + , withMidiInHeader + , withMidiOutHeader + , newMidiInHeader + , freeMidiInHeader + + , MIDIHDR + , HMIDI + , HMIDIIN + , HMIDIOUT + , MIDIPROC + , MIDIINPROC + , MIDIOUTPROC + , mkMIDIPROC + + , decodeShortMessage + , encodeShortMessage + , MIM(..) + , MOM(..) + , mim + , mom + + , timeGetTime -- not strictly MIDI, nevertheless quite useful in this context + ) where + +import Control.Monad +import Data.Bits +import Data.Word +import Foreign +import Foreign.Storable + +import System.Win32.Types +import System.MIDI.Base + +maxPNAMELEN = 32 :: Int +maxERRORLENGTH = 256 :: UINT + +midiMapperID = -1 :: UINT + +type HMIDI = HANDLE +type HMIDIIN = HANDLE +type HMIDIOUT = HANDLE + +type MIDIPROC a = HMIDI -> UINT -> Ptr a -> DWORD -> DWORD -> IO () +type MIDIINPROC a = HMIDIIN -> UINT -> Ptr a -> DWORD -> DWORD -> IO () +type MIDIOUTPROC a = HMIDIOUT -> UINT -> Ptr a -> DWORD -> DWORD -> IO () + +foreign import stdcall safe "wrapper" + mkMIDIPROC :: MIDIPROC () -> IO (FunPtr (MIDIPROC ())) + +----- + +type MMRESULT = UINT +type MMVERSION = UINT + +newtype Source = Source UINT deriving (Show,Eq) +newtype Destination = Destination UINT deriving (Show,Eq) + +fromMMVersion :: MMVERSION -> (Int,Int) +fromMMVersion mmversion = (major,minor) where + major = fromIntegral $ shiftR mmversion 8 + minor = fromIntegral $ mmversion .&. 255 + +----- Time + +-- Returns the system time in miliseconds. +foreign import stdcall unsafe "mmsystem.h timeGetTime" + timeGetTime :: IO DWORD + +----- Errors + +{- +-- not really informative conversion (fallback) +mmErrorString :: MMRESULT -> String +mmErrorString mmresult = "MMRESULT = " ++ show mmresult + +-- not really informative "fail" +mmError :: MMRESULT -> IO a +mmError mmresult = fail $ mmErrorString mmresult +-} + +mmInError :: MMRESULT -> IO a +mmInError mmresult = do { txt <- midiInGetErrorText mmresult ; fail txt } + +mmOutError :: MMRESULT -> IO a +mmOutError mmresult = do { txt <- midiOutGetErrorText mmresult ; fail txt } + +foreign import stdcall unsafe "mmsystem.h midiInGetErrorTextW" + c_midiInGetErrorText :: MMRESULT -> LPTSTR -> UINT -> IO UINT + +foreign import stdcall unsafe "mmsystem.h midiOutGetErrorTextW" + c_midiOutGetErrorText :: MMRESULT -> LPTSTR -> UINT -> IO UINT + +midiInGetErrorText :: MMRESULT -> IO String +midiInGetErrorText errcode = do + allocaArray0 (fromIntegral maxERRORLENGTH) $ \p -> do + mmr <- c_midiInGetErrorText errcode p maxERRORLENGTH + if mmr /= 0 + then return "invalid MMRESULT" + else peekTString p + +midiOutGetErrorText :: MMRESULT -> IO String +midiOutGetErrorText errcode = do + allocaArray0 (fromIntegral maxERRORLENGTH) $ \p -> do + mmr <- c_midiOutGetErrorText errcode p maxERRORLENGTH + if mmr /= 0 + then return "invalid MMRESULT" + else peekTString p + +----- Devices + +foreign import stdcall unsafe "mmsystem.h midiInGetNumDevs" + c_midiInGetNumDevs :: IO UINT + +foreign import stdcall unsafe "mmsystem.h midiOutGetNumDevs" + c_midiOutGetNumDevs :: IO UINT + +-- |Eumerates the MIDI sources. +enumerateSources :: IO [Source] +enumerateSources = do + n <- c_midiInGetNumDevs + return $ if n>0 then [ Source i | i<-[0..n-1] ] else [] -- n is unsigned! + +-- |Eumerates the MIDI destinations. +enumerateDestinations :: IO [Destination] +enumerateDestinations = do + n <- c_midiOutGetNumDevs + return $ if n>0 then [ Destination i | i<-[0..n-1] ] else [] -- n is unsigned! + +----- MIDI capabilities + +manufacturerIDToString :: WORD -> String +manufacturerIDToString mid = "Manufacturer ID = " ++ show mid + +productIDToString :: WORD -> WORD -> String +productIDToString mid pid = "Product ID = " ++ show mid ++ ":" ++ show pid + +data MIDIINCAPS +data MIDIOUTCAPS + +type LPMIDIINCAPS = Ptr MIDIINCAPS +type LPMIDIOUTCAPS = Ptr MIDIOUTCAPS + +data MidiInCaps = MidiInCaps + { mic_Mid :: WORD + , mic_Pid :: WORD + , mic_DriverVersion :: MMVERSION + , mic_Pname :: String -- TCHAR [MAXPNAMELEN] + , mic_Support :: DWORD -- reserved + } deriving Show + +instance Storable MidiInCaps where + sizeOf _ = 12 + maxPNAMELEN * sizeOf (undefined::TCHAR) + alignment _ = 4 + peek p = do + mid <- peek (castPtr p) ; q <- return (p `plusPtr` 2) + pid <- peek (castPtr q) ; q <- return (q `plusPtr` 2) + ver <- peek (castPtr q) ; q <- return (q `plusPtr` 4) + nam <- peekTString (castPtr q) ; q <- return (q `plusPtr` (4*maxPNAMELEN)) + sup <- peek (castPtr q) + return $ MidiInCaps mid pid ver nam sup + poke p mic = fail "MidiInCaps/poke not implemented yet" + +data MidiOutCaps = MidiOutCaps + { moc_Mid :: WORD + , moc_Pid :: WORD + , moc_DriverVersion :: MMVERSION + , moc_Pname :: String -- TCHAR [MAXPNAMELEN] + , moc_Technology :: WORD + , moc_Voices :: WORD + , moc_Notes :: WORD + , moc_ChannelMask :: WORD + , moc_Support :: DWORD -- reserved + } deriving Show + +instance Storable MidiOutCaps where + sizeOf _ = 20 + maxPNAMELEN * sizeOf (undefined::TCHAR) + alignment _ = 4 + peek p = do + mid <- peek (castPtr p) ; q <- return (p `plusPtr` 2) + pid <- peek (castPtr q) ; q <- return (q `plusPtr` 2) + ver <- peek (castPtr q) ; q <- return (q `plusPtr` 4) + nam <- peekTString (castPtr q) ; q <- return (q `plusPtr` (4*maxPNAMELEN)) + tec <- peek (castPtr p) ; q <- return (p `plusPtr` 2) + voi <- peek (castPtr p) ; q <- return (p `plusPtr` 2) + not <- peek (castPtr p) ; q <- return (p `plusPtr` 2) + chm <- peek (castPtr p) ; q <- return (p `plusPtr` 2) + sup <- peek (castPtr q) + return $ MidiOutCaps mid pid ver nam tec voi not chm sup + poke p mic = fail "not implemented yet" + +foreign import stdcall unsafe "mmsystem.h midiInGetDevCapsW" + c_midiInGetDevCaps :: UINT -> LPMIDIINCAPS -> UINT -> IO MMRESULT + +foreign import stdcall unsafe "mmsystem.h midiOutGetDevCapsW" + c_midiOutGetDevCaps :: UINT -> LPMIDIOUTCAPS -> UINT -> IO MMRESULT + +-- |`Source`'s and `Destinations` have names, models and manufacturers (though the last two is not really supported...) +class MIDIHasName a where + getName :: a -> IO String + getModel :: a -> IO String + getManufacturer :: a -> IO String + +instance MIDIHasName Source where + getName src = do + caps <- getMidiInCaps src + return $ mic_Pname caps + getModel src = do + caps <- getMidiInCaps src + return $ productIDToString (mic_Mid caps) (mic_Pid caps) + getManufacturer src = do + caps <- getMidiInCaps src + return $ manufacturerIDToString (mic_Mid caps) + +instance MIDIHasName Destination where + getName dst = do + caps <- getMidiOutCaps dst + return $ moc_Pname caps + getModel dst = do + caps <- getMidiOutCaps dst + return $ productIDToString (moc_Mid caps) (moc_Pid caps) + getManufacturer dst = do + caps <- getMidiOutCaps dst + return $ manufacturerIDToString (moc_Mid caps) + +getMidiInCaps :: Source -> IO MidiInCaps +getMidiInCaps (Source device) = do + let cast = castPtr :: Ptr MidiInCaps -> LPMIDIINCAPS + alloca $ \ptr -> do + mmresult <- c_midiInGetDevCaps device (cast ptr) (fromIntegral $ sizeOf (undefined::MidiInCaps)) + if mmresult /= 0 + then mmInError mmresult + else peek ptr + +getMidiOutCaps :: Destination -> IO MidiOutCaps +getMidiOutCaps (Destination device) = do + let cast = castPtr :: Ptr MidiOutCaps -> LPMIDIOUTCAPS + alloca $ \ptr -> do + mmresult <- c_midiOutGetDevCaps device (cast ptr) (fromIntegral $ sizeOf (undefined::MidiOutCaps)) + if mmresult /= 0 + then mmOutError mmresult + else peek ptr + +----- Open / Close (these should be "safe", as they are generating immediate callbacks!) + +foreign import stdcall safe "mmsystem.h midiInOpen" + c_midiInOpen :: Ptr HMIDIIN -> UINT -> FunPtr (MIDIINPROC a) -> Ptr a -> DWORD -> IO MMRESULT + +foreign import stdcall safe "mmsystem.h midiOutOpen" + c_midiOutOpen :: Ptr HMIDIOUT -> UINT -> FunPtr (MIDIOUTPROC a) -> Ptr a -> DWORD -> IO MMRESULT + +foreign import stdcall safe "mmsystem.h midiInClose" + c_midiInClose :: HMIDIIN -> IO MMRESULT + +foreign import stdcall safe "mmsystem.h midiOutClose" + c_midiOutClose :: HMIDIOUT -> IO MMRESULT + +----- Start / Stop / Reset + +foreign import stdcall unsafe "mmsystem.h midiInStart" + c_midiInStart :: HMIDIIN -> IO MMRESULT + +foreign import stdcall unsafe "mmsystem.h midiInStop" + c_midiInStop :: HMIDIIN -> IO MMRESULT + +foreign import stdcall safe "mmsystem.h midiInReset" + c_midiInReset :: HMIDIIN -> IO MMRESULT -- the resetting functions must be safe, as they are doing callbacks!!! + +foreign import stdcall safe "mmsystem.h midiOutReset" + c_midiOutReset :: HMIDIIN -> IO MMRESULT + +----- Send Messages + +data MIDIHDR + +foreign import stdcall unsafe "mmsystem.h midiInAddBuffer" -- this should be called midiInLongMsg ??? + c_midiInAddBuffer :: HMIDIIN -> Ptr MIDIHDR -> UINT -> IO MMRESULT + +foreign import stdcall unsafe "mmsystem.h midiOutShortMsg" + c_midiOutShortMsg :: HMIDIOUT -> DWORD -> IO MMRESULT + +foreign import stdcall unsafe "mmsystem.h midiOutLongMsg" + c_midiOutLongMsg :: HMIDIOUT -> Ptr MIDIHDR -> UINT -> IO MMRESULT + +foreign import stdcall unsafe "mmystem.h midiInPrepareHeader" + c_midiInPrepareHeader :: HMIDIIN -> Ptr MIDIHDR -> UINT -> IO MMRESULT + +foreign import stdcall unsafe "mmystem.h midiOutPrepareHeader" + c_midiOutPrepareHeader :: HMIDIOUT -> Ptr MIDIHDR -> UINT -> IO MMRESULT + +foreign import stdcall unsafe "mmystem.h midiInUnprepareHeader" + c_midiInUnprepareHeader :: HMIDIIN -> Ptr MIDIHDR -> UINT -> IO MMRESULT + +foreign import stdcall unsafe "mmystem.h midiOutUnprepareHeader" + c_midiOutUnprepareHeader :: HMIDIOUT -> Ptr MIDIHDR -> UINT -> IO MMRESULT + +type CPrepare = HMIDI -> Ptr MIDIHDR -> UINT -> IO MMRESULT +type CUnprepare = HMIDI -> Ptr MIDIHDR -> UINT -> IO MMRESULT + +waitFor :: IO Bool -> IO () +waitFor check = do + b <- check + unless b $ waitFor check + +while :: (a -> Bool) -> IO a -> IO a +while cond act = do + x <- act + if cond x then while cond act else return x + +withMidiHeader :: (MMRESULT -> IO ()) -> CPrepare -> CUnprepare -> HMIDI -> [Word8] -> (HMIDI -> Ptr MIDIHDR -> UINT -> IO a) -> IO a +withMidiHeader mmError prepare unprepare handle bytes action = do + let n = fromIntegral (length bytes) :: DWORD + size = 48 :: UINT -- size of the MIDIHDR structure + allocaBytes (fromIntegral size) $ \p -> allocaBytes (fromIntegral n) $ \q -> do + poke (castPtr p ) q -- pointer to the data + poke (castPtr p `plusPtr` 4) n -- length of the data + poke (castPtr p `plusPtr` 16) (0::DWORD) -- flags, must be zero + mmresult <- prepare handle p size ; when (mmresult /=0) $ mmError mmresult + pokeArray q bytes + x <- action handle p size +{- + waitFor $ do + flags <- peek (castPtr p `plusPtr` 16) :: IO DWORD + return $ (flags .&. 1) /= 0 -- DONE FLAG + mmresult <- unprepare handle p size ; when (mmresult /=0) $ mmError mmresult +-} + mmresult <- while (==65) (unprepare handle p size) -- 65 is MIDIERR_STILLPLAYING + return x + +newMidiHeader :: (MMRESULT -> IO ()) -> CPrepare -> HMIDI -> Int -> IO (Ptr MIDIHDR) +newMidiHeader mmError prepare handle n = do + let size = 48 :: UINT -- size of the MIDIHDR structure + p <- mallocBytes (fromIntegral size + n) + let q = castPtr p `plusPtr` (fromIntegral size) :: Ptr Word8 + poke (castPtr p ) q -- pointer to the data + poke (castPtr p `plusPtr` 4) n -- length of the data + poke (castPtr p `plusPtr` 16) (0::DWORD) -- flags, must be zero + mmresult <- prepare handle p size ; when (mmresult /=0) $ mmError mmresult + return p + +freeMidiHeader :: (MMRESULT -> IO ()) -> CUnprepare -> HMIDI -> Ptr MIDIHDR -> IO () +freeMidiHeader mmError unprepare handle p = do + mmresult <- unprepare handle p 48 ; when (mmresult /=0) $ mmError mmresult + free p + +withMidiInHeader = withMidiHeader mmInError c_midiInPrepareHeader c_midiInUnprepareHeader +withMidiOutHeader = withMidiHeader mmOutError c_midiOutPrepareHeader c_midiOutUnprepareHeader +newMidiInHeader = newMidiHeader mmInError c_midiInPrepareHeader +freeMidiInHeader = freeMidiHeader mmInError c_midiInUnprepareHeader + +midiInAddBuffer :: HMIDIIN -> Int -> IO (Ptr MIDIHDR) +midiInAddBuffer handle n = do + p <- newMidiInHeader handle n + mmresult <- c_midiInAddBuffer handle p 48 + when (mmresult /=0) $ mmInError mmresult + return p + +-- |you shouldn't include the starting/trailing bytes 0xf0 and 0xf7 +midiOutSendSysEx :: HMIDIOUT -> [Word8] -> IO () +midiOutSendSysEx handle msg' = do + let msg = 0xf0 : (msg' ++ [0xf7]) + --print msg + mmresult <- withMidiOutHeader handle msg c_midiOutLongMsg + when (mmresult /=0) $ mmOutError mmresult + +midiOutSend :: HMIDIOUT -> ShortMessage -> IO () +midiOutSend handle msg = do + mmresult <- c_midiOutShortMsg handle (encodeShortMessage msg) + when (mmresult /=0) $ mmOutError mmresult + +---------- exported Haskell functions --------- + +encodeRunningMessages :: [ShortMessage] -> [DWORD] +encodeRunningMessages msgs = encodeShortMessage (head msgs) : map encode' (tail msgs) where + encode' msg = fromIntegral (sm_byte1 msg) + (shiftL (fromIntegral $ sm_byte2 msg) 8) + +encodeShortMessage :: ShortMessage -> DWORD +encodeShortMessage (ShortMessage chn' msg' bt1' bt2') + = chn + shiftL msg 4 + shiftL bt1 8 + shiftL bt2 16 + where + chn = 15 .&. fromIntegral chn' + msg = 15 .&. fromIntegral msg' + bt1 = fromIntegral bt1' + bt2 = fromIntegral bt2' + +decodeShortMessage :: DWORD -> ShortMessage +decodeShortMessage x = ShortMessage chn msg bt1 bt2 + where + chn = fromIntegral $ ( x ) .&. 15 + msg = fromIntegral $ (shiftR x 4) .&. 15 + bt1 = fromIntegral $ (shiftR x 8) .&. 255 + bt2 = fromIntegral $ (shiftR x 16) .&. 255 + +midiInStart :: HMIDIIN -> IO () +midiInStart handle = do + mmresult <- c_midiInStart handle + when (mmresult /=0) $ mmInError mmresult + +midiInStop :: HMIDIIN -> IO () +midiInStop handle = do + mmresult <- c_midiInStop handle + when (mmresult /=0) $ mmInError mmresult + +midiInClose :: HMIDIIN -> IO () +midiInClose handle = do + mmresult <- c_midiInClose handle + when (mmresult /=0) $ mmInError mmresult + +midiOutClose :: HMIDIOUT -> IO () +midiOutClose handle = do + mmresult <- c_midiOutClose handle + when (mmresult /=0) $ mmOutError mmresult + +midiInReset :: HMIDIIN -> IO () +midiInReset handle = do + mmresult <- c_midiInReset handle + when (mmresult /=0) $ mmInError mmresult + +midiOutReset :: HMIDIOUT -> IO () +midiOutReset handle = do + mmresult <- c_midiOutReset handle + when (mmresult /=0) $ mmOutError mmresult + +data MIM + = MIM_OPEN + | MIM_CLOSE + | MIM_DATA + | MIM_LONGDATA + | MIM_ERROR + | MIM_LONGERROR + deriving (Eq,Show) + +mim :: UINT -> MIM +mim 0x3C1 = MIM_OPEN +mim 0x3C2 = MIM_CLOSE +mim 0x3C3 = MIM_DATA +mim 0x3C4 = MIM_LONGDATA +mim 0x3C5 = MIM_ERROR +mim 0x3C6 = MIM_LONGERROR + +data MOM + = MOM_OPEN + | MOM_CLOSE + | MOM_DONE + deriving (Eq,Show) + +mom :: UINT -> MOM +mom 0x3c7 = MOM_OPEN +mom 0x3c8 = MOM_CLOSE +mom 0x3c9 = MOM_DONE + +data Callback + = CALLBACK_NULL -- ^ no callback + | CALLBACK_WINDOW -- ^ callback is window (needs a HWND) + | CALLBACK_THREAD -- ^ callback is a thread (needs the thread id) + | CALLBACK_FUNCTION Bool -- ^ callback is a function; the boolean is MIDI_IO_STATUS (input only) + | CALLBACK_EVENT -- ^ callback is an event (needs an event handle; output only) + +callback :: Callback -> DWORD +callback CALLBACK_NULL = 0x00000000 +callback CALLBACK_WINDOW = 0x00010000 +callback CALLBACK_THREAD = 0x00020000 +callback (CALLBACK_FUNCTION ios) = 0x00030000 + if ios then 0x20 else 0 +callback CALLBACK_EVENT = 0x00050000 + +midiInOpen :: Source -> FunPtr (MIDIINPROC a) -> Ptr a -> Callback -> IO HMIDIIN +midiInOpen (Source dev) proc ref cbtype = + alloca $ \phandle -> do + mmresult <- c_midiInOpen phandle dev proc ref (callback cbtype) + when (mmresult /=0) $ mmInError mmresult + peek phandle + +midiOutOpen :: Destination -> FunPtr (MIDIOUTPROC a) -> Ptr a -> Callback -> IO HMIDIOUT +midiOutOpen dst@(Destination dev) proc ref cbtype = do + alloca $ \phandle -> do + mmresult <- c_midiOutOpen phandle dev proc ref (callback cbtype) + when (mmresult /=0) $ mmInError mmresult + peek phandle