diff --git a/rhine.cabal b/rhine.cabal --- a/rhine.cabal +++ b/rhine.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: rhine -version: 1.6 +version: 1.7 synopsis: Functional Reactive Programming with type-level clocks description: Rhine is a library for synchronous and asynchronous Functional Reactive Programming (FRP). @@ -49,13 +49,14 @@ common opts build-depends: - automaton ^>=1.6, + automaton ^>=1.7, base >=4.16 && <4.22, - monad-schedule ^>=1.6, + monad-schedule ^>=1.7, mtl >=2.2 && <2.4, selective ^>=0.7, text >=1.2 && <2.2, time >=1.8, + time-domain ^>=1.7, transformers >=0.5, vector-sized >=1.4, @@ -159,7 +160,6 @@ sop-core ^>=0.5, text >=1.2 && <2.2, time >=1.8, - time-domain ^>=1.6, transformers >=0.5, -- Directories containing source files. diff --git a/src/FRP/Rhine/ClSF/Except.hs b/src/FRP/Rhine/ClSF/Except.hs --- a/src/FRP/Rhine/ClSF/Except.hs +++ b/src/FRP/Rhine/ClSF/Except.hs @@ -61,6 +61,7 @@ if b then throwS -< e else returnA -< () +{-# INLINEABLE throwOn' #-} -- | Throw the exception 'e' whenever the function evaluates to 'True'. throwOnCond :: (Monad m) => (a -> Bool) -> e -> ClSF (ExceptT e m) cl a a diff --git a/src/FRP/Rhine/ClSF/Util.hs b/src/FRP/Rhine/ClSF/Util.hs --- a/src/FRP/Rhine/ClSF/Util.hs +++ b/src/FRP/Rhine/ClSF/Util.hs @@ -45,6 +45,7 @@ {- | Utility to apply functions to the current 'TimeInfo', such as record selectors: + @ printAbsoluteTime :: ClSF IO cl () () printAbsoluteTime = timeInfoOf absolute >>> arrMCl print diff --git a/src/FRP/Rhine/Clock.hs b/src/FRP/Rhine/Clock.hs --- a/src/FRP/Rhine/Clock.hs +++ b/src/FRP/Rhine/Clock.hs @@ -58,13 +58,15 @@ -- | The time domain, i.e. type of the time stamps the clock creates. type Time cl - -- | Additional information that the clock may output at each tick, - -- e.g. if a realtime promise was met, if an event occurred, - -- if one of its subclocks (if any) ticked. + {- | Additional information that the clock may output at each tick, + e.g. if a realtime promise was met, if an event occurred, + if one of its subclocks (if any) ticked. + -} type Tag cl - -- | The method that produces to a clock value a running clock, - -- i.e. an effectful stream of tagged time stamps together with an initialisation time. + {- | The method that produces to a clock value a running clock, + i.e. an effectful stream of tagged time stamps together with an initialisation time. + -} initClock :: -- | The clock value, containing e.g. settings or device parameters cl -> @@ -190,8 +192,9 @@ { unscaledClockS :: cl -- ^ The clock before the rescaling , rescaleS :: RescalingSInit m cl time tag - -- ^ The rescaling stream function, and rescaled initial time, - -- depending on the initial time before rescaling + {- ^ The rescaling stream function, and rescaled initial time, + depending on the initial time before rescaling + -} } instance diff --git a/src/FRP/Rhine/Clock/FixedStep.hs b/src/FRP/Rhine/Clock/FixedStep.hs --- a/src/FRP/Rhine/Clock/FixedStep.hs +++ b/src/FRP/Rhine/Clock/FixedStep.hs @@ -24,6 +24,9 @@ import Control.Monad.Schedule.Class import Control.Monad.Schedule.Trans (ScheduleT, wait) +-- time-domain +import Data.TimeDomain (Seconds (..)) + -- automaton import Data.Automaton (accumulateWith, arrM) @@ -43,11 +46,11 @@ FixedStep :: (KnownNat n) => FixedStep n -- TODO Does the constraint bring any benefit? -- | Extract the type-level natural number as an integer. -stepsize :: FixedStep n -> Integer -stepsize fixedStep@FixedStep = natVal fixedStep +stepsize :: FixedStep n -> Seconds Integer +stepsize fixedStep@FixedStep = Seconds $ natVal fixedStep -instance (MonadSchedule m, Monad m) => Clock (ScheduleT Integer m) (FixedStep n) where - type Time (FixedStep n) = Integer +instance (MonadSchedule m, Monad m) => Clock (ScheduleT (Seconds Integer) m) (FixedStep n) where + type Time (FixedStep n) = Seconds Integer type Tag (FixedStep n) = () initClock cl = let step = stepsize cl diff --git a/src/FRP/Rhine/Clock/Periodic.hs b/src/FRP/Rhine/Clock/Periodic.hs --- a/src/FRP/Rhine/Clock/Periodic.hs +++ b/src/FRP/Rhine/Clock/Periodic.hs @@ -22,6 +22,9 @@ -- monad-schedule import Control.Monad.Schedule.Trans +-- time-domain +import Data.TimeDomain (Seconds (..)) + -- automaton import Data.Automaton (Automaton (..), accumulateWith, concatS, withSideEffect) @@ -43,9 +46,9 @@ instance (Monad m, NonemptyNatList v) => - Clock (ScheduleT Integer m) (Periodic v) + Clock (ScheduleT (Seconds Integer) m) (Periodic v) where - type Time (Periodic v) = Integer + type Time (Periodic v) = Seconds Integer type Tag (Periodic v) = () initClock cl = return @@ -68,16 +71,16 @@ tailCl Periodic = Periodic class NonemptyNatList (v :: [Nat]) where - theList :: Periodic v -> NonEmpty Integer + theList :: Periodic v -> NonEmpty (Seconds Integer) instance (KnownNat n) => NonemptyNatList '[n] where - theList cl = headCl cl :| [] + theList cl = Seconds (headCl cl) :| [] instance (KnownNat n1, KnownNat n2, NonemptyNatList (n2 : ns)) => NonemptyNatList (n1 : n2 : ns) where - theList cl = headCl cl <| theList (tailCl cl) + theList cl = Seconds (headCl cl) <| theList (tailCl cl) -- * Utilities diff --git a/src/FRP/Rhine/Clock/Realtime/Audio.hs b/src/FRP/Rhine/Clock/Realtime/Audio.hs --- a/src/FRP/Rhine/Clock/Realtime/Audio.hs +++ b/src/FRP/Rhine/Clock/Realtime/Audio.hs @@ -34,7 +34,7 @@ import Data.Automaton.Trans.Except hiding (step) -- time-domain -import Data.TimeDomain (diffTime) +import Data.TimeDomain (Seconds (..), diffTime) -- rhine import FRP.Rhine.Clock @@ -119,7 +119,7 @@ currentTime <- once_ $ liftIO getCurrentTime let lateDiff = currentTime `diffTime` bufferFullTime - late = if lateDiff > 0 then Just lateDiff else Nothing + late = if lateDiff > 0 then Just $ getSeconds lateDiff else Nothing safe $ runningClock bufferFullTime late initialTime <- liftIO getCurrentTime return @@ -148,12 +148,12 @@ thePureRateNum = fromInteger . thePureRateIntegral instance (Monad m, PureAudioClockRate rate) => Clock m (PureAudioClock rate) where - type Time (PureAudioClock rate) = Double + type Time (PureAudioClock rate) = Seconds Double type Tag (PureAudioClock rate) = () initClock audioClock = return - ( arr (const (1 / thePureRateNum audioClock)) >>> sumS &&& arr (const ()) + ( arr (const (1 / thePureRateNum audioClock)) >>> sumN &&& arr (const ()) , 0 ) {-# INLINE initClock #-} @@ -170,5 +170,5 @@ pureAudioClockF = RescaledClock { unscaledClock = PureAudioClock - , rescale = double2Float + , rescale = double2Float . getSeconds } diff --git a/src/FRP/Rhine/Clock/Realtime/Millisecond.hs b/src/FRP/Rhine/Clock/Realtime/Millisecond.hs --- a/src/FRP/Rhine/Clock/Realtime/Millisecond.hs +++ b/src/FRP/Rhine/Clock/Realtime/Millisecond.hs @@ -17,6 +17,8 @@ import Data.Time.Clock -- rhine + +import Data.TimeDomain (Seconds (..)) import FRP.Rhine.Clock import FRP.Rhine.Clock.FixedStep import FRP.Rhine.Clock.Proxy @@ -35,16 +37,16 @@ where 'Nothing' represents successful realtime, and @'Just' lag@ a lag (in seconds). -} -newtype Millisecond (n :: Nat) = Millisecond (WaitUTCClock IO (RescaledClock (UnscheduleClock IO (FixedStep n)) Double)) +newtype Millisecond (n :: Nat) = Millisecond (WaitUTCClock IO (RescaledClock (UnscheduleClock IO (FixedStep n)) (Seconds Double))) instance Clock IO (Millisecond n) where type Time (Millisecond n) = UTCTime type Tag (Millisecond n) = Maybe Double - initClock (Millisecond cl) = initClock cl <&> first (>>> arr (second snd)) + initClock (Millisecond cl) = initClock cl <&> first (>>> arr (second (fmap getSeconds . snd))) {-# INLINE initClock #-} instance GetClockProxy (Millisecond n) -- | Tries to achieve real time by using 'waitUTC', see its docs. waitClock :: (KnownNat n) => Millisecond n -waitClock = Millisecond $ waitUTC $ RescaledClock (unyieldClock FixedStep) ((/ 1000) . fromInteger) +waitClock = Millisecond $ waitUTC $ RescaledClock (unyieldClock FixedStep) ((/ 1000) . fromInteger . getSeconds) diff --git a/src/FRP/Rhine/Clock/Select.hs b/src/FRP/Rhine/Clock/Select.hs --- a/src/FRP/Rhine/Clock/Select.hs +++ b/src/FRP/Rhine/Clock/Select.hs @@ -34,9 +34,10 @@ -} data SelectClock cl a = SelectClock { mainClock :: cl - -- ^ The main clock - -- | Return 'Nothing' if no tick of the subclock is required, - -- or 'Just a' if the subclock should tick, with tag 'a'. + {- ^ The main clock + | Return 'Nothing' if no tick of the subclock is required, + or 'Just a' if the subclock should tick, with tag 'a'. + -} , select :: Tag cl -> Maybe a } diff --git a/src/FRP/Rhine/ResamplingBuffer.hs b/src/FRP/Rhine/ResamplingBuffer.hs --- a/src/FRP/Rhine/ResamplingBuffer.hs +++ b/src/FRP/Rhine/ResamplingBuffer.hs @@ -53,14 +53,16 @@ a -> s -> m s - -- ^ Store one input value of type 'a' at a given time stamp, - -- and return an updated state. + {- ^ Store one input value of type 'a' at a given time stamp, + and return an updated state. + -} , get :: TimeInfo clb -> s -> m (Result s b) - -- ^ Retrieve one output value of type 'b' at a given time stamp, - -- and an updated state. + {- ^ Retrieve one output value of type 'b' at a given time stamp, + and an updated state. + -} } -- | A type synonym to allow for abbreviation. diff --git a/src/FRP/Rhine/ResamplingBuffer/ClSF.hs b/src/FRP/Rhine/ResamplingBuffer/ClSF.hs --- a/src/FRP/Rhine/ResamplingBuffer/ClSF.hs +++ b/src/FRP/Rhine/ResamplingBuffer/ClSF.hs @@ -24,10 +24,11 @@ -} clsfBuffer :: (Monad m) => - -- | The clocked signal function that consumes - -- and a list of timestamped inputs, - -- and outputs a single value. - -- The list will contain the /newest/ element in the head. + {- | The clocked signal function that consumes + and a list of timestamped inputs, + and outputs a single value. + The list will contain the /newest/ element in the head. + -} ClSF m cl2 [(TimeInfo cl1, a)] b -> ResamplingBuffer m cl1 cl2 a b clsfBuffer = clsfBuffer' . toStreamT . getAutomaton diff --git a/src/FRP/Rhine/ResamplingBuffer/Interpolation.hs b/src/FRP/Rhine/ResamplingBuffer/Interpolation.hs --- a/src/FRP/Rhine/ResamplingBuffer/Interpolation.hs +++ b/src/FRP/Rhine/ResamplingBuffer/Interpolation.hs @@ -67,8 +67,9 @@ , s ~ Diff (Time cl1) , s ~ Diff (Time cl2) ) => - -- | The size of the interpolation window - -- (for how long in the past to remember incoming values) + {- | The size of the interpolation window + (for how long in the past to remember incoming values) + -} s -> ResamplingBuffer m cl1 cl2 v v sinc windowSize = diff --git a/src/FRP/Rhine/ResamplingBuffer/Util.hs b/src/FRP/Rhine/ResamplingBuffer/Util.hs --- a/src/FRP/Rhine/ResamplingBuffer/Util.hs +++ b/src/FRP/Rhine/ResamplingBuffer/Util.hs @@ -5,9 +5,15 @@ -} module FRP.Rhine.ResamplingBuffer.Util where +-- base +import Data.Function ((&)) + -- transformers import Control.Monad.Trans.Reader (runReaderT) +-- time-domain +import Data.TimeDomain (TimeDomain (..)) + -- automaton import Data.Stream (StreamT (..)) import Data.Stream.Internal (JointState (..)) @@ -18,6 +24,7 @@ import FRP.Rhine.ClSF hiding (step, toStreamT) import FRP.Rhine.Clock import FRP.Rhine.ResamplingBuffer +import FRP.Rhine.Schedule (ParallelClock) -- * Utilities to build 'ResamplingBuffer's from smaller components @@ -102,3 +109,75 @@ (forall b. ResamplingBuffer m cl clf b (f b)) -> ResamplingBuffer m cl clf a (f (a, TimeInfo cl)) timestamped resBuf = (clId &&& timeInfo) ^->> resBuf + +infixl 4 |-| + +-- | Combine two 'ResamplingBuffer's in parallel input time. +-- +-- The resulting 'ResamplingBuffer' will consume input whenever either of the input clocks ticks. +-- +-- Caution: The time differences are split up between the two buffers, so the total passed time on the inputs is not the same as on the output. +(|-|) :: + ( Monad m, + TimeDomain (Time cl), + Time clL ~ Time cl, + Time clR ~ Time cl + ) => + ResamplingBuffer m clL cl a b -> + ResamplingBuffer m clR cl a c -> + ResamplingBuffer m (ParallelClock clL clR) cl a (b, c) +ResamplingBuffer stateL putL getL |-| ResamplingBuffer stateR putR getR = + ResamplingBuffer + { buffer = JointState (JointState Nothing stateL) (JointState Nothing stateR), + put = \theTimeInfo a (JointState (JointState lastTimeMaybeL sL) (JointState lastTimeMaybeR sR)) -> do + let now = absolute theTimeInfo + case tag theTimeInfo of + Left tagL -> do + sL' <- putL (theTimeInfo & retag (const tagL) & fixSinceLast lastTimeMaybeL) a sL + pure $! JointState (JointState (Just now) sL') (JointState lastTimeMaybeR sR) + Right tagR -> do + sR' <- putR (theTimeInfo & retag (const tagR) & fixSinceLast lastTimeMaybeR) a sR + pure $! JointState (JointState lastTimeMaybeL sL) (JointState (Just now) sR'), + get = \theTimeInfo (JointState (JointState lastTimeMaybeL sL) (JointState lastTimeMaybeR sR)) -> do + Result sL' b <- getL theTimeInfo sL + Result sR' c <- getR theTimeInfo sR + pure $! Result (JointState (JointState lastTimeMaybeL sL') (JointState lastTimeMaybeR sR')) (b, c) + } + +infixl 4 ||-|| + +-- | Combine two 'ResamplingBuffer's in parallel output time. +-- +-- The resulting 'ResamplingBuffer' will produce output whenever either of the output clocks ticks. +-- +-- Caution: The time differences are split up between the two buffers, so the total passed time on the input is not the same as on the outputs. +(||-||) :: + ( Monad m, + TimeDomain (Time cl), + Time clL ~ Time cl, + Time clR ~ Time cl + ) => + ResamplingBuffer m cl clL a b -> + ResamplingBuffer m cl clR a b -> + ResamplingBuffer m cl (ParallelClock clL clR) a b +ResamplingBuffer stateL putL getL ||-|| ResamplingBuffer stateR putR getR = + ResamplingBuffer + { buffer = JointState (JointState Nothing stateL) (JointState Nothing stateR), + put = \theTimeInfo a (JointState (JointState lastTimeMaybeL sL) (JointState lastTimeMaybeR sR)) -> do + sL' <- putL theTimeInfo a sL + sR' <- putR theTimeInfo a sR + pure $! JointState (JointState lastTimeMaybeL sL') (JointState lastTimeMaybeR sR'), + get = \theTimeInfo (JointState (JointState lastTimeMaybeL sL) (JointState lastTimeMaybeR sR)) -> case tag theTimeInfo of + Left tagL -> do + Result sL' b <- getL (theTimeInfo & retag (const tagL) & fixSinceLast lastTimeMaybeL) sL + pure $! Result (JointState (JointState lastTimeMaybeL sL') (JointState lastTimeMaybeR sR)) b + Right tagR -> do + Result sR' b <- getR (theTimeInfo & retag (const tagR) & fixSinceLast lastTimeMaybeR) sR + pure $! Result (JointState (JointState lastTimeMaybeL sL) (JointState lastTimeMaybeR sR')) b + } + +-- | Helper function for 'ResamplingBuffer's over 'ParallelClock's to fix the 'sinceLast' field of the 'TimeInfo'. +fixSinceLast :: (TimeDomain (Time cl)) => Maybe (Time cl) -> TimeInfo cl -> TimeInfo cl +fixSinceLast lastTimeMaybe theTimeInfo = case lastTimeMaybe of + Nothing -> theTimeInfo + Just lastTime -> theTimeInfo {sinceLast = absolute theTimeInfo `diffTime` lastTime} diff --git a/test/Schedule.hs b/test/Schedule.hs --- a/test/Schedule.hs +++ b/test/Schedule.hs @@ -16,6 +16,9 @@ -- monad-schedule import Control.Monad.Schedule.Trans (Schedule, runScheduleT, wait) +-- time-domain +import Data.TimeDomain (Seconds) + -- automaton import Data.Automaton (accumulateWith, constM, embed) @@ -31,10 +34,10 @@ [ testGroup "scheduleList" [ testCase "schedule waits chronologically" $ do - let output = runIdentity $ runScheduleT (const (pure ())) $ embed (scheduleList $ (\n -> constM (wait n $> n) >>> accumulateWith (+) 0) <$> [3 :: Integer, 5]) $ replicate 6 () + let output = runIdentity $ runScheduleT (const (pure ())) $ embed (scheduleList $ (\n -> constM (wait n $> n) >>> accumulateWith (+) 0) <$> [3 :: Seconds Integer, 5]) $ replicate 6 () output @?= pure <$> [3, 5, 6, 9, 10, 12] , testCase "schedule waits chronologically (mirrored)" $ do - let output = runSchedule $ embed (scheduleList $ (\n -> constM (wait n $> n) >>> accumulateWith (+) 0) <$> [5 :: Integer, 3]) $ replicate 6 () + let output = runSchedule $ embed (scheduleList $ (\n -> constM (wait n $> n) >>> accumulateWith (+) 0) <$> [5 :: Seconds Integer, 3]) $ replicate 6 () output @?= pure <$> [3, 5, 6, 9, 10, 12] ] , testGroup @@ -42,8 +45,8 @@ [ testCase "chronological ticks" $ do let clA = FixedStep @5 clB = FixedStep @3 - (runningClockA, _) = runSchedule (initClock clA :: RunningClockInit (Schedule Integer) Integer ()) - (runningClockB, _) = runSchedule (initClock clB :: RunningClockInit (Schedule Integer) Integer ()) + (runningClockA, _) = runSchedule (initClock clA :: RunningClockInit (Schedule (Seconds Integer)) (Seconds Integer) ()) + (runningClockB, _) = runSchedule (initClock clB :: RunningClockInit (Schedule (Seconds Integer)) (Seconds Integer) ()) output = runSchedule $ embed (runningSchedule clA clB runningClockA runningClockB) $ replicate 6 () output @?= [ (3, Right ()) @@ -58,7 +61,7 @@ "ParallelClock" [ testCase "chronological ticks" $ do let - (runningClock, _time) = runSchedule (initClock $ ParallelClock (FixedStep @5) (FixedStep @3) :: RunningClockInit (Schedule Integer) Integer (Either () ())) + (runningClock, _time) = runSchedule (initClock $ ParallelClock (FixedStep @5) (FixedStep @3) :: RunningClockInit (Schedule (Seconds Integer)) (Seconds Integer) (Either () ())) output = runSchedule $ embed runningClock $ replicate 6 () output @?= [ (3, Right ())