src/RMCA/Translator/Jack.hs

   1 {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}
   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.Arrow
   9 import           Control.Concurrent.MVar
  10 import qualified Control.Monad.Exception.Synchronous as Sync
  11 import qualified Control.Monad.Trans.Class           as Trans
  12 import           Data.Foldable
  13 import qualified Data.IntMap                         as M
  14 import           Data.ReactiveValue
  15 import qualified Foreign.C.Error                     as E
  16 import           RMCA.Auxiliary
  17 import           RMCA.Global.Clock
  18 import           RMCA.Semantics
  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 :: (ReactiveValueReadWrite board
  37               (M.IntMap ([Note],[Message])) IO
  38              , ReactiveValueRead tempo Tempo IO) =>
  39              TickableClock
  40           -> board
  41           -> tempo
  42           -> IO ()
  43 jackSetup tc boardQueue tempoRV = Jack.handleExceptions $ do
  44   toProcessRV <- Trans.lift $ newCBMVarRW []
  45   Jack.withClientDefault rmcaName $ \client ->
  46     Jack.withPort client outPortName $ \output ->
  47     Jack.withPort client inPortName  $ \input ->
  48     Jack.withProcess client (jackCallBack tc input output
  49                               toProcessRV boardQueue tempoRV) $
  50     Jack.withActivation client $ Trans.lift $ do
  51     putStrLn $ "Started " ++ rmcaName ++ " JACK client."
  52     --newEmptyMVar >>= takeMVar
  53     Jack.waitForBreak
  54     return ()
  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 :: ( ReactiveValueReadWrite toProcess [(Frames, RawMessage)] IO
  61                 , ReactiveValueReadWrite board
  62                   (M.IntMap ([Note],[Message])) IO
  63                 , ReactiveValueRead tempo Tempo IO) =>
  64                 TickableClock
  65              -> JMIDI.Port Jack.Input
  66              -> JMIDI.Port Jack.Output
  67              -> toProcess
  68              -> board
  69              -> tempo
  70              -> Jack.NFrames
  71              -> Sync.ExceptionalT E.Errno IO ()
  72 jackCallBack tc input output toProcessRV boardQueue tempoRV
  73   nframes@(Jack.NFrames nframesInt') = do
  74   let inMIDIRV = inMIDIEvent input nframes
  75       outMIDIRV = outMIDIEvent output nframes
  76       nframesInt = fromIntegral nframesInt' :: Int
  77   Trans.lift $ do
  78     tempo <- reactiveValueRead tempoRV
  79     concat . toList . gatherMessages tempo nframesInt <$>
  80       reactiveValueRead boardQueue >>= \bq ->
  81       reactiveValueAppend toProcessRV bq >> putStrLn ("BoardQueue: " ++ show (map fst bq))
  82     reactiveValueEmpty  boardQueue
  83     (go, old') <- schedule nframesInt <$> reactiveValueRead toProcessRV
  84     let old = map (first (+ (- nframesInt))) old'
  85     putStrLn ("Out: " ++ show (map fst go))
  86     reactiveValueWrite outMIDIRV go
  87     reactiveValueWrite toProcessRV old
  88     tickClock tc
  89   --------------