1 {-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}
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
9 import qualified Control.Monad.Exception.Synchronous as Sync
10 import qualified Control.Monad.Trans.Class as Trans
12 import qualified Data.IntMap as M
13 import Data.ReactiveValue
14 import qualified Foreign.C.Error as E
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
30 outPortName = "output"
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) =>
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."
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
55 jackCallBack :: ( ReactiveValueReadWrite toProcess [(Frames, RawMessage)] IO
56 , ReactiveValueReadWrite board
57 (M.IntMap ([Note],[Message])) IO
58 , ReactiveValueRead tempo Tempo IO) =>
60 -> JMIDI.Port Jack.Output
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
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