]> Git — Sourcephile - tmp/julm/arpeggigon.git/blob - RMCA/Translator/RV.hs
Tile adding supported.
[tmp/julm/arpeggigon.git] / RMCA / Translator / RV.hs
1 {-# LANGUAGE ScopedTypeVariables #-}
2
3 module RMCA.Translator.RV where
4
5 import Control.Monad
6 import Control.Monad.Exception.Synchronous (ExceptionalT, resolveT)
7 import qualified Control.Monad.Trans.Class as Trans
8 import qualified Data.Bifunctor as BF
9 import Data.CBMVar
10 import qualified Data.EventList.Absolute.TimeBody as EventListAbs
11 import qualified Data.List as L
12 import Data.Ord (comparing)
13 import Data.ReactiveValue
14 import qualified Foreign.C.Error as E
15 import RMCA.Translator.Message
16 import qualified Sound.JACK as Jack
17 import Sound.JACK.Exception
18 ( All
19 , ThrowsErrno
20 , toStringWithHead
21 )
22 import qualified Sound.JACK.MIDI as JMIDI
23 import qualified System.IO as IO
24
25 import Debug.Trace
26
27 handleError :: (Monoid a) => ExceptionalT All IO a -> IO a
28 handleError = resolveT $ \e -> do
29 IO.hPutStrLn IO.stderr $ toStringWithHead e
30 return mempty
31
32 inMIDIEvent :: JMIDI.Port Jack.Input
33 -> Jack.NFrames
34 -> ReactiveFieldRead IO [(Frames,RawMessage)]
35 inMIDIEvent input nframes = ReactiveFieldRead getter notifier
36 where getter :: IO [(Frames, RawMessage)]
37 getter = handleError $ transform <$>
38 JMIDI.readEventsFromPort input nframes
39
40 transform :: EventListAbs.T Jack.NFrames t -> [(Frames, t)]
41 transform = map (BF.first (\(Jack.NFrames n) -> fromIntegral n)) .
42 EventListAbs.toPairList
43
44 notifier :: IO () -> IO ()
45 notifier = id
46
47 outMIDIEvent :: JMIDI.Port Jack.Output
48 -> Jack.NFrames
49 -> ReactiveFieldWrite IO [(Frames, RawMessage)]
50 outMIDIEvent output nframes@(Jack.NFrames nframesInt') =
51 ReactiveFieldWrite setter
52 where setter :: [(Frames, RawMessage)] -> IO ()
53 setter = handleError .
54 JMIDI.writeEventsToPort output nframes . transform
55 -- Doesn't assume the list is sorted or small enough. For
56 -- large size buffer, this might cause performance issue. All
57 -- the unprocessed events are lost, which is unfortunate…
58 transform :: [(Frames, RawMessage)]
59 -> EventListAbs.T Jack.NFrames RawMessage
60 transform = EventListAbs.fromPairList .
61 map (BF.first (Jack.NFrames . fromIntegral)) .
62 takeWhile ((< nframesInt) . fst) . L.sortBy (comparing fst)
63 nframesInt = fromIntegral nframesInt'
64
65 toProcess :: CBMVar [(Frames, RawMessage)]
66 -> ReactiveFieldReadWrite IO [(Frames, RawMessage)]
67 toProcess mvar = ReactiveFieldReadWrite setter getter notifier
68 where setter :: [(Frames, RawMessage)] -> IO ()
69 setter = writeCBMVar mvar
70 getter :: IO [(Frames, RawMessage)]
71 getter = readCBMVar mvar
72 notifier :: IO () -> IO ()
73 notifier = installCallbackCBMVar mvar