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           Control.Concurrent.MVar
  10 import qualified Control.Monad.Exception.Synchronous as Sync
  11 import qualified Control.Monad.Trans.Class           as Trans
  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.Auxiliary
  18 import           RMCA.Global.Clock
  19 import           RMCA.IOClockworks
  20 import           RMCA.Semantics
  21 import           RMCA.Translator.Message
  22 import           RMCA.Translator.RV
  23 import           RMCA.Translator.Translator
  24 import qualified Sound.JACK                          as Jack
  25 import qualified Sound.JACK.Exception                as JackExc
  26 import qualified Sound.JACK.MIDI                     as JMIDI
  27
  28 rmcaName :: String
  29 rmcaName = "RMCA"
  30
  31 inPortName :: String
  32 inPortName = "input"
  33
  34 outPortName :: String
  35 outPortName = "output"
  36
  37 handleErrorJack :: JackExc.All -> IO ()
  38 handleErrorJack _ = postGUIAsync $ do
  39   diag <- messageDialogNewWithMarkup
  40           Nothing [] MessageError ButtonsClose
  41           "No running instance of Jack could be found!"
  42   widgetShow diag
  43   resp <- dialogRun diag
  44   print resp
  45   mainQuit
  46
  47 -- Starts a default client with an input and an output port. Doesn't
  48 -- do anything as such.
  49 jackSetup :: (ReactiveValueReadWrite board
  50               (M.IntMap ([Note],[Message])) IO
  51              , ReactiveValueRead tempo Tempo IO) =>
  52              IOTick
  53           -> board
  54           -> tempo
  55           -> IO ()
  56 jackSetup tc boardQueue tempoRV = Sync.resolveT handleErrorJack $ do
  57   toProcessRV <- Trans.lift $ newCBMVarRW []
  58   Jack.withClientDefault rmcaName $ \client ->
  59     Jack.withPort client outPortName $ \output ->
  60     Jack.withPort client inPortName  $ \input ->
  61     Jack.withProcess client (jackCallBack tc input output
  62                               toProcessRV boardQueue tempoRV) $
  63     Jack.withActivation client $ Trans.lift $ do
  64     putStrLn $ "Started " ++ rmcaName ++ " JACK client."
  65     --newEmptyMVar >>= takeMVar
  66     Jack.waitForBreak
  67     return ()
  68
  69 -- The callback function. It pumps value out of the input port, mix
  70 -- them with value coming from the machine itself and stuff them into
  71 -- the output port. When this function is not running, events are
  72 -- processed.
  73 jackCallBack :: ( ReactiveValueReadWrite toProcess [(Frames, RawMessage)] IO
  74                 , ReactiveValueReadWrite board
  75                   (M.IntMap ([Note],[Message])) IO
  76                 , ReactiveValueRead tempo Tempo IO) =>
  77                 IOTick
  78              -> JMIDI.Port Jack.Input
  79              -> JMIDI.Port Jack.Output
  80              -> toProcess
  81              -> board
  82              -> tempo
  83              -> Jack.NFrames
  84              -> Sync.ExceptionalT E.Errno IO ()
  85 jackCallBack tc input output toProcessRV boardQueue tempoRV
  86   nframes@(Jack.NFrames nframesInt') = do
  87   let inMIDIRV = inMIDIEvent input nframes
  88       outMIDIRV = outMIDIEvent output nframes
  89       nframesInt = fromIntegral nframesInt' :: Int
  90   Trans.lift $ do
  91     tempo <- reactiveValueRead tempoRV
  92     concat . toList . gatherMessages tempo nframesInt <$>
  93       reactiveValueRead boardQueue >>= \bq ->
  94       reactiveValueAppend toProcessRV bq >> putStrLn ("BoardQueue: " ++ show (map fst bq))
  95     reactiveValueEmpty  boardQueue
  96     (go, old') <- schedule nframesInt <$> reactiveValueRead toProcessRV
  97     let old = map (first (+ (- nframesInt))) old'
  98     putStrLn ("Out: " ++ show (map fst go))
  99     reactiveValueWrite outMIDIRV go
 100     reactiveValueWrite toProcessRV old
 101     tickIOTick tc
 102   --------------