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.ReactiveValue
  15 import qualified Foreign.C.Error                     as E
  16 import           Graphics.UI.Gtk
  17 import           RMCA.IOClockworks
  18 import           RMCA.ReactiveValueAtomicUpdate
  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 :: (ReactiveValueAtomicUpdate board
  49               (M.IntMap ([Note],[Message])) IO
  50              , ReactiveValueRead tempo Tempo IO) =>
  51              IOTick
  52           -> board
  53           -> tempo
  54           -> IO ()
  55 jackSetup tc boardQueue tempoRV = Sync.resolveT handleErrorJack $ do
  56   toProcessRV <- Trans.lift $ newCBRef []
  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 :: ( ReactiveValueAtomicUpdate toProcess [(Frames, RawMessage)] IO
  73                 , ReactiveValueAtomicUpdate board
  74                   (M.IntMap ([Note],[Message])) IO
  75                 , ReactiveValueRead tempo Tempo IO) =>
  76                 IOTick
  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     tickIOTick tc
 101   --------------