SysEx.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}

module Sound.PortMidi.SysEx where

import Data.Char (chr)
import Data.Word (Word8)
import Data.Either (partitionEithers)

import qualified Sound.PortMidi as Midi

import Sound.PortMidi.Simple (Timestamp, Message(..), midi_, waitInput)

data Handle = Handle
  { sysexOut    :: Midi.PMStream
  , sysexIn     :: Midi.PMStream
  , sysexReader :: IO [(Timestamp, Message)]
  , sysexRate   :: Int
  }

class Encode a where
  encode :: a -> [Word8]

instance Encode [Word8] where
  encode = id

class Decode a where
  type DecodeError a
  decode :: [Word8] -> Either (DecodeError a) a

instance Decode [Word8] where
  type DecodeError [Word8] = ()
  decode = Right

type Messages = [(Timestamp, Message)]
type Results res = [(Timestamp, Either (DecodeError res) res)]
{- AKA @unsafePerformWhateverIsNeeded@

XXX: Access to streams should be externally synchronized.
-}
call
  :: (Encode req, Decode res)
  => Handle
  -> req
  -> IO (Messages, Results res)
call Handle{..} req = do
  time <- Midi.time
  midi_ $ Midi.writeSysEx sysexOut time $
    map (chr . fromIntegral) (encode req)

  waitInput sysexRate sysexIn
  messages <- sysexReader
  pure $ partitionEithers do
    msg@(timestamp, message) <- messages
    case message of
      SysEx bytes ->
        pure . Right $ (timestamp, decode bytes)
      _rest ->
        pure $ Left msg

-- | Even more unsafe, when you REALLY don't care and just want to
call_
  :: (Encode req, Decode res)
  => Handle
  -> req
  -> IO (Either (Messages, Results res) res)
call_ handle req = do
  call handle req >>= \case
    ([], [(_ts, Right one)]) ->
      pure $ Right one
    rest ->
      pure $ Left rest