1 {-# LANGUAGE Arrows #-}
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 ( jackSetup
8 import Control.Applicative ((<**>))
9 import qualified Control.Monad.Exception.Synchronous as Sync
10 import qualified Control.Monad.Trans.Class as Trans
11 import qualified Data.Bifunctor as BF
13 import qualified Data.EventList.Absolute.TimeBody as EventListAbs
14 import Data.ReactiveValue
15 import qualified Foreign.C.Error as E
18 import RCMA.Translator.Filter
19 import RCMA.Translator.Message
20 import RCMA.Translator.RV
21 import RCMA.Translator.Translator
22 import qualified Sound.JACK as Jack
23 import qualified Sound.JACK.Exception as JExc
24 import qualified Sound.JACK.MIDI as JMIDI
35 outPortName = "output"
37 -- Starts a default client with an input and an output port. Doesn't
38 -- do anything as such.
39 jackSetup :: ReactiveFieldRead IO (LTempo, Int, [Note])
41 jackSetup boardInRV = Jack.handleExceptions $ do
42 toProcessRV <- Trans.lift $ toProcess <$> newCBMVar []
43 Jack.withClientDefault rcmaName $ \client ->
44 Jack.withPort client outPortName $ \output ->
45 Jack.withPort client inPortName $ \input ->
46 Jack.withProcess client (jackCallBack client input output
47 toProcessRV boardInRV) $ do
48 Trans.lift $ putStrLn $ "Started " ++ rcmaName
49 Trans.lift $ Jack.waitForBreak
52 -- Loop that does nothing except setting up a callback function
53 -- (called when Jack is ready to take new inputs).
54 jackRun :: (JExc.ThrowsErrno e) =>
56 -> (Jack.NFrames -> Sync.ExceptionalT E.Errno IO ())
57 -> Sync.ExceptionalT e IO ()
58 jackRun client callback =
59 Jack.withProcess client callback $ do
60 Trans.lift $ putStrLn $ "Startedbbb " ++ rcmaName
61 Trans.lift $ Jack.waitForBreak
66 -- The callback function. It pumps value out of the input port, mix
67 -- them with value coming from the machine itself and stuff them into
68 -- the output port. When this function is not running, events are
70 jackCallBack :: Jack.Client
71 -> JMIDI.Port Jack.Input
72 -> JMIDI.Port Jack.Output
73 -> ReactiveFieldReadWrite IO [(Frames, RawMessage)]
74 -> ReactiveFieldRead IO (LTempo, Int, [Note])
76 -> Sync.ExceptionalT E.Errno IO ()
77 jackCallBack client input output toProcessRV boardInRV
78 nframes@(Jack.NFrames nframesInt') = do
79 let inMIDIRV = inMIDIEvent input nframes
80 outMIDIRV = outMIDIEvent output nframes
81 nframesInt = fromIntegral nframesInt' :: Int
82 -- This gets the sample rate of the client and the last frame number
83 -- it processed. We then use it to calculate the current absolute time
84 sr <- Trans.lift $ Jack.getSampleRate client
85 (Jack.NFrames lframeInt) <- Trans.lift $ Jack.lastFrameTime client
86 -- We write the content of the input buffer to the input of a
87 -- translation signal function.
88 -- /!\ Should maybe be moved elsewhere
89 (inRaw, outPure) <- Trans.lift $ yampaReactiveDual [] readMessages
90 Trans.lift (inMIDIRV =:> inRaw)
91 (tempo, chan, boardIn') <- Trans.lift $ reactiveValueRead boardInRV
92 let boardIn = (zip (repeat 0) boardIn',[],[])
93 outMIDI <- Trans.lift $ reactiveValueRead outPure
94 -- We translate all signals to be sent into low level signals and
95 -- write them to the output buffer.
96 (inPure, outRaw) <- Trans.lift $ yampaReactiveDual
97 (defaultTempo, sr, chan, ([],[],[])) gatherMessages
98 -- This should all go in its own IO action
100 reactiveValueWrite inPure (tempo, sr, chan, (boardIn `mappend` outMIDI))
101 reactiveValueRead outRaw <**>
102 (mappend <$> reactiveValueRead toProcessRV) >>=
103 reactiveValueWrite toProcessRV
104 (go, old') <- schedule nframesInt <$> reactiveValueRead toProcessRV
105 let old = map (BF.first (+ (- nframesInt))) old'
106 reactiveValueWrite outMIDIRV go
107 reactiveValueWrite toProcessRV old