]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/Translator/Jack.hs
Removed debug.
[tmp/julm/arpeggigon.git] / 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 Control.Concurrent.MVar
10 import qualified Control.Monad.Exception.Synchronous as Sync
11 import qualified Control.Monad.Trans.Class as Trans
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 RMCA.Auxiliary
17 import RMCA.Global.Clock
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 rmcaName :: String
26 rmcaName = "RMCA"
27
28 inPortName :: String
29 inPortName = "input"
30
31 outPortName :: String
32 outPortName = "output"
33
34 -- Starts a default client with an input and an output port. Doesn't
35 -- do anything as such.
36 jackSetup :: (ReactiveValueReadWrite board
37 (M.IntMap ([Note],[Message])) IO
38 , ReactiveValueRead tempo Tempo IO) =>
39 TickableClock
40 -> board
41 -> tempo
42 -> IO ()
43 jackSetup tc boardQueue tempoRV = 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 tc input output
49 toProcessRV boardQueue tempoRV) $
50 Jack.withActivation client $ Trans.lift $ do
51 putStrLn $ "Started " ++ rmcaName ++ " JACK client."
52 --newEmptyMVar >>= takeMVar
53 Jack.waitForBreak
54 return ()
55
56 -- The callback function. It pumps value out of the input port, mix
57 -- them with value coming from the machine itself and stuff them into
58 -- the output port. When this function is not running, events are
59 -- processed.
60 jackCallBack :: ( ReactiveValueReadWrite toProcess [(Frames, RawMessage)] IO
61 , ReactiveValueReadWrite board
62 (M.IntMap ([Note],[Message])) IO
63 , ReactiveValueRead tempo Tempo IO) =>
64 TickableClock
65 -> JMIDI.Port Jack.Input
66 -> JMIDI.Port Jack.Output
67 -> toProcess
68 -> board
69 -> tempo
70 -> Jack.NFrames
71 -> Sync.ExceptionalT E.Errno IO ()
72 jackCallBack tc input output toProcessRV boardQueue tempoRV
73 nframes@(Jack.NFrames nframesInt') = do
74 let inMIDIRV = inMIDIEvent input nframes
75 outMIDIRV = outMIDIEvent output nframes
76 nframesInt = fromIntegral nframesInt' :: Int
77 Trans.lift $ do
78 tempo <- reactiveValueRead tempoRV
79 concat . toList . gatherMessages tempo nframesInt <$>
80 reactiveValueRead boardQueue >>= \bq ->
81 reactiveValueAppend toProcessRV bq >> putStrLn ("BoardQueue: " ++ show (map fst bq))
82 reactiveValueEmpty boardQueue
83 (go, old') <- schedule nframesInt <$> reactiveValueRead toProcessRV
84 let old = map (first (+ (- nframesInt))) old'
85 putStrLn ("Out: " ++ show (map fst go))
86 reactiveValueWrite outMIDIRV go
87 reactiveValueWrite toProcessRV old
88 tickClock tc
89 --------------