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