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 qualified Control.Monad.Exception.Synchronous as Sync
  10 import qualified Control.Monad.Trans.Class           as Trans
  11 import           Data.Foldable
  12 import qualified Data.IntMap                         as M
  13 import           Data.ReactiveValue
  14 import qualified Foreign.C.Error                     as E
  15 import           RMCA.Auxiliary
  16 import           RMCA.Semantics
  17 import           RMCA.Translator.Message
  18 import           RMCA.Translator.RV
  19 import           RMCA.Translator.Translator
  20 import qualified Sound.JACK                          as Jack
  21 import qualified Sound.JACK.MIDI                     as JMIDI
  22
  23 rmcaName :: String
  24 rmcaName = "RMCA"
  25
  26 inPortName :: String
  27 inPortName = "input"
  28
  29 outPortName :: String
  30 outPortName = "output"
  31
  32 -- Starts a default client with an input and an output port. Doesn't
  33 -- do anything as such.
  34 jackSetup :: (ReactiveValueReadWrite board
  35               (M.IntMap ([Note],[Message])) IO
  36              , ReactiveValueRead tempo Tempo IO) =>
  37              board
  38           -> tempo
  39           -> IO ()
  40 jackSetup boardQueue tempoRV = Jack.handleExceptions $ do
  41   toProcessRV <- Trans.lift $ newCBMVarRW []
  42   Jack.withClientDefault rmcaName $ \client ->
  43     Jack.withPort client outPortName $ \output ->
  44     Jack.withPort client inPortName  $ \input ->
  45     Jack.withProcess client (jackCallBack input output
  46                               toProcessRV boardQueue tempoRV) $
  47     Jack.withActivation client $ Trans.lift $ do
  48     putStrLn $ "Started " ++ rmcaName ++ " JACK client."
  49     Jack.waitForBreak
  50
  51 -- The callback function. It pumps value out of the input port, mix
  52 -- them with value coming from the machine itself and stuff them into
  53 -- the output port. When this function is not running, events are
  54 -- processed.
  55 jackCallBack :: ( ReactiveValueReadWrite toProcess [(Frames, RawMessage)] IO
  56                 , ReactiveValueReadWrite board
  57                   (M.IntMap ([Note],[Message])) IO
  58                 , ReactiveValueRead tempo Tempo IO) =>
  59                 JMIDI.Port Jack.Input
  60              -> JMIDI.Port Jack.Output
  61              -> toProcess
  62              -> board
  63              -> tempo
  64              -> Jack.NFrames
  65              -> Sync.ExceptionalT E.Errno IO ()
  66 jackCallBack input output toProcessRV boardQueue tempoRV
  67   nframes@(Jack.NFrames nframesInt') = do
  68   let inMIDIRV = inMIDIEvent input nframes
  69       outMIDIRV = outMIDIEvent output nframes
  70       nframesInt = fromIntegral nframesInt' :: Int
  71   Trans.lift $ do
  72     tempo <- reactiveValueRead tempoRV
  73     concat . toList . gatherMessages tempo nframesInt <$>
  74       reactiveValueRead boardQueue >>= \bq ->
  75       reactiveValueAppend toProcessRV bq >> putStrLn ("BoardQueue: " ++ show (map fst bq))
  76     reactiveValueEmpty  boardQueue
  77     (go, old') <- schedule nframesInt <$> reactiveValueRead toProcessRV
  78     let old = map (first (+ (- nframesInt))) old'
  79     putStrLn ("Out: " ++ show (map fst go))
  80     reactiveValueWrite outMIDIRV go
  81     reactiveValueWrite toProcessRV old
  82   --------------