RMCA/Translator/Jack.hs

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