Simple.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}

module Sound.PortMidi.Simple where

import Control.Concurrent (threadDelay)
import Data.Word (Word8, Word64)
import Data.Foldable (find)
import Data.Bits (Bits(..), (.&.), shiftR)
import Data.List (isPrefixOf)
import Data.Traversable (for)
import Control.Exception (Exception(..), bracket, bracket_, throwIO)

import qualified Sound.PortMidi as Midi
import qualified Foreign

-- * Exceptional wrappers

data MidiError
  = MidiError Midi.PMError
  | SysExTruncated
  deriving (Show)

instance Exception MidiError

midi :: IO (Either Midi.PMError b) -> IO b
midi action = action >>= \case
  Left err ->
    throwIO $ MidiError err
  Right res ->
    pure res

midi_ :: IO (Either Midi.PMError Midi.PMSuccess) -> IO ()
midi_ action = () <$ midi action

-- * Global library wrapper

withMidi :: IO a -> IO a
withMidi = bracket_ midiInitialize midiTerminate

-- TODO: make reenterable?
midiInitialize :: IO ()
midiInitialize = midi_ Midi.initialize

midiTerminate :: IO ()
midiTerminate = midi_ Midi.terminate

-- * Devices

-- ** Enumeration

getDevices :: IO [(Midi.DeviceID, Midi.DeviceInfo)]
getDevices = do
  n <- Midi.countDevices
  for [0 .. n-1] \device -> do
    info <- Midi.getDeviceInfo device
    pure (device, info)

findDevice :: ((Midi.DeviceID, Midi.DeviceInfo) -> Bool) -> IO (Maybe (Midi.DeviceID, Midi.DeviceInfo))
findDevice pred = do
  devices <- getDevices
  pure $ find pred devices

findInputNamed :: [Char] -> IO (Maybe Midi.DeviceID)
findInputNamed name =
  findDevice pred >>= \case
    Nothing ->
      pure Nothing
    Just (device, _info) ->
      pure $ Just device
  where
    pred (_device, Midi.DeviceInfo{input, name=devicName}) =
      input && isPrefixOf name devicName

findOutputNamed :: [Char] -> IO (Maybe Midi.DeviceID)
findOutputNamed name =
  findDevice pred >>= \case
    Nothing ->
      pure Nothing
    Just (device, _info) ->
      pure $ Just device
  where
    pred (_device, Midi.DeviceInfo{output, name=devicName}) =
      output && isPrefixOf name devicName

-- ** Input

withInput :: Midi.DeviceID -> (Midi.PMStream -> IO c) -> IO c
withInput device action = bracket (midiOpenInput device) midiClose action

midiOpenInput :: Midi.DeviceID -> IO Midi.PMStream
midiOpenInput device = midi $ Midi.openInput device

-- ** Output

withOutput :: Midi.DeviceID -> Int -> (Midi.PMStream -> IO c) -> IO c
withOutput device latency action = bracket (midiOpenOutput device latency) midiClose action

midiOpenOutput :: Midi.DeviceID -> Int -> IO Midi.PMStream
midiOpenOutput device latency = midi $ Midi.openOutput device latency

-- ** Common

midiClose :: Midi.PMStream -> IO ()
midiClose stream = midi_ $ Midi.close stream

-- * Streams

-- ** Input

type Timestamp = Integer

data Message
  = Channel Int ChannelMessage
  | Raw Midi.PMEvent -- ^ Unparsed message data
  | SysEx [Word8]
  | Realtime Word8
  deriving (Eq, Show)

type ChannelReader r = IO [(Timestamp, Message)] -> IO r

withReadMessages :: Midi.PMStream -> Int -> ChannelReader r -> IO r
withReadMessages stream bufSize action =
  withReadEvents stream bufSize $
    action . mkReadMessages

