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 qualified Control.Monad.Exception.Synchronous as Sync
   9 import qualified Control.Monad.Trans.Class           as Trans
  10 import qualified Data.Bifunctor                      as BF
  11 import           Data.CBMVar
  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           Hails.Yampa
  17 import           RMCA.Auxiliary
  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 import           Control.Arrow
  26 import           Debug.Trace
  27
  28 rmcaName :: String
  29 rmcaName = "RMCA"
  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 :: (ReactiveValueReadWrite board
  40               (M.IntMap ([(LTempo,Note)],[Message])) IO) =>
  41              board
  42           -> IO ()
  43 jackSetup boardQueue = 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 client input output
  49                               toProcessRV boardQueue) $
  50     Jack.withActivation client $ Trans.lift $ do
  51     putStrLn $ "Started " ++ rmcaName ++ " JACK client."
  52     Jack.waitForBreak
  53
  54 defaultTempo :: Tempo
  55 defaultTempo = 120
  56
  57 -- The callback function. It pumps value out of the input port, mix
  58 -- them with value coming from the machine itself and stuff them into
  59 -- the output port. When this function is not running, events are
  60 -- processed.
  61 jackCallBack :: ( ReactiveValueReadWrite toProcess [(Frames, RawMessage)] IO
  62                 , ReactiveValueReadWrite board
  63                   (M.IntMap ([(LTempo,Note)],[Message])) IO) =>
  64                 Jack.Client
  65              -> JMIDI.Port Jack.Input
  66              -> JMIDI.Port Jack.Output
  67              -> toProcess
  68              -> board
  69              -> Jack.NFrames
  70              -> Sync.ExceptionalT E.Errno IO ()
  71 jackCallBack client input output toProcessRV boardQueue nframes@(Jack.NFrames nframesInt') = do
  72   let inMIDIRV = inMIDIEvent input nframes
  73       outMIDIRV = outMIDIEvent output nframes
  74       nframesInt = fromIntegral nframesInt' :: Int
  75   Trans.lift $ do
  76     concat . toList . gatherMessages nframesInt <$>
  77       reactiveValueRead boardQueue >>=
  78       reactiveValueAppend toProcessRV
  79     reactiveValueEmpty  boardQueue
  80     (go, old') <- schedule nframesInt <$> reactiveValueRead toProcessRV
  81     let old = map (BF.first (+ (- nframesInt))) old'
  82     print $ map fst go
  83     reactiveValueWrite outMIDIRV go
  84     reactiveValueWrite toProcessRV old
  85   --------------