RCMA/Translator/Jack.hs

   1 {-# LANGUAGE Arrows, PartialTypeSignatures #-}
   2
   3 -- Contains all the information and functions necessary to run a Jack
   4 -- port and exchange information through reactive values and Yampa.
   5 module RCMA.Translator.Jack where
   6
   7 import           Control.Applicative                 ((<**>))
   8 import qualified Control.Monad.Exception.Synchronous as Sync
   9 import qualified Control.Monad.Trans.Class           as Trans
  10 import qualified Data.Bifunctor                      as BF
  11 import           Data.CBMVar
  12 import qualified Data.EventList.Absolute.TimeBody    as EventListAbs
  13 import           Data.ReactiveValue
  14 import qualified Foreign.C.Error                     as E
  15 import           Hails.Yampa
  16 import           RCMA.Semantics
  17 import           RCMA.Translator.Filter
  18 import           RCMA.Translator.Message
  19 import           RCMA.Translator.RV
  20 import           RCMA.Translator.Translator
  21 import qualified Sound.JACK                          as Jack
  22 import qualified Sound.JACK.MIDI                     as JMIDI
  23
  24 rcmaName :: String
  25 rcmaName = "RCMA"
  26
  27 inPortName :: String
  28 inPortName = "input"
  29
  30 outPortName :: String
  31 outPortName = "output"
  32
  33 -- Starts a default client with an input and an output port. Doesn't
  34 -- do anything as such.
  35 --jackSetup :: _
  36 jackSetup boardInRV = Jack.handleExceptions $ do
  37   toProcessRV <- Trans.lift $ toProcess <$> newCBMVar []
  38   Jack.withClientDefault rcmaName $ \client ->
  39     Jack.withPort client outPortName $ \output ->
  40     Jack.withPort client inPortName  $ \input ->
  41     jackRun client input output
  42     (jackCallBack client input output toProcessRV boardInRV)
  43
  44 -- Loop that does nothing except setting up a callback function
  45 -- (called when Jack is ready to take new inputs).
  46 {-jackRun :: Jack.Client
  47         -> JMIDI.Port Jack.Input
  48         -> JMIDI.Port Jack.Output
  49         -> _
  50         -> _-}
  51 jackRun client input output callback =
  52   Jack.withProcess client callback $ do
  53   Trans.lift $ putStrLn $ "Started " ++ rcmaName
  54   Trans.lift $ Jack.waitForBreak
  55
  56 defaultTempo :: Tempo
  57 defaultTempo = 96
  58
  59 -- The callback function. It pumps value out of the input port, mix
  60 -- them with value coming from the machine itself and stuff them into
  61 -- the output port. When this function is not running, events are
  62 -- processed.
  63 jackCallBack :: Jack.Client
  64              -> JMIDI.Port Jack.Input
  65              -> JMIDI.Port Jack.Output
  66              -> ReactiveFieldReadWrite IO [(Frames, RawMessage)]
  67              -> ReactiveFieldRead IO (LTempo, Int, [(Frames, RawMessage)])
  68              -> Jack.NFrames
  69              -> Sync.ExceptionalT E.Errno IO ()
  70 jackCallBack client input output toProcessRV boardInRV
  71   nframes@(Jack.NFrames nframesInt') = do
  72   let inMIDIRV = inMIDIEvent input nframes
  73       outMIDIRV = outMIDIEvent output nframes
  74       nframesInt = fromIntegral nframesInt' :: Int
  75   -- This gets the sample rate of the client and the last frame number
  76   -- it processed. We then use it to calculate the current absolute time
  77   sr <- Trans.lift $ Jack.getSampleRate client
  78   (Jack.NFrames lframeInt) <- Trans.lift $ Jack.lastFrameTime client
  79   -- We write the content of the input buffer to the input of a
  80   -- translation signal function.
  81   -- /!\ Should be moved elsewhere
  82   (inRaw, outPure) <- Trans.lift $ yampaReactiveDual [] readMessages
  83   Trans.lift (inMIDIRV =:> inRaw)
  84   (tempo, chan, boardIn') <- Trans.lift $ reactiveValueRead boardInRV
  85   let boardIn = ([],[],boardIn')
  86   outMIDI <- Trans.lift $ reactiveValueRead outPure
  87   -- We translate all signals to be sent into low level signals and
  88   -- write them to the output buffer.
  89   (inPure, outRaw) <- Trans.lift $ yampaReactiveDual
  90                       (defaultTempo, sr, chan, ([],[],[])) gatherMessages
  91   -- This should all go in its own IO action
  92   Trans.lift $ reactiveValueWrite inPure
  93                (tempo, sr, chan, (boardIn `mappend` outMIDI))
  94   Trans.lift (reactiveValueRead outRaw <**>
  95               (mappend <$> reactiveValueRead toProcessRV) >>=
  96               reactiveValueWrite toProcessRV)
  97   Trans.lift $ do
  98     (go, old') <- schedule nframesInt <$> reactiveValueRead toProcessRV
  99     let old = map (BF.first (+ (- nframesInt))) old'
 100     reactiveValueWrite outMIDIRV go
 101     reactiveValueWrite toProcessRV old
 102   --------------
 103   return ()