]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/Translator/Jack.hs
Rework on instruments.
[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 Graphics.UI.Gtk
17 import RMCA.Auxiliary
18 import RMCA.Global.Clock
19 import RMCA.Semantics
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 JackExc
25 import qualified Sound.JACK.MIDI as JMIDI
26
27 rmcaName :: String
28 rmcaName = "RMCA"
29
30 inPortName :: String
31 inPortName = "input"
32
33 outPortName :: String
34 outPortName = "output"
35
36 handleErrorJack :: JackExc.All -> IO ()
37 handleErrorJack _ = postGUIAsync $ do
38 diag <- messageDialogNewWithMarkup
39 Nothing [] MessageError ButtonsClose
40 "No running instance of Jack could be found!"
41 widgetShow diag
42 resp <- dialogRun diag
43 print resp
44 mainQuit
45
46 -- Starts a default client with an input and an output port. Doesn't
47 -- do anything as such.
48 jackSetup :: (ReactiveValueReadWrite board
49 (M.IntMap ([Note],[Message])) IO
50 , ReactiveValueRead tempo Tempo IO) =>
51 TickableClock
52 -> board
53 -> tempo
54 -> IO ()
55 jackSetup tc boardQueue tempoRV = Sync.resolveT handleErrorJack $ do
56 toProcessRV <- Trans.lift $ newCBMVarRW []
57 Jack.withClientDefault rmcaName $ \client ->
58 Jack.withPort client outPortName $ \output ->
59 Jack.withPort client inPortName $ \input ->
60 Jack.withProcess client (jackCallBack tc input output
61 toProcessRV boardQueue tempoRV) $
62 Jack.withActivation client $ Trans.lift $ do
63 putStrLn $ "Started " ++ rmcaName ++ " JACK client."
64 --newEmptyMVar >>= takeMVar
65 Jack.waitForBreak
66 return ()
67
68 -- The callback function. It pumps value out of the input port, mix
69 -- them with value coming from the machine itself and stuff them into
70 -- the output port. When this function is not running, events are
71 -- processed.
72 jackCallBack :: ( ReactiveValueReadWrite toProcess [(Frames, RawMessage)] IO
73 , ReactiveValueReadWrite board
74 (M.IntMap ([Note],[Message])) IO
75 , ReactiveValueRead tempo Tempo IO) =>
76 TickableClock
77 -> JMIDI.Port Jack.Input
78 -> JMIDI.Port Jack.Output
79 -> toProcess
80 -> board
81 -> tempo
82 -> Jack.NFrames
83 -> Sync.ExceptionalT E.Errno IO ()
84 jackCallBack tc input output toProcessRV boardQueue tempoRV
85 nframes@(Jack.NFrames nframesInt') = do
86 let inMIDIRV = inMIDIEvent input nframes
87 outMIDIRV = outMIDIEvent output nframes
88 nframesInt = fromIntegral nframesInt' :: Int
89 Trans.lift $ do
90 tempo <- reactiveValueRead tempoRV
91 concat . toList . gatherMessages tempo nframesInt <$>
92 reactiveValueRead boardQueue >>= \bq ->
93 reactiveValueAppend toProcessRV bq >> putStrLn ("BoardQueue: " ++ show (map fst bq))
94 reactiveValueEmpty boardQueue
95 (go, old') <- schedule nframesInt <$> reactiveValueRead toProcessRV
96 let old = map (first (+ (- nframesInt))) old'
97 putStrLn ("Out: " ++ show (map fst go))
98 reactiveValueWrite outMIDIRV go
99 reactiveValueWrite toProcessRV old
100 tickClock tc
101 --------------