]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/Translator/Jack.hs
Removed useless dependency.
[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 qualified Control.Monad.Exception.Synchronous as Sync
10 import qualified Control.Monad.Trans.Class as Trans
11 import Data.CBRef
12 import Data.Foldable
13 import qualified Data.IntMap as M
14 import Data.Maybe
15 import Data.ReactiveValue
16 import qualified Foreign.C.Error as E
17 import Graphics.UI.Gtk
18 import RMCA.IOClockworks
19 import RMCA.Layer.LayerConf
20 import RMCA.ReactiveValueAtomicUpdate
21 import RMCA.Semantics
22 import RMCA.Translator.Message
23 import RMCA.Translator.RV
24 import RMCA.Translator.Translator
25 import qualified Sound.JACK as Jack
26 import qualified Sound.JACK.Exception as JackExc
27 import qualified Sound.JACK.MIDI as JMIDI
28
29 rmcaName :: String
30 rmcaName = "RMCA"
31
32 inPortName :: String
33 inPortName = "input"
34
35 outPortName :: String
36 outPortName = "output"
37
38 handleErrorJack :: JackExc.All -> IO ()
39 handleErrorJack _ = postGUIAsync $ do
40 diag <- messageDialogNewWithMarkup
41 Nothing [] MessageError ButtonsClose
42 "No running instance of Jack could be found!"
43 widgetShow diag
44 resp <- dialogRun diag
45 print resp
46 mainQuit
47
48 -- Starts a default client with an input and an output port. Doesn't
49 -- do anything as such.
50 jackSetup :: (ReactiveValueAtomicUpdate board
51 (M.IntMap ([Note],[Message])) IO
52 , ReactiveValueRead tempo Tempo IO
53 , ReactiveValueAtomicUpdate layerConfs (M.IntMap LayerConf) IO
54 ) =>
55 IOTick
56 -> board
57 -> tempo
58 -> layerConfs
59 -> IO ()
60 jackSetup tc boardQueue tempoRV layerMapRV = Sync.resolveT handleErrorJack $ do
61 toProcessRV <- Trans.lift $ newCBRef []
62 Jack.withClientDefault rmcaName $ \client ->
63 Jack.withPort client outPortName $ \output ->
64 Jack.withPort client inPortName $ \input ->
65 Jack.withProcess client (jackCallBack tc input output
66 toProcessRV boardQueue tempoRV layerMapRV) $
67 Jack.withActivation client $ Trans.lift $ do
68 putStrLn $ "Started " ++ rmcaName ++ " JACK client."
69 Jack.waitForBreak
70 return ()
71
72 -- The callback function. It pumps value out of the input port, mix
73 -- them with value coming from the machine itself and stuff them into
74 -- the output port. When this function is not running, events are
75 -- processed.
76 jackCallBack :: ( ReactiveValueAtomicUpdate toProcess [(Frames, RawMessage)] IO
77 , ReactiveValueAtomicUpdate board
78 (M.IntMap ([Note],[Message])) IO
79 , ReactiveValueRead tempo Tempo IO
80 , ReactiveValueAtomicUpdate layerConfs (M.IntMap LayerConf) IO
81 ) =>
82 IOTick
83 -> JMIDI.Port Jack.Input
84 -> JMIDI.Port Jack.Output
85 -> toProcess
86 -> board
87 -> tempo
88 -> layerConfs
89 -> Jack.NFrames
90 -> Sync.ExceptionalT E.Errno IO ()
91 jackCallBack tc input output toProcessRV boardQueue tempoRV layerMapRV
92 nframes@(Jack.NFrames nframesInt') = do
93 let inMIDIRV = inMIDIEvent input nframes
94 outMIDIRV = outMIDIEvent output nframes
95 nframesInt = fromIntegral nframesInt' :: Int
96 Trans.lift $ do
97 tempo <- reactiveValueRead tempoRV
98 inMIDI <- reactiveValueRead inMIDIRV
99 let (unchangedMessages,toBeTreatedMessages) =
100 break (\(_,m) -> fromMaybe False $ do
101 mess <- fromRawMessage m
102 return (isInstrument mess || isVolume mess)) inMIDI
103 reactiveValueAppend toProcessRV unchangedMessages
104 let (volume,instruments) = break (isInstrument . snd) $
105 map (second (fromJust . fromRawMessage)) toBeTreatedMessages
106 mapM_ ((\(Volume c v) -> reactiveValueUpdate layerMapRV
107 (M.adjust (\(st,d,s) -> (st,d,s { volume = v }))
108 (fromChannel c))) . snd) volume
109 mapM_ ((\(Instrument c p) -> reactiveValueUpdate layerMapRV
110 (M.adjust (\(st,d,s) -> (st,d,s { instrument = fromProgram p }))
111 (fromChannel c))) . snd) instruments
112 concat . toList . gatherMessages tempo nframesInt <$>
113 reactiveValueEmpty boardQueue >>=
114 reactiveValueAppend toProcessRV
115 (go, old') <- schedule nframesInt <$> reactiveValueRead toProcessRV
116 let old = map (first (+ (- nframesInt))) old'
117 --putStrLn ("Out: " ++ show (map fst go))
118 reactiveValueWrite outMIDIRV go
119 reactiveValueWrite toProcessRV old
120 tickIOTick tc
121 --------------