src/RMCA/Translator/Jack.hs

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