Updated CLOC.

[tmp/julm/arpeggigon.git] / RCMA / Translator / Jack.hs

diff --git a/RCMA/Translator/Jack.hs b/RCMA/Translator/Jack.hs
index 21387e54f66602f545d33707b4cba2cb3347d462..0f86175bc1550b567c13d0f24b5a55e5b4b9092a 100644 (file)
--- a/RCMA/Translator/Jack.hs
+++ b/RCMA/Translator/Jack.hs
@@ -1,21 +1,26 @@
-{-# LANGUAGE Arrows, PartialTypeSignatures #-}
+{-# LANGUAGE Arrows #-}
 
 -- Contains all the information and functions necessary to run a Jack
 -- port and exchange information through reactive values and Yampa.
-module RCMA.Translator.Jack where
+module RCMA.Translator.Jack ( jackSetup
+                            ) where
 
+import           Control.Applicative                 ((<**>))
 import qualified Control.Monad.Exception.Synchronous as Sync
 import qualified Control.Monad.Trans.Class           as Trans
+import qualified Data.Bifunctor                      as BF
 import           Data.CBMVar
 import qualified Data.EventList.Absolute.TimeBody    as EventListAbs
 import           Data.ReactiveValue
 import qualified Foreign.C.Error                     as E
 import           Hails.Yampa
 import           RCMA.Semantics
+import           RCMA.Translator.Filter
 import           RCMA.Translator.Message
 import           RCMA.Translator.RV
 import           RCMA.Translator.Translator
 import qualified Sound.JACK                          as Jack
+import qualified Sound.JACK.Exception                as JExc
 import qualified Sound.JACK.MIDI                     as JMIDI
 
 rcmaName :: String
@@ -29,23 +34,22 @@ outPortName = "output"
 
 -- Starts a default client with an input and an output port. Doesn't
 -- do anything as such.
---jackSetup :: _
+jackSetup :: ReactiveFieldRead IO (LTempo, Int, [(Frames, RawMessage)])
+          -> IO ()
 jackSetup boardInRV = Jack.handleExceptions $ do
-  toProcessQueue <- Trans.lift $ toProcess <$> newCBMVar []
+  toProcessRV <- Trans.lift $ toProcess <$> newCBMVar []
   Jack.withClientDefault rcmaName $ \client ->
     Jack.withPort client outPortName $ \output ->
     Jack.withPort client inPortName  $ \input ->
-    jackRun client input output
-    (jackCallBack client input output toProcessQueue boardInRV)
+    jackRun client (jackCallBack client input output toProcessRV boardInRV)
 
 -- Loop that does nothing except setting up a callback function
 -- (called when Jack is ready to take new inputs).
-{-jackRun :: Jack.Client
-        -> JMIDI.Port Jack.Input
-        -> JMIDI.Port Jack.Output
-        -> _
-        -> _-}
-jackRun client input output callback =
+jackRun :: (JExc.ThrowsErrno e) =>
+           Jack.Client
+        -> (Jack.NFrames -> Sync.ExceptionalT E.Errno IO ())
+        -> Sync.ExceptionalT e IO ()
+jackRun client callback =
   Jack.withProcess client callback $ do
   Trans.lift $ putStrLn $ "Started " ++ rcmaName
   Trans.lift $ Jack.waitForBreak
@@ -64,10 +68,11 @@ jackCallBack :: Jack.Client
              -> ReactiveFieldRead IO (LTempo, Int, [(Frames, RawMessage)])
              -> Jack.NFrames
              -> Sync.ExceptionalT E.Errno IO ()
-jackCallBack client input output toProcessQueue boardInRV
-  nframes@(Jack.NFrames nframesInt) = do
+jackCallBack client input output toProcessRV boardInRV
+  nframes@(Jack.NFrames nframesInt') = do
   let inMIDIRV = inMIDIEvent input nframes
       outMIDIRV = outMIDIEvent output nframes
+      nframesInt = fromIntegral nframesInt' :: Int
   -- This gets the sample rate of the client and the last frame number
   -- it processed. We then use it to calculate the current absolute time
   sr <- Trans.lift $ Jack.getSampleRate client
@@ -84,7 +89,16 @@ jackCallBack client input output toProcessQueue boardInRV
   -- write them to the output buffer.
   (inPure, outRaw) <- Trans.lift $ yampaReactiveDual
                       (defaultTempo, sr, chan, ([],[],[])) gatherMessages
+  -- This should all go in its own IO action
   Trans.lift $ reactiveValueWrite inPure
                (tempo, sr, chan, (boardIn `mappend` outMIDI))
-  Trans.lift (outRaw =:> outMIDIRV)
+  Trans.lift (reactiveValueRead outRaw <**>
+              (mappend <$> reactiveValueRead toProcessRV) >>=
+              reactiveValueWrite toProcessRV)
+  Trans.lift $ do
+    (go, old') <- schedule nframesInt <$> reactiveValueRead toProcessRV
+    let old = map (BF.first (+ (- nframesInt))) old'
+    reactiveValueWrite outMIDIRV go
+    reactiveValueWrite toProcessRV old
+  --------------
   return ()