MIDI.chs

{-# LANGUAGE ForeignFunctionInterface #-}

#include "jack/midiport.h"

module Sound.JACK.FFI.MIDI
  (
    EventBuffer(EventBuffer),

    RawEvent(RawEvent),
    time,
    buffer,

    toRawEventFunction,

    get_event_count,
    event_get,
    clear_buffer,
    event_reserve,
    event_write,

    -- internal
    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, )


-- could also be an empty data declaration
data EventBuffer = EventBuffer

-- | Represents a raw JACK MIDI event
data RawEvent = RawEvent {
      time   :: NFrames      -- ^ Sample index at which event is valid (relative to cycle start)
    , buffer :: B.ByteString -- ^ Raw MIDI data
} deriving (Eq, Ord)

-- | Converts high level MIDI Event transformation functions into raw MIDI Event transformation functions
toRawEventFunction ::
   (NFrames -> (NFrames, Msg.T) -> IO (NFrames, Msg.T))
        -- ^ transforms Sound.MIDI.File.Event
   ->
   (NFrames -> RawEvent -> IO RawEvent)
        -- ^ transforms Sound.JACK.MIDI.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    _ = {# sizeof jack_midi_event_t #}

    alignment _ = alignment (undefined :: CUInt)

    peek pointer = do
        time_ <- {# get jack_midi_event_t-> time #} pointer
        size_ <- {# get jack_midi_event_t-> size #} pointer

        bufferPtr <- {# get jack_midi_event_t-> buffer #} pointer
        let sizeInt = fromIntegral size_
        buffer_ <-
            BI.create sizeInt $ \dest ->
                copyArray dest (castPtr bufferPtr) sizeInt

        return $ RawEvent (NFrames time_) buffer_

    {- |
    This implementation expects that port buffer pointer is already initialized.
    This is dangerous, but currently we do not know, how to do it better.
    -}
    poke pointer (RawEvent (NFrames time_) buffer_) = do
        {# set jack_midi_event_t-> time #} pointer time_
        {# set jack_midi_event_t-> size #} pointer (fromIntegral $ B.length buffer_)

        bufferPtr <- {# get jack_midi_event_t-> buffer #} pointer
        withByteStringPtr buffer_ $ \ptr len ->
            copyArray (castPtr bufferPtr) ptr len

        {# set jack_midi_event_t-> buffer #} 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 ()

-- nullPtr may be mapped to eNOBUFS exception as in event_write
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