]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - RMCA/Translator/Jack.hs
Compiles but crashes.
[tmp/julm/arpeggigon.git] / RMCA / Translator / Jack.hs
1 {-# LANGUAGE FlexibleContexts #-}
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.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
12 import Data.CBMVar
13 import qualified Data.EventList.Absolute.TimeBody as EventListAbs
14 import Data.ReactiveValue
15 import qualified Foreign.C.Error as E
16 import Hails.Yampa
17 import RMCA.Auxiliary.RV
18 import RMCA.Semantics
19 import RMCA.Translator.Filter
20 import RMCA.Translator.Message
21 import RMCA.Translator.RV
22 import RMCA.Translator.Translator
23 import qualified Sound.JACK as Jack
24 import qualified Sound.JACK.Exception as JExc
25 import qualified Sound.JACK.MIDI as JMIDI
26
27 import Debug.Trace
28
29 rmcaName :: String
30 rmcaName = "RMCA"
31
32 inPortName :: String
33 inPortName = "input"
34
35 outPortName :: String
36 outPortName = "output"
37
38 -- Starts a default client with an input and an output port. Doesn't
39 -- do anything as such.
40 jackSetup :: ( ReactiveValueRead tempo LTempo IO
41 , ReactiveValueRead channel Int IO
42 , ReactiveValueReadWrite board [Note] IO) =>
43 tempo
44 -> channel
45 -> board
46 -> IO ()
47 jackSetup tempoRV chanRV boardInRV = Jack.handleExceptions $ do
48 toProcessRV <- Trans.lift $ toProcess <$> newCBMVar []
49 Jack.withClientDefault rmcaName $ \client ->
50 Jack.withPort client outPortName $ \output ->
51 Jack.withPort client inPortName $ \input ->
52 Jack.withProcess client (jackCallBack client input output
53 toProcessRV tempoRV chanRV boardInRV) $
54 Jack.withActivation client $ Trans.lift $ do
55 putStrLn $ "Started " ++ rmcaName ++ " JACK client."
56 Jack.waitForBreak
57
58 {-
59 -- Loop that does nothing except setting up a callback function
60 -- (called when Jack is ready to take new inputs).
61 jackRun :: (JExc.ThrowsErrno e) =>
62 Jack.Client
63 -> (Jack.NFrames -> Sync.ExceptionalT E.Errno IO ())
64 -> Sync.ExceptionalT e IO ()
65 jackRun client callback =
66 Jack.withProcess client callback $ do
67 Trans.lift $ putStrLn $ "Startedbbb " ++ rmcaName
68 Trans.lift $ Jack.waitForBreak
69 -}
70 defaultTempo :: Tempo
71 defaultTempo = 96
72
73 -- The callback function. It pumps value out of the input port, mix
74 -- them with value coming from the machine itself and stuff them into
75 -- the output port. When this function is not running, events are
76 -- processed.
77 jackCallBack :: ( ReactiveValueReadWrite toProcess [(Frames, RawMessage)] IO
78 , ReactiveValueRead tempo LTempo IO
79 , ReactiveValueRead channel Int IO
80 , ReactiveValueReadWrite board [Note] IO) =>
81 Jack.Client
82 -> JMIDI.Port Jack.Input
83 -> JMIDI.Port Jack.Output
84 -> toProcess
85 -> tempo
86 -> channel
87 -> board
88 -> Jack.NFrames
89 -> Sync.ExceptionalT E.Errno IO ()
90 jackCallBack client input output toProcessRV tempoRV chanRV outBoard
91 nframes@(Jack.NFrames nframesInt') = do
92 let inMIDIRV = inMIDIEvent input nframes
93 outMIDIRV = outMIDIEvent output nframes
94 nframesInt = fromIntegral nframesInt' :: Int
95 -- This gets the sample rate of the client and the last frame number
96 -- it processed. We then use it to calculate the current absolute time
97 sr <- Trans.lift $ Jack.getSampleRate client
98 (Jack.NFrames lframeInt) <- Trans.lift $ Jack.lastFrameTime client
99 --Trans.lift (reactiveValueRead inMIDIRV >>= (print . map (fst)))
100 -- We write the content of the input buffer to the input of a
101 -- translation signal function.
102 -- /!\ Should maybe be moved elsewhere
103 (inRaw, outPure) <- Trans.lift $ yampaReactiveDual [] readMessages
104 Trans.lift (inMIDIRV =:> inRaw)
105 tempo <- Trans.lift $ reactiveValueRead tempoRV
106 chan <- Trans.lift $ reactiveValueRead chanRV
107 boardIn' <- Trans.lift $ reactiveValueRead outBoard
108 Trans.lift $ emptyRW outBoard
109 let boardIn = (zip (repeat 0) boardIn',[],[])
110 outMIDI <- Trans.lift $ reactiveValueRead outPure
111 -- We translate all signals to be sent into low level signals and
112 -- write them to the output buffer.
113 (inPure, outRaw) <- Trans.lift $ yampaReactiveDual
114 (defaultTempo, sr, chan, ([],[],[])) gatherMessages
115 -- This should all go in its own IO action
116 Trans.lift $ do
117 reactiveValueWrite inPure (tempo, sr, chan, boardIn `mappend` outMIDI)
118 reactiveValueRead outRaw <**>
119 (mappend <$> reactiveValueRead toProcessRV) >>=
120 reactiveValueWrite toProcessRV
121 --map fst <$> reactiveValueRead toProcessRV >>= print . ("toProcess " ++) . show
122 (go, old') <- schedule nframesInt <$> reactiveValueRead toProcessRV
123 let old = map (BF.first (+ (- nframesInt))) old'
124 reactiveValueWrite outMIDIRV go
125 reactiveValueWrite toProcessRV old
126 --------------