RCMA/Translator/RV.hs

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