module Sound.JACK.FFI.MIDI
(
EventBuffer(EventBuffer),
RawEvent(RawEvent),
time,
buffer,
toRawEventFunction,
get_event_count,
event_get,
clear_buffer,
event_reserve,
event_write,
withByteStringPtr,
)
where
import Sound.JACK.FFI (NFrames(NFrames), )
import Foreign.Marshal.Array (copyArray, advancePtr, )
import Foreign.ForeignPtr (withForeignPtr, )
import Foreign.Ptr (Ptr, castPtr, )
import Foreign.Storable (Storable, peekByteOff, pokeByteOff, sizeOf, alignment, peek, poke)
import Foreign.C.Types (CULong, CUInt, CUChar, CSize)
import Foreign.C.Error (Errno, )
import Data.Word (Word8, )
import qualified Data.ByteString as B
import qualified Data.ByteString.Internal as BI
import qualified Data.ByteString.Lazy as BL
import qualified Sound.MIDI.Message as Msg
import qualified Sound.MIDI.Parser.Report as Report
import System.IO (hPutStrLn, stderr, )
data EventBuffer = EventBuffer
data RawEvent = RawEvent {
time :: NFrames
, buffer :: B.ByteString
} deriving (Eq, Ord)
toRawEventFunction ::
(NFrames -> (NFrames, Msg.T) -> IO (NFrames, Msg.T))
->
(NFrames -> RawEvent -> IO RawEvent)
toRawEventFunction fun cycleStart rawEvent =
case Msg.maybeFromByteString $ BL.fromChunks [buffer rawEvent] of
Report.Cons warnings result -> do
mapM_ (hPutStrLn stderr) warnings
case result of
Left _ -> do
putStrLn $ "Warning: Did not understand Event: " ++ show rawEvent
return rawEvent
Right e -> do
(time_, event_) <- fun cycleStart (time rawEvent, e)
return $ RawEvent time_ $ B.concat $
BL.toChunks $ Msg.toByteString event_
instance Storable RawEvent where
sizeOf _ = 12
alignment _ = alignment (undefined :: CUInt)
peek pointer = do
time_ <- (\ptr -> do {peekByteOff ptr 0 ::IO CUInt}) pointer
size_ <- (\ptr -> do {peekByteOff ptr 4 ::IO CUInt}) pointer
bufferPtr <- (\ptr -> do {peekByteOff ptr 8 ::IO (Ptr CUChar)}) pointer
let sizeInt = fromIntegral size_
buffer_ <-
BI.create sizeInt $ \dest ->
copyArray dest (castPtr bufferPtr) sizeInt
return $ RawEvent (NFrames time_) buffer_
poke pointer (RawEvent (NFrames time_) buffer_) = do
(\ptr val -> do {pokeByteOff ptr 0 (val::CUInt)}) pointer time_
(\ptr val -> do {pokeByteOff ptr 4 (val::CUInt)}) pointer (fromIntegral $ B.length buffer_)
bufferPtr <- (\ptr -> do {peekByteOff ptr 8 ::IO (Ptr CUChar)}) pointer
withByteStringPtr buffer_ $ \ptr len ->
copyArray (castPtr bufferPtr) ptr len
(\ptr val -> do {pokeByteOff ptr 8 (val::(Ptr CUChar))}) pointer bufferPtr
withByteStringPtr :: B.ByteString -> (Ptr Word8 -> Int -> IO a) -> IO a
withByteStringPtr bstr act =
case BI.toForeignPtr bstr of
(fptr, start, len) ->
withForeignPtr fptr $ \ptr ->
act (advancePtr ptr start) len
instance Show RawEvent where
show rawEvent =
"MIDIEvent @ " ++ show (time rawEvent) ++
"\t: " ++ showEvent (buffer rawEvent)
showEvent :: B.ByteString -> String
showEvent buffer_ =
case Msg.maybeFromByteString $ BL.fromChunks [buffer_] of
Report.Cons warnings result ->
unlines warnings ++
case result of
Left errMsg -> "Warning: " ++ errMsg
Right e ->
case e of
Msg.Channel b -> "MidiMsg.Channel " ++ show b
Msg.System _ -> "MidiMsg.System ..."
foreign import ccall "static jack/midiport.h jack_midi_get_event_count"
get_event_count :: Ptr EventBuffer -> IO NFrames
foreign import ccall "static jack/midiport.h jack_midi_event_get"
event_get :: Ptr RawEvent -> Ptr EventBuffer -> NFrames -> IO Errno
foreign import ccall "static jack/midiport.h jack_midi_clear_buffer"
clear_buffer :: Ptr EventBuffer -> IO ()
foreign import ccall "static jack/midiport.h jack_midi_event_reserve"
event_reserve :: Ptr EventBuffer -> NFrames -> CSize -> IO (Ptr Word8)
foreign import ccall "static jack/midiport.h jack_midi_event_write"
event_write :: Ptr EventBuffer -> NFrames -> Ptr Word8 -> CULong -> IO Errno