packages feed

rhine 1.3 → 1.4

raw patch · 14 files changed

+171/−77 lines, 14 filesdep ~automatondep ~monad-schedule

Dependency ranges changed: automaton, monad-schedule

Files

ChangeLog.md view
@@ -1,5 +1,12 @@ # Revision history for rhine +## 1.4++* Add `Profunctor` instance for `ResamplingBuffer`+* Fix imports of `FRP.Rhine` prelude+* Add `UTCClock` and `WaitUTCClock`, corresponding refactorings+* Remove unreliable `downsampleMillisecond` `ResamplingBuffer`+ ## 1.3  * Dropped `dunai` dependency in favour of state automata.
bench/Sum.hs view
@@ -16,7 +16,6 @@  import "automaton" Data.Stream as Stream (StreamT (..)) import "automaton" Data.Stream.Optimized (OptimizedStreamT (Stateful))-import "automaton" Data.Stream.Result (Result (..)) import "rhine" FRP.Rhine  nMax :: Int
rhine.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: rhine-version: 1.3+version: 1.4 synopsis: Functional Reactive Programming with type-level clocks description:   Rhine is a library for synchronous and asynchronous Functional Reactive Programming (FRP).@@ -31,7 +31,6 @@   test/assets/*.txt  tested-with:-  ghc ==9.0.2   ghc ==9.2.8   ghc ==9.4.7   ghc ==9.6.4@@ -44,13 +43,13 @@ source-repository this   type: git   location: https://github.com/turion/rhine.git-  tag: v1.3+  tag: v1.4  common opts   build-depends:-    automaton ^>=1.3,+    automaton ^>=1.4,     base >=4.14 && <4.20,-    monad-schedule ^>=0.1.2,+    monad-schedule ^>=0.2,     mtl >=2.2 && <2.4,     selective ^>=0.7,     text >=1.2 && <2.2,@@ -108,6 +107,7 @@     FRP.Rhine.Clock.FixedStep     FRP.Rhine.Clock.Periodic     FRP.Rhine.Clock.Proxy+    FRP.Rhine.Clock.Realtime     FRP.Rhine.Clock.Realtime.Audio     FRP.Rhine.Clock.Realtime.Busy     FRP.Rhine.Clock.Realtime.Event
src/FRP/Rhine.hs view
@@ -12,8 +12,12 @@ -} module FRP.Rhine (module X) where +-- time-domain+import Data.TimeDomain as X+ -- automaton import Data.Automaton as X+import Data.Stream.Result as X (Result (..))  -- rhine import Data.VectorSpace as X
src/FRP/Rhine/ClSF/Except.hs view
@@ -5,7 +5,7 @@ {- | This module provides exception handling, and thus control flow, to synchronous signal functions. -The API presented here closely follows @automaton@'s 'Data.Automaton.Trans.Except',+The API presented here closely follows @automaton@'s "Data.Automaton.Trans.Except", and reexports everything needed from there. -} module FRP.Rhine.ClSF.Except (
src/FRP/Rhine/ClSF/Util.hs view
@@ -29,6 +29,9 @@ -- simple-affine-space import Data.VectorSpace +-- time-domain+import Data.TimeDomain+ -- rhine import FRP.Rhine.ClSF.Core import FRP.Rhine.ClSF.Except@@ -67,7 +70,9 @@ tagS = timeInfoOf tag  {- |-Calculate the time passed since this 'ClSF' was instantiated.+Calculate the time passed since this 'ClSF' was instantiated,+i.e. since the first tick on which this 'ClSF' was run.+ This is _not_ the same as 'sinceInitS', which measures the time since clock initialisation. @@ -84,6 +89,11 @@ If you replace 'sinceStart' by 'sinceInitS', it will usually hang after one second, since it doesn't reset after restarting the sawtooth.++Even in the absence of conditional activation of 'ClSF's,+there is a difference:+For a clock that doesn't tick at its initialisation time,+'sinceStart' and 'sinceInitS' will have a constant offset of the duration between initialisation time and first tick. -} sinceStart :: (Monad m, TimeDomain time) => BehaviourF m time a (Diff time) sinceStart =
src/FRP/Rhine/Clock.hs view
@@ -15,11 +15,7 @@ and certain general constructions of 'Clock's, such as clocks lifted along monad morphisms or time rescalings. -}-module FRP.Rhine.Clock (-  module FRP.Rhine.Clock,-  module X,-)-where+module FRP.Rhine.Clock where  -- base import Control.Arrow@@ -33,7 +29,7 @@ import Data.Automaton (Automaton, arrM, hoistS)  -- time-domain-import Data.TimeDomain as X+import Data.TimeDomain  -- * The 'Clock' type class
src/FRP/Rhine/Clock/Except.hs view
@@ -15,6 +15,9 @@ import Control.Monad.Error.Class import Control.Monad.IO.Class (MonadIO, liftIO) +-- time-domain+import Data.TimeDomain (TimeDomain)+ -- automaton import Data.Automaton (hoistS) import Data.Automaton.Trans.Except@@ -26,7 +29,6 @@ import FRP.Rhine.Clock (   Clock (..),   HoistClock (..),-  TimeDomain,   TimeInfo (..),   retag,  )
+ src/FRP/Rhine/Clock/Realtime.hs view
@@ -0,0 +1,94 @@+module FRP.Rhine.Clock.Realtime where++-- base+import Control.Arrow (arr)+import Control.Concurrent (threadDelay)+import Control.Monad (guard)+import Control.Monad.IO.Class++-- time+import Data.Time (addUTCTime, diffUTCTime, getCurrentTime)++-- automaton+import Data.Automaton++-- rhine+import FRP.Rhine.Clock++-- time-domain+import Data.TimeDomain (Diff, UTCTime)++{- | A clock rescaled to the 'UTCTime' time domain.++There are different strategies how a clock may be rescaled, see below.+-}+type UTCClock m cl = RescaledClockS m cl UTCTime (Tag cl)++-- | Rescale an 'IO' clock to the UTC time domain, overwriting its timestamps.+overwriteUTC :: (MonadIO m) => cl -> UTCClock m cl+overwriteUTC cl =+  RescaledClockS+    { unscaledClockS = cl+    , rescaleS = const $ do+        now <- liftIO getCurrentTime+        return (arrM $ \(_timePassed, tag) -> (,tag) <$> liftIO getCurrentTime, now)+    }++{- | Rescale a clock to the UTC time domain.++The initial time stamp is measured as system time,+and the increments (durations between ticks) are taken from the original clock.+No attempt at waiting until the specified time is made,+the timestamps of the original clock are trusted unconditionally.+-}+addUTC :: (Real (Time cl), MonadIO m) => cl -> UTCClock m cl+addUTC cl =+  RescaledClockS+    { unscaledClockS = cl+    , rescaleS = const $ do+        now <- liftIO getCurrentTime+        return (arr $ \(timePassed, tag) -> (addUTCTime (realToFrac timePassed) now, tag), now)+    }++{- | Like 'UTCClock', but also output in the tag whether and by how much the target realtime was missed.++The original clock specifies with its time stamps when, relative to the initialisation time,+the UTC clock should tick.+A tag of @(tag, 'Nothing')@ means that the tick was in time.+@(tag, 'Just' dt)@ means that the tick was too late by @dt@.+-}+type WaitUTCClock m cl = RescaledClockS m cl UTCTime (Tag cl, Maybe (Diff (Time cl)))++{- | Measure the time after each tick, and wait for the remaining time until the next tick.++If the next tick should already have occurred @dt@ seconds ago,+the tag is set to @'Just' dt@, representing a failed real time attempt.++Note that this clock internally uses 'threadDelay' which can block+for quite a lot longer than the requested time, which can cause+'waitUTC' to miss one or more ticks when using a fast original clock.+When using 'threadDelay', the difference between the real wait time+and the requested wait time will be larger when using+the @-threaded@ ghc option (around 800 microseconds) than when not using+this option (around 100 microseconds). For fast clocks it is recommended+that @-threaded@ not be used in order to miss less ticks. The clock will adjust+the wait time, up to no wait time at all, to catch up when a tick is missed.+-}+waitUTC :: (Real (Time cl), MonadIO m, Fractional (Diff (Time cl))) => cl -> WaitUTCClock m cl+waitUTC unscaledClockS =+  RescaledClockS+    { unscaledClockS+    , rescaleS = \_ -> do+        initTime <- liftIO getCurrentTime+        let+          runningClock = arrM $ \(sinceInitTarget, tag) -> liftIO $ do+            beforeSleep <- getCurrentTime+            let+              diff :: Rational+              diff = toRational $ beforeSleep `diffUTCTime` initTime+              remaining = toRational sinceInitTarget - diff+            threadDelay $ round $ 1000000 * remaining+            now <- getCurrentTime+            return (now, (tag, guard (remaining > 0) >> return (fromRational remaining)))+        return (runningClock, initTime)+    }
src/FRP/Rhine/Clock/Realtime/Audio.hs view
@@ -33,6 +33,9 @@ import Data.Automaton import Data.Automaton.Trans.Except hiding (step) +-- time-domain+import Data.TimeDomain (diffTime)+ -- rhine import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy
src/FRP/Rhine/Clock/Realtime/Millisecond.hs view
@@ -9,88 +9,41 @@ module FRP.Rhine.Clock.Realtime.Millisecond where  -- base-import Control.Arrow-import Control.Concurrent (threadDelay)-import Control.Monad.IO.Class (liftIO)-import Data.Maybe (fromMaybe)+import Control.Arrow (arr, first, second, (>>>))+import Data.Functor ((<&>)) import GHC.TypeLits  -- time import Data.Time.Clock --- vector-sized-import Data.Vector.Sized (Vector, fromList)---- automaton-import Data.Automaton (arrM)- -- rhine import FRP.Rhine.Clock import FRP.Rhine.Clock.FixedStep import FRP.Rhine.Clock.Proxy+import FRP.Rhine.Clock.Realtime (WaitUTCClock, waitUTC) import FRP.Rhine.Clock.Unschedule-import FRP.Rhine.ResamplingBuffer-import FRP.Rhine.ResamplingBuffer.Collect-import FRP.Rhine.ResamplingBuffer.Util -{- |-A clock ticking every 'n' milliseconds,-in real time.+{- | A clock ticking every 'n' milliseconds, in real time.+ Since 'n' is in the type signature, it is ensured that when composing two signals on a 'Millisecond' clock, they will be driven at the same rate. -The tag of this clock is 'Bool',-where 'True' represents successful realtime,-and 'False' a lag.--}-newtype Millisecond (n :: Nat) = Millisecond (RescaledClockS IO (UnscheduleClock IO (FixedStep n)) UTCTime Bool)+For example, @'Millisecond' 100@ ticks every 0.1 seconds, so 10 times per seconds. --- TODO Consider changing the tag to Maybe Double+The tag of this clock is 'Maybe Double',+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))  instance Clock IO (Millisecond n) where   type Time (Millisecond n) = UTCTime-  type Tag (Millisecond n) = Bool-  initClock (Millisecond cl) = initClock cl+  type Tag (Millisecond n) = Maybe Double+  initClock (Millisecond cl) = initClock cl <&> first (>>> arr (second snd))  instance GetClockProxy (Millisecond n) -{- | This implementation measures the time after each tick,-   and waits for the remaining time until the next tick.-   If the next tick should already have occurred,-   the tag is set to 'False', representing a failed real time attempt.--   Note that this clock internally uses 'threadDelay' which can block-   for quite a lot longer than the requested time, which can cause-   the clock to miss one or more ticks when using low values of 'n'.-   When using 'threadDelay', the difference between the real wait time-   and the requested wait time will be larger when using-   the '-threaded' ghc option (around 800 microseconds) than when not using-   this option (around 100 microseconds). For low values of @n@ it is recommended-   that '-threaded' not be used in order to miss less ticks. The clock will adjust-   the wait time, up to no wait time at all, to catch up when a tick is missed.--}+-- | Tries to achieve real time by using 'waitUTC', see its docs. waitClock :: (KnownNat n) => Millisecond n-waitClock = Millisecond $ RescaledClockS (unyieldClock FixedStep) $ \_ -> do-  initTime <- liftIO getCurrentTime-  let-    runningClock = arrM $ \(n, ()) -> liftIO $ do-      beforeSleep <- getCurrentTime-      let-        diff :: Double-        diff = realToFrac $ beforeSleep `diffUTCTime` initTime-        remaining = fromInteger $ n * 1000 - round (diff * 1000000)-      threadDelay remaining-      now <- getCurrentTime -- TODO Test whether this is a performance penalty-      return (now, remaining > 0)-  return (runningClock, initTime)---- TODO It would be great if this could be directly implemented in terms of downsampleFixedStep-downsampleMillisecond ::-  (KnownNat n, Monad m) =>-  ResamplingBuffer m (Millisecond k) (Millisecond (n * k)) a (Vector n a)-downsampleMillisecond = collect >>-^ arr (fromList >>> assumeSize)-  where-    assumeSize =-      fromMaybe $-        error "downsampleMillisecond: Internal error. Please report this as a bug: https://github.com/turion/rhine/issues"+waitClock = Millisecond $ waitUTC $ RescaledClock (unyieldClock FixedStep) ((/ 1000) . fromInteger)
src/FRP/Rhine/Clock/Unschedule.hs view
@@ -15,6 +15,9 @@ -- automaton import Data.Automaton (hoistS) +-- time-domain+import Data.TimeDomain (Diff, TimeDomain)+ -- rhine import FRP.Rhine.Clock
src/FRP/Rhine/ResamplingBuffer.hs view
@@ -16,6 +16,9 @@ ) where +-- profunctors+import Data.Profunctor (Profunctor (..))+ -- automaton import Data.Stream.Result @@ -74,3 +77,20 @@     , get = (morph .) . get     , buffer     }++instance (Functor m) => Profunctor (ResamplingBuffer m cla clb) where+  lmap f ResamplingBuffer {put, get, buffer} =+    ResamplingBuffer+      { put = (. f) <$> put+      , get+      , buffer+      }+  rmap = fmap++instance (Functor m) => Functor (ResamplingBuffer m cla clb a) where+  fmap f ResamplingBuffer {put, get, buffer} =+    ResamplingBuffer+      { put+      , get = fmap (fmap (fmap f)) <$> get+      , buffer+      }
src/FRP/Rhine/ResamplingBuffer/Interpolation.hs view
@@ -14,6 +14,9 @@ -- simple-affine-space import Data.VectorSpace +-- time-domain+import Data.TimeDomain (Diff)+ -- rhine import FRP.Rhine.ClSF import FRP.Rhine.ResamplingBuffer