hmidi-0.1: System/Win32/MIDI.hs
-- |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