RMCA/Translator/RV.hs

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