mkReadMessages :: IO [Midi.PMEvent] -> IO [(Timestamp, Message)]
mkReadMessages readEvents = do
  {- XXX: events may contain realtime byte-sized messages and can be truncated.

  > When receiving sysex messages, the sysex message is terminated by either
  > an EOX status byte (anywhere in the 4 byte messages) or by a non-real-time
  > status byte in the low order byte of the message.
  > If you get a non-real-time status byte but there was no EOX byte, it means
  > the sysex message was somehow truncated.
  > This is not considered an error; e.g., a missing EOX can result from
  > the user disconnecting a MIDI cable during sysex transmission.

  http://portmedia.sourceforge.net/portmidi/doxygen/structPmEvent.html
  -}
  events <- readEvents
  readMsg [] events
  where
    readMsg acc = \case
      [] ->
        pure $ reverse acc

      buf@(event@Midi.PMEvent{timestamp, message} : next) ->
        if message .&. 0xFF == 0xF0 then
          readSysEx0 acc [] buf
        else
          let
            msg =
              case channelMessage (Midi.decodeMsg message) of
                Nothing ->
                  Raw event
                Just msg ->
                  msg
          in
            readMsg ((toInteger timestamp, msg) : acc) next

    readSysEx0 msgs acc = \case
      [] ->
        throwIO SysExTruncated
      cur : next -> do
        let
          quad = fromIntegral (Midi.message cur) :: Word64
          chunk = map fromIntegral -- XXX: goes via Integer
            [ 0xFF .&. quad
            , 0xFF .&. quad `shiftR`  8
            , 0xFF .&. quad `shiftR` 16
            , 0xFF .&. quad `shiftR` 24
            ]

        -- TODO: extract stray realtimes

        if elem 0xF7 chunk then
          let
            msg =
              ( fromIntegral $ Midi.timestamp cur
              , SysEx . concat $ reverse (chunk : acc)
              )
          in
            readMsg (msg : msgs) next
        else
          readSysEx0 msgs (chunk : acc) next

withReadEvents :: Midi.PMStream -> Int -> (IO [Midi.PMEvent] -> IO r) -> IO r
withReadEvents stream bufSize action =
  Foreign.allocaArray bufSize \buf ->
    let
      readEvents = do
        Midi.PMEventCount count <- midi $
          Midi.readEventsToBuffer stream buf (fromIntegral bufSize)
        Foreign.peekArray (fromIntegral count) buf
        -- pure do
        --   Midi.PMEvent{timestamp, message} <- events
        --   pure (fromIntegral timestamp, Midi.decodeMsg message)
    in
      action readEvents

waitInput :: Int -> Midi.PMStream -> IO ()
waitInput rate inStream =
  midi (Midi.poll inStream) >>= \case
    Midi.GotData ->
      pure ()
    Midi.NoError'NoData -> do
      threadDelay rate
      waitInput rate inStream

-- * Message

{- XXX: stripped-down Codec.Midi.Message

Copyright: George Giorgidze
-}

data ChannelMessage
  = NoteOff
      { key      :: !Int
      , velocity :: !Int
      }
  | NoteOn
      { key      :: !Int
      , velocity :: !Int
      }
  | KeyPressure
      { key      :: !Int
      , pressure :: !Int
      }
  | ControlChange
      { controllerNumber :: !Int
      , controllerValue  :: !Int
      }
  | ProgramChange
      { preset :: !Int
      }
  | ChannelPressure
      { pressure :: !Int
      }
  | PitchWheel
      { pitchWheel :: !Int
      }
  deriving (Show,Eq)

{- XXX: adapted Euterpea.IO.MIDI.MidiIO.msgToMidi

Copyright (c) 2008-2015 Euterpea authors
-}

-- -- type Channel = Int

channelMessage :: Midi.PMMsg -> Maybe Message
channelMessage (Midi.PMMsg m d1 d2) =
  case (m .&. 0xF0) `shiftR` 4 of
    0x8 -> chan $ NoteOff         (fromIntegral d1) (fromIntegral d2)
    0x9 -> chan $ NoteOn          (fromIntegral d1) (fromIntegral d2)
    0xA -> chan $ KeyPressure     (fromIntegral d1) (fromIntegral d2)
    0xB -> chan $ ControlChange   (fromIntegral d1) (fromIntegral d2)
    0xC -> chan $ ProgramChange   (fromIntegral d1)
    0xD -> chan $ ChannelPressure (fromIntegral d1)
    0xE -> chan $ PitchWheel      (fromIntegral $ d1 + d2 `shiftL` 8)
    _   -> Nothing
  where
    chan = Just . Channel (fromIntegral $ m .&. 0x0F)