RCMA/Translator/Jack.hs

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