]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - src/RMCA/Translator/Jack.hs
Hlint suggestions.
[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 --newEmptyMVar >>= takeMVar
70 Jack.waitForBreak
71 return ()
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 :: ( ReactiveValueAtomicUpdate toProcess [(Frames, RawMessage)] IO
78 , ReactiveValueAtomicUpdate board
79 (M.IntMap ([Note],[Message])) IO
80 , ReactiveValueRead tempo Tempo IO
81 , ReactiveValueAtomicUpdate layerConfs (M.IntMap LayerConf) IO
82 ) =>
83 IOTick
84 -> JMIDI.Port Jack.Input
85 -> JMIDI.Port Jack.Output
86 -> toProcess
87 -> board
88 -> tempo
89 -> layerConfs
90 -> Jack.NFrames
91 -> Sync.ExceptionalT E.Errno IO ()
92 jackCallBack tc input output toProcessRV boardQueue tempoRV layerMapRV
93 nframes@(Jack.NFrames nframesInt') = do
94 let inMIDIRV = inMIDIEvent input nframes
95 outMIDIRV = outMIDIEvent output nframes
96 nframesInt = fromIntegral nframesInt' :: Int
97 Trans.lift $ do
98 tempo <- reactiveValueRead tempoRV
99 inMIDI <- reactiveValueRead inMIDIRV
100 let (unchangedMessages,toBeTreatedMessages) =
101 break (\(_,m) -> fromMaybe False $ do
102 mess <- fromRawMessage m
103 return (isInstrument mess || isVolume mess)) inMIDI
104 reactiveValueAppend toProcessRV unchangedMessages
105 let (volume,instruments) = break (isInstrument . snd) $
106 map (second (fromJust . fromRawMessage)) toBeTreatedMessages
107 mapM_ ((\(Volume c v) -> reactiveValueUpdate layerMapRV
108 (M.adjust (\(st,d,s) -> (st,d,s { volume = v }))
109 (fromChannel c))) . snd) volume
110 mapM_ ((\(Instrument c p) -> reactiveValueUpdate layerMapRV
111 (M.adjust (\(st,d,s) -> (st,d,s { instrument = fromProgram p }))
112 (fromChannel c))) . snd) instruments
113 concat . toList . gatherMessages tempo nframesInt <$>
114 reactiveValueEmpty boardQueue >>=
115 reactiveValueAppend toProcessRV
116 (go, old') <- schedule nframesInt <$> reactiveValueRead toProcessRV
117 let old = map (first (+ (- nframesInt))) old'
118 --putStrLn ("Out: " ++ show (map fst go))
119 reactiveValueWrite outMIDIRV go
120 reactiveValueWrite toProcessRV old
121 tickIOTick tc
122 --------------