module Reactive.Banana.JACK.Process where
import qualified Reactive.Banana.JACK.Common as Common
import qualified Reactive.Banana.MIDI.Process as Process
import qualified Reactive.Banana.MIDI.Time as Time
import qualified Reactive.Banana.Combinators as RB
import qualified Reactive.Banana.Frameworks as RBF
import Reactive.Banana.Frameworks (Handler, )
import Reactive.Banana.Combinators ((<@>), )
import qualified Sound.JACK.Exception as JackExc
import qualified Sound.JACK.MIDI as JackMidi
import qualified Sound.JACK as Jack
import qualified Sound.MIDI.Message as MidiMsg
import qualified Data.EventList.Absolute.TimeBody as EventListAbs
import qualified Data.Map as Map
import Data.Map (Map)
import Numeric.NonNegative.Class ((-|), )
import qualified Control.Monad.Exception.Synchronous as Sync
import qualified Foreign.C.Error as E
import qualified Data.Accessor.Basic as Acc
import qualified Control.Monad.Trans.Class as MT
import qualified Control.Monad.Trans.State as MS
import qualified Control.Monad.Trans.Reader as MR
import Control.Monad.Trans.Reader (ReaderT, runReaderT, )
import Control.Monad.IO.Class (MonadIO, liftIO, )
import Control.Monad.Fix (MonadFix, )
import Control.Monad (when, )
import Control.Applicative (Applicative, pure, (<*>), )
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef, )
import Data.Foldable (forM_, )
import Data.Monoid (Monoid, mappend, mempty, )
import Prelude hiding (sequence, )
data Context =
Context {
contextCycleStartRef :: IORef AbsoluteTicks,
contextInQueueRef :: IORef InQueue,
contextClient :: Jack.Client
}
newtype Schedule = Schedule Int
deriving (Eq, Ord, Enum, Show)
newtype Reactor a =
Reactor {
runReactor :: ReaderT Context (MS.StateT Schedule RBF.MomentIO) a
} deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
instance RB.MonadMoment Reactor where
liftMoment = Process.liftMomentIO . RB.liftMoment
instance Process.MomentIO Reactor where
liftMomentIO = Reactor . MT.lift . MT.lift
instance Time.Timed Reactor where
ticksFromSeconds t = do
client <- Reactor $ MR.asks contextClient
rate <- liftIO $ Jack.getSampleRate client
return .
Time.cons . Time.Ticks .
round . (fromIntegral rate *) .
Time.unSeconds . Time.decons $ t
data InEvent =
InEvent (Map Schedule [Handler AbsoluteTicks]) [MidiMsg.T]
instance Monoid InEvent where
mempty = InEvent Map.empty []
mappend (InEvent xs0 ys0) (InEvent xs1 ys1) =
InEvent (Map.unionWith (++) xs0 xs1) (ys0++ys1)
inEventBeat :: Acc.T InEvent (Map Schedule [Handler AbsoluteTicks])
inEventBeat =
Acc.fromSetGet
(\beats (InEvent _ evs) -> InEvent beats evs)
(\(InEvent beats _) -> beats)
type InQueue = Map Jack.NFrames InEvent
type OutQueue = Map Jack.NFrames [MidiMsg.T]
run ::
(JackExc.ThrowsErrno e) =>
(RB.Event MidiMsg.T -> RB.Event [MidiMsg.T]) ->
ReaderT Common.Handle (Sync.ExceptionalT e IO) ()
run f =
runM (\ _ts xs -> return $ f xs)
runM ::
(JackExc.ThrowsErrno e) =>
(RB.Behavior AbsoluteTicks ->
RB.Event MidiMsg.T -> Reactor (RB.Event [MidiMsg.T])) ->
ReaderT Common.Handle (Sync.ExceptionalT e IO) ()
runM f = do
MR.ReaderT $ \h -> do
cycleStartRef <- MT.lift $ newIORef mempty
inQueueRef <- MT.lift $ newIORef Map.empty
outQueueRef <- MT.lift $ newIORef Map.empty
(addEventHandler, runEventHandler) <- MT.lift RBF.newAddHandler
(addTimeHandler, runTimeHandler) <- MT.lift RBF.newAddHandler
MT.lift $ RBF.actuate =<< RBF.compile (do
time <- RBF.fromChanges (error "uninitialized time") addTimeHandler
evs <-
flip MS.evalStateT (Schedule 0) .
flip runReaderT
(Context cycleStartRef inQueueRef (Common.client h)) .
runReactor .
f (fmap (absTicksFromNFrames . fst) time)
=<< RBF.fromAddHandler addEventHandler
RBF.reactimate $
pure
(\t -> modifyIORef outQueueRef . Map.insertWith (++) t)
<*> fmap snd time <@> evs)
Jack.withProcess (Common.client h)
(process h cycleStartRef inQueueRef outQueueRef
runTimeHandler runEventHandler) $
Jack.withActivation (Common.client h) $
MT.lift $ Jack.waitForBreak
viewQueueL ::
InQueue ->
Maybe
((Jack.NFrames, Either [Handler AbsoluteTicks] MidiMsg.T),
InQueue)
viewQueueL q0 = do
((t, InEvent beats evs), q1) <- Map.minViewWithKey q0
case (Map.minView beats, evs) of
(Just (b,bs), _) ->
Just ((t, Left b), Map.insert t (InEvent bs evs) q1)
(Nothing, e:es) ->
Just ((t, Right e),
if null es then q1 else Map.insert t (InEvent Map.empty es) q1)
(Nothing, []) -> viewQueueL q1
normalizeInQueue :: InQueue -> InQueue
normalizeInQueue =
Map.filter (\(InEvent beats evs) -> not $ Map.null beats && null evs)
reduceQueueTime ::
Jack.NFrames -> Map Jack.NFrames a -> Map Jack.NFrames a
reduceQueueTime dt = Map.mapKeysMonotonic (-| dt)
process ::
Common.Handle ->
IORef AbsoluteTicks ->
IORef InQueue ->
IORef OutQueue ->
Handler (Jack.NFrames, Jack.NFrames) ->
Handler MidiMsg.T ->
Jack.NFrames ->
Sync.ExceptionalT E.Errno IO ()
process h cycleStartRef inQueueRef outQueueRef
runTimeHandler runEventHandler size = do
evs <- JackMidi.readEventsFromPort (Common.portIn h) size
MT.lift $ modifyIORef inQueueRef $
Map.unionWith mappend $ fmap (InEvent Map.empty) $
Map.fromListWith (++) $ EventListAbs.toPairList $
fmap (:[]) evs
cycleStart <- MT.lift $ Jack.lastFrameTime $ Common.client h
let cycleStartTicks = absTicksFromNFrames cycleStart
MT.lift $ writeIORef cycleStartRef cycleStartTicks
let duration = size
loop = do
inQueueStart <- readIORef inQueueRef
forM_ (viewQueueL inQueueStart) $ \((t,ev), remQueue) ->
when (t<duration) $ do
writeIORef inQueueRef remQueue
runTimeHandler (mappend cycleStart t, t)
either
(mapM_ ($ Time.inc (ticksFromNFrames t) cycleStartTicks))
runEventHandler ev
loop
MT.lift loop
MT.lift $ modifyIORef inQueueRef $ reduceQueueTime duration
outQueue <- MT.lift $ readIORef outQueueRef
case Map.splitLookup duration outQueue of
(now, pivot, later) -> do
JackMidi.writeEventsToPort (Common.portOut h) size $
EventListAbs.flatten $ EventListAbs.fromPairList $ Map.toList now
MT.lift $ writeIORef outQueueRef $
maybe id (Map.insert mempty) pivot $
reduceQueueTime duration later
type RelativeTicks = Time.T Reactor Time.Relative Time.Ticks
type AbsoluteTicks = Time.T Reactor Time.Absolute Time.Ticks
type RelativeSeconds = Time.T Reactor Time.Relative Time.Seconds
nframesFromTicks :: RelativeTicks -> Jack.NFrames
nframesFromTicks =
Jack.NFrames . fromIntegral . Time.unTicks . Time.decons
ticksFromNFrames :: Jack.NFrames -> RelativeTicks
ticksFromNFrames (Jack.NFrames n) =
Time.cons . Time.Ticks . fromIntegral $ n
absTicksFromNFrames :: Jack.NFrames -> AbsoluteTicks
absTicksFromNFrames (Jack.NFrames n) =
Time.cons . Time.Ticks . fromIntegral $ n
sendBeat ::
Context -> Schedule ->
Handler AbsoluteTicks -> AbsoluteTicks -> IO ()
sendBeat context sched runBeatHandler time = do
cycleStart <- readIORef (contextCycleStartRef context)
modifyIORef (contextInQueueRef context) $
Map.insertWith mappend
(nframesFromTicks $ Time.subSat time cycleStart)
(InEvent (Map.singleton sched [runBeatHandler]) [])
cancelBeats :: Context -> Schedule -> IO ()
cancelBeats context sched = do
modifyIORef (contextInQueueRef context) $
normalizeInQueue .
fmap (Acc.modify inEventBeat (Map.delete sched))
instance Process.Reactor Reactor where
reserveSchedule = Reactor $ MR.ReaderT $ \context -> do
sched <- MS.get
MS.modify succ
(eEcho, runBeatHandler) <- MT.lift RBF.newEvent
return
(mapM_ (sendBeat context sched runBeatHandler),
cancelBeats context sched, eEcho)