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