RCMA/Translator/Jack.hs

   1 {-# LANGUAGE Arrows, PartialTypeSignatures #-}
   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 where
   6
   7 import           Control.Concurrent.MVar
   8 import qualified Control.Monad.Exception.Synchronous as Sync
   9 import qualified Control.Monad.Trans.Class           as Trans
  10 import qualified Data.EventList.Absolute.TimeBody    as EventListAbs
  11 import           Data.ReactiveValue
  12 import qualified Foreign.C.Error                     as E
  13 import           Hails.Yampa
  14 import           RCMA.Semantics
  15 import           RCMA.Translator.Message
  16 import           RCMA.Translator.RV
  17 import           RCMA.Translator.Translator
  18 import qualified Sound.JACK                          as Jack
  19 import qualified Sound.JACK.MIDI                     as JMIDI
  20
  21 rcmaName :: String
  22 rcmaName = "RCMA"
  23
  24 inPortName :: String
  25 inPortName = "input"
  26
  27 outPortName :: String
  28 outPortName = "output"
  29
  30 -- Starts a default client with an input and an output port. Doesn't
  31 -- do anything as such.
  32 --jackSetup :: _
  33 jackSetup boardInRV = Jack.handleExceptions $ do
  34   toProcessQueue <- Trans.lift $ toProcess <$> newMVar []
  35   Jack.withClientDefault rcmaName $ \client ->
  36     Jack.withPort client outPortName $ \output ->
  37     Jack.withPort client inPortName  $ \input ->
  38     jackRun client input output
  39     (jackCallBack client input output toProcessQueue boardInRV)
  40
  41 -- Loop that does nothing except setting up a callback function
  42 -- (called when Jack is ready to take new inputs).
  43 {-jackRun :: Jack.Client
  44         -> JMIDI.Port Jack.Input
  45         -> JMIDI.Port Jack.Output
  46         -> _
  47         -> _-}
  48 jackRun client input output callback =
  49   Jack.withProcess client callback $ do
  50   Trans.lift $ putStrLn $ "Started " ++ rcmaName
  51   Trans.lift $ Jack.waitForBreak
  52
  53 defaultTempo :: Tempo
  54 defaultTempo = 96
  55
  56 -- The callback function. It pumps value out of the input port, mix
  57 -- them with value coming from the machine itself and stuff them into
  58 -- the output port. When this function is not running, events are
  59 -- processed.
  60 jackCallBack :: Jack.Client
  61              -> JMIDI.Port Jack.Input
  62              -> JMIDI.Port Jack.Output
  63              -> ReactiveFieldReadWrite IO [(Frames, RawMessage)]
  64              -> ReactiveFieldRead IO (LTempo, Int, [(Frames, RawMessage)])
  65              -> Jack.NFrames
  66              -> Sync.ExceptionalT E.Errno IO ()
  67 jackCallBack client input output toProcessQueue boardInRV
  68   nframes@(Jack.NFrames nframesInt) = do
  69   let inMIDIRV = inMIDIEvent input nframes
  70       outMIDIRV = outMIDIEvent output nframes
  71   -- This gets the sample rate of the client and the last frame number
  72   -- it processed. We then use it to calculate the current absolute time
  73   sr <- Trans.lift $ Jack.getSampleRate client
  74   (Jack.NFrames lframeInt) <- Trans.lift $ Jack.lastFrameTime client
  75   -- We write the content of the input buffer to the input of a
  76   -- translation signal function.
  77   -- /!\ Should be moved elsewhere
  78   (inRaw, outPure) <- Trans.lift $ yampaReactiveDual [] readMessages
  79   Trans.lift (inMIDIRV =:> inRaw)
  80   (tempo, chan, boardIn') <- Trans.lift $ reactiveValueRead boardInRV
  81   let boardIn = ([],[],boardIn')
  82   outMIDI <- Trans.lift $ reactiveValueRead outPure
  83   -- We translate all signals to be sent into low level signals and
  84   -- write them to the output buffer.
  85   (inPure, outRaw) <- Trans.lift $ yampaReactiveDual
  86                       (defaultTempo, sr, chan, ([],[],[])) gatherMessages
  87   Trans.lift $ reactiveValueWrite inPure
  88                (tempo, sr, chan, (boardIn `mappend` outMIDI))
  89   Trans.lift (outRaw =:> outMIDIRV)
  90   return ()