src/RMCA/Translator/RV.hs

   1 {-# LANGUAGE ScopedTypeVariables #-}
   2
   3 module RMCA.Translator.RV where
   4
   5 import           Control.Monad.Exception.Synchronous (ExceptionalT, resolveT)
   6 import qualified Data.Bifunctor                      as BF
   7 import           Data.CBMVar
   8 import qualified Data.EventList.Absolute.TimeBody    as EventListAbs
   9 import qualified Data.List                           as L
  10 import           Data.Ord                            (comparing)
  11 import           Data.ReactiveValue
  12 import           RMCA.Translator.Message
  13 import qualified Sound.JACK                          as Jack
  14 import           Sound.JACK.Exception                (All, toStringWithHead)
  15 import qualified Sound.JACK.MIDI                     as JMIDI
  16 import qualified System.IO                           as IO
  17
  18 handleError :: (Monoid a) => ExceptionalT All IO a -> IO a
  19 handleError = resolveT $ \e -> do
  20   IO.hPutStrLn IO.stderr $ toStringWithHead e
  21   return mempty
  22
  23 inMIDIEvent :: JMIDI.Port Jack.Input
  24             -> Jack.NFrames
  25             -> ReactiveFieldRead IO [(Frames,RawMessage)]
  26 inMIDIEvent input nframes = ReactiveFieldRead getter notifier
  27   where getter :: IO [(Frames, RawMessage)]
  28         getter = handleError $ transform <$>
  29                  JMIDI.readEventsFromPort input nframes
  30
  31         transform :: EventListAbs.T Jack.NFrames t -> [(Frames, t)]
  32         transform = map (BF.first (\(Jack.NFrames n) -> fromIntegral n)) .
  33                     EventListAbs.toPairList
  34
  35         notifier :: IO () -> IO ()
  36         notifier = id
  37
  38 outMIDIEvent :: JMIDI.Port Jack.Output
  39              -> Jack.NFrames
  40              -> ReactiveFieldWrite IO [(Frames, RawMessage)]
  41 outMIDIEvent output nframes@(Jack.NFrames nframesInt') =
  42   ReactiveFieldWrite setter
  43   where setter :: [(Frames, RawMessage)] -> IO ()
  44         setter = handleError .
  45                  JMIDI.writeEventsToPort output nframes . transform
  46         -- Doesn't assume the list is sorted or small enough. For
  47         -- large size buffer, this might cause performance issue. All
  48         -- the unprocessed events are lost, which is unfortunate…
  49         transform :: [(Frames, RawMessage)]
  50                   -> EventListAbs.T Jack.NFrames RawMessage
  51         transform = EventListAbs.fromPairList .
  52                     map (BF.first (Jack.NFrames . fromIntegral)) .
  53                     takeWhile ((< nframesInt) . fst) . L.sortBy (comparing fst)
  54         nframesInt = fromIntegral nframesInt'
  55
  56 toProcess :: CBMVar [(Frames, RawMessage)]
  57           -> ReactiveFieldReadWrite IO [(Frames, RawMessage)]
  58 toProcess mvar = ReactiveFieldReadWrite setter getter notifier
  59   where setter :: [(Frames, RawMessage)] -> IO ()
  60         setter = writeCBMVar mvar
  61         getter :: IO [(Frames, RawMessage)]
  62         getter = readCBMVar mvar
  63         notifier :: IO () -> IO ()
  64         notifier = installCallbackCBMVar mvar