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                       hiding (mapM_,concat)
  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     Jack.waitForBreak
  70     return ()
  71
  72 -- The callback function. It pumps value out of the input port, mix
  73 -- them with value coming from the machine itself and stuff them into
  74 -- the output port. When this function is not running, events are
  75 -- processed.
  76 jackCallBack :: ( ReactiveValueAtomicUpdate toProcess [(Frames, RawMessage)] IO
  77                 , ReactiveValueAtomicUpdate board
  78                   (M.IntMap ([Note],[Message])) IO
  79                 , ReactiveValueRead tempo Tempo IO
  80                 , ReactiveValueAtomicUpdate layerConfs (M.IntMap LayerConf) IO
  81                 ) =>
  82                 IOTick
  83              -> JMIDI.Port Jack.Input
  84              -> JMIDI.Port Jack.Output
  85              -> toProcess
  86              -> board
  87              -> tempo
  88              -> layerConfs
  89              -> Jack.NFrames
  90              -> Sync.ExceptionalT E.Errno IO ()
  91 jackCallBack tc input output toProcessRV boardQueue tempoRV layerMapRV
  92   nframes@(Jack.NFrames nframesInt') = do
  93   let inMIDIRV = inMIDIEvent input nframes
  94       outMIDIRV = outMIDIEvent output nframes
  95       nframesInt = fromIntegral nframesInt' :: Int
  96   Trans.lift $ do
  97     tempo <- reactiveValueRead tempoRV
  98     inMIDI <- reactiveValueRead inMIDIRV
  99     let (unchangedMessages,toBeTreatedMessages) =
 100           break (\(_,m) -> fromMaybe False $ do
 101                     mess <- fromRawMessage m
 102                     return (isInstrument mess || isVolume mess)) inMIDI
 103     reactiveValueAppend toProcessRV unchangedMessages
 104     let (volume,instruments) = break (isInstrument . snd) $
 105           map (second (fromJust . fromRawMessage)) toBeTreatedMessages
 106     mapM_ ((\(Volume c v) -> reactiveValueUpdate layerMapRV
 107             (M.adjust (\(st,d,s) -> (st,d,s { volume = v }))
 108              (fromChannel c))) . snd) volume
 109     mapM_ ((\(Instrument c p) -> reactiveValueUpdate layerMapRV
 110             (M.adjust (\(st,d,s) -> (st,d,s { instrument = fromProgram p }))
 111               (fromChannel c))) . snd) instruments
 112     fmap (concat . toList . gatherMessages tempo nframesInt)
 113          (reactiveValueEmpty boardQueue) >>=
 114       reactiveValueAppend toProcessRV
 115     (go, old') <- fmap (schedule nframesInt) (reactiveValueRead toProcessRV)
 116     let old = map (first (+ (- nframesInt))) old'
 117     --putStrLn ("Out: " ++ show (map fst go))
 118     reactiveValueWrite outMIDIRV go
 119     reactiveValueWrite toProcessRV old
 120     tickIOTick tc
 121   --------------