packages feed

rhine 0.8.1.1 → 0.9

raw patch · 44 files changed

+1907/−1650 lines, 44 filesdep ~dunaisetup-changed

Dependency ranges changed: dunai

Files

ChangeLog.md view
@@ -1,5 +1,9 @@ # Revision history for rhine +## 0.9++* dunai-0.9 compatibility+ ## 0.8.1.1  * Support for GHC 9.4.4
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
rhine.cabal view
@@ -1,6 +1,6 @@ name:                rhine -version:             0.8.1.1+version:             0.9  synopsis: Functional Reactive Programming with type-level clocks @@ -37,7 +37,7 @@  extra-doc-files:     README.md -cabal-version:       1.18+cabal-version:       2.0  tested-with:   GHC == 8.10.7@@ -52,7 +52,7 @@ source-repository this   type:     git   location: https://github.com/turion/rhine.git-  tag:      v0.8.1.1+  tag:      v0.9  library   exposed-modules:@@ -105,7 +105,7 @@    -- Other library packages from which modules are imported.   build-depends:       base         >= 4.14 && < 4.18-                     , dunai        >= 0.8+                     , dunai        ^>= 0.9                      , transformers >= 0.5                      , time         >= 1.8                      , free         >= 5.1
src/Control/Monad/Schedule.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE DeriveFunctor #-}+ {- | This module supplies a general purpose monad transformer that adds a syntactical "delay", or "waiting" side effect.@@ -6,11 +8,8 @@ that implement their waiting actions in 'ScheduleT'. See 'FRP.Rhine.Schedule.Trans' for more details. -}--{-# LANGUAGE DeriveFunctor #-} module Control.Monad.Schedule where - -- base import Control.Concurrent @@ -20,7 +19,6 @@ -- free import Control.Monad.Trans.Free - -- TODO Implement Time via StateT  {- |@@ -30,7 +28,7 @@ * 'a' is the encapsulated value. -} data Wait diff a = Wait diff a-  deriving Functor+  deriving (Functor)  {- | Values in @ScheduleT diff m@ are delayed computations with side effects in 'm'.@@ -39,36 +37,44 @@ -} type ScheduleT diff = FreeT (Wait diff) - -- | The side effect that waits for a specified amount. wait :: Monad m => diff -> ScheduleT diff m () wait diff = FreeT $ return $ Free $ Wait diff $ return () --- | Supply a semantic meaning to 'Wait'.---   For every occurrence of @Wait diff@ in the @ScheduleT diff m a@ value,---   a waiting action is executed, depending on 'diff'.+{- | Supply a semantic meaning to 'Wait'.+   For every occurrence of @Wait diff@ in the @ScheduleT diff m a@ value,+   a waiting action is executed, depending on 'diff'.+-} runScheduleT :: Monad m => (diff -> m ()) -> ScheduleT diff m a -> m a runScheduleT waitAction = iterT $ \(Wait n ma) -> waitAction n >> ma --- | Run a 'ScheduleT' value in a 'MonadIO',---   interpreting the times as milliseconds.-runScheduleIO-  :: (MonadIO m, Integral n)-  => ScheduleT n m a -> m a+{- | Run a 'ScheduleT' value in a 'MonadIO',+   interpreting the times as milliseconds.+-}+runScheduleIO ::+  (MonadIO m, Integral n) =>+  ScheduleT n m a ->+  m a runScheduleIO = runScheduleT $ liftIO . threadDelay . (* 1000) . fromIntegral  -- TODO The definition and type signature are both a mouthful. Is there a simpler concept?--- | Runs two values in 'ScheduleT' concurrently---   and returns the first one that yields a value---   (defaulting to the first argument),---   and a continuation for the other value.-race-  :: (Ord diff, Num diff, Monad m)-  => ScheduleT    diff m a -> ScheduleT diff m b-  -> ScheduleT    diff m (Either-       (                 a,   ScheduleT diff m b)-       (ScheduleT diff m a,                    b)-     )++{- | Runs two values in 'ScheduleT' concurrently+   and returns the first one that yields a value+   (defaulting to the first argument),+   and a continuation for the other value.+-}+race ::+  (Ord diff, Num diff, Monad m) =>+  ScheduleT diff m a ->+  ScheduleT diff m b ->+  ScheduleT+    diff+    m+    ( Either+        (a, ScheduleT diff m b)+        (ScheduleT diff m a, b)+    ) race (FreeT ma) (FreeT mb) = FreeT $ do   -- Perform the side effects to find out how long each 'ScheduleT' values need to wait.   aWait <- ma@@ -78,30 +84,32 @@     Pure a -> return $ Pure $ Left (a, FreeT $ return bWait)     -- 'a' needs to wait, so we need to inspect 'b' as well and see which one needs to wait longer.     Free (Wait aDiff aCont) -> case bWait of-    -- 'b' doesn't need to wait. Return immediately and leave the continuation for 'a'.+      -- 'b' doesn't need to wait. Return immediately and leave the continuation for 'a'.       Pure b -> return $ Pure $ Right (wait aDiff >> aCont, b)       -- Both need to wait. Which one needs to wait longer?-      Free (Wait bDiff bCont) -> if aDiff <= bDiff-        -- 'a' yields first, or both are done simultaneously.-        then runFreeT $ do-          -- Perform the wait action that we've deconstructed-          wait aDiff-          -- Recurse, since more wait actions might be hidden in 'a' and 'b'. 'b' doesn't need to wait as long, since we've already waited for 'aDiff'.-          race aCont $ wait (bDiff - aDiff) >> bCont-        -- 'b' yields first. Analogously.-        else runFreeT $ do-          wait bDiff-          race (wait (aDiff - bDiff) >> aCont) bCont+      Free (Wait bDiff bCont) ->+        if aDiff <= bDiff+          then -- 'a' yields first, or both are done simultaneously.+          runFreeT $ do+            -- Perform the wait action that we've deconstructed+            wait aDiff+            -- Recurse, since more wait actions might be hidden in 'a' and 'b'. 'b' doesn't need to wait as long, since we've already waited for 'aDiff'.+            race aCont $ wait (bDiff - aDiff) >> bCont+          else -- 'b' yields first. Analogously.+          runFreeT $ do+            wait bDiff+            race (wait (aDiff - bDiff) >> aCont) bCont  -- | Runs both schedules concurrently and returns their results at the end.-async-  :: (Ord diff, Num diff, Monad m)-  => ScheduleT diff m  a -> ScheduleT diff m b-  -> ScheduleT diff m (a,                    b)+async ::+  (Ord diff, Num diff, Monad m) =>+  ScheduleT diff m a ->+  ScheduleT diff m b ->+  ScheduleT diff m (a, b) async aSched bSched = do   ab <- race aSched bSched   case ab of-    Left  (a, bCont) -> do+    Left (a, bCont) -> do       b <- bCont       return (a, b)     Right (aCont, b) -> do
src/FRP/Rhine.hs view
@@ -4,52 +4,52 @@ so you will have to import those yourself, e.g. like this:  @-{-# LANGUAGE DataKinds #-} import FRP.Rhine import FRP.Rhine.Clock.Realtime.Millisecond  main :: IO ()-main = flow $ constMCl (putStrLn "Hello World!") @@ (waitClock :: Millisecond 100)+main = flow \$ constMCl (putStrLn \"Hello World!\") \@\@ (waitClock :: Millisecond 100) @ -} module FRP.Rhine (module X) where  -- dunai-import Data.MonadicStreamFunction         as X hiding ((>>>^), (^>>>))-import Data.VectorSpace                   as X+import Data.MonadicStreamFunction as X hiding ((>>>^), (^>>>))+import Data.VectorSpace as X  -- rhine-import FRP.Rhine.Clock                    as X-import FRP.Rhine.Clock.Proxy              as X-import FRP.Rhine.Clock.Util               as X-import FRP.Rhine.ClSF                     as X-import FRP.Rhine.Reactimation             as X++import FRP.Rhine.ClSF as X+import FRP.Rhine.Clock as X+import FRP.Rhine.Clock.Proxy as X+import FRP.Rhine.Clock.Util as X+import FRP.Rhine.Reactimation as X import FRP.Rhine.Reactimation.Combinators as X-import FRP.Rhine.ResamplingBuffer         as X-import FRP.Rhine.ResamplingBuffer.Util    as X-import FRP.Rhine.Schedule                 as X-import FRP.Rhine.SN                       as X-import FRP.Rhine.SN.Combinators           as X-import FRP.Rhine.Type                     as X+import FRP.Rhine.ResamplingBuffer as X+import FRP.Rhine.ResamplingBuffer.Util as X+import FRP.Rhine.SN as X+import FRP.Rhine.SN.Combinators as X+import FRP.Rhine.Schedule as X+import FRP.Rhine.Type as X  -- rhine (components) import FRP.Rhine.Clock.FixedStep as X import FRP.Rhine.Clock.Periodic as X-import FRP.Rhine.Clock.Realtime.Event as X-import FRP.Rhine.Clock.Realtime.Stdin as X import FRP.Rhine.Clock.Realtime.Audio as X import FRP.Rhine.Clock.Realtime.Busy as X+import FRP.Rhine.Clock.Realtime.Event as X import FRP.Rhine.Clock.Realtime.Millisecond as X+import FRP.Rhine.Clock.Realtime.Stdin as X import FRP.Rhine.Clock.Select as X -import FRP.Rhine.ResamplingBuffer.Interpolation as X-import FRP.Rhine.ResamplingBuffer.MSF as X+import FRP.Rhine.ResamplingBuffer.Collect as X import FRP.Rhine.ResamplingBuffer.FIFO as X+import FRP.Rhine.ResamplingBuffer.Interpolation as X+import FRP.Rhine.ResamplingBuffer.KeepLast as X import FRP.Rhine.ResamplingBuffer.LIFO as X-import FRP.Rhine.ResamplingBuffer.Collect as X+import FRP.Rhine.ResamplingBuffer.MSF as X import FRP.Rhine.ResamplingBuffer.Timeless as X-import FRP.Rhine.ResamplingBuffer.KeepLast as X -import FRP.Rhine.Schedule.Trans as X import FRP.Rhine.Schedule.Concurrently as X+import FRP.Rhine.Schedule.Trans as X import FRP.Rhine.Schedule.Util as X
src/FRP/Rhine/ClSF.hs view
@@ -7,13 +7,11 @@ and a wealth of utilities such as digital signal processing units. Documentation can be found in the individual modules. -}--module FRP.Rhine.ClSF ( module X ) where-+module FRP.Rhine.ClSF (module X) where  -- rhine-import FRP.Rhine.ClSF.Core   as X+import FRP.Rhine.ClSF.Core as X import FRP.Rhine.ClSF.Except as X import FRP.Rhine.ClSF.Random as X import FRP.Rhine.ClSF.Reader as X-import FRP.Rhine.ClSF.Util   as X+import FRP.Rhine.ClSF.Util as X
src/FRP/Rhine/ClSF/Core.hs view
@@ -1,19 +1,19 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+ {- | The core functionality of clocked signal functions, supplying the type of clocked signal functions itself ('ClSF'), behaviours (clock-independent/polymorphic signal functions), and basic constructions of 'ClSF's that may use awareness of time as an effect. -}--{-# LANGUAGE Arrows #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-module FRP.Rhine.ClSF.Core-  ( module FRP.Rhine.ClSF.Core-  , module Control.Arrow-  , module X-  )-  where+module FRP.Rhine.ClSF.Core (+  module FRP.Rhine.ClSF.Core,+  module Control.Arrow,+  module X,+)+where  -- base import Control.Arrow@@ -26,71 +26,75 @@ import Data.MonadicStreamFunction as X hiding ((>>>^), (^>>>))  -- rhine-import FRP.Rhine.Clock      as X-+import FRP.Rhine.Clock  -- * Clocked signal functions and behaviours --- | A (synchronous, clocked) monadic stream function---   with the additional side effect of being time-aware,---   that is, reading the current 'TimeInfo' of the clock @cl@.+{- | A (synchronous, clocked) monadic stream function+   with the additional side effect of being time-aware,+   that is, reading the current 'TimeInfo' of the clock @cl@.+-} type ClSF m cl a b = MSF (ReaderT (TimeInfo cl) m) a b --- | A clocked signal is a 'ClSF' with no input required.---   It produces its output on its own.-type ClSignal m cl a = forall arbitrary . ClSF m cl arbitrary a+{- | A clocked signal is a 'ClSF' with no input required.+   It produces its output on its own.+-}+type ClSignal m cl a = forall arbitrary. ClSF m cl arbitrary a --- | A (side-effectful) behaviour is a time-aware stream---   that doesn't depend on a particular clock.---   @time@ denotes the 'TimeDomain'.+{- | A (side-effectful) behaviour is a time-aware stream+   that doesn't depend on a particular clock.+   @time@ denotes the 'TimeDomain'.+-} type Behaviour m time a = forall cl. time ~ Time cl => ClSignal m cl a  -- | Compatibility to U.S. american spelling.-type Behavior  m time a = Behaviour m time a+type Behavior m time a = Behaviour m time a --- | A (side-effectful) behaviour function is a time-aware synchronous stream---   function that doesn't depend on a particular clock.---   @time@ denotes the 'TimeDomain'.+{- | A (side-effectful) behaviour function is a time-aware synchronous stream+   function that doesn't depend on a particular clock.+   @time@ denotes the 'TimeDomain'.+-} type BehaviourF m time a b = forall cl. time ~ Time cl => ClSF m cl a b  -- | Compatibility to U.S. american spelling.-type BehaviorF  m time a b = BehaviourF m time a b+type BehaviorF m time a b = BehaviourF m time a b  -- * Utilities to create 'ClSF's from simpler data  -- | Hoist a 'ClSF' along a monad morphism.-hoistClSF-  :: (Monad m1, Monad m2)-  => (forall c. m1 c -> m2 c)-  -> ClSF m1 cl a b-  -> ClSF m2 cl a b+hoistClSF ::+  (Monad m1, Monad m2) =>+  (forall c. m1 c -> m2 c) ->+  ClSF m1 cl a b ->+  ClSF m2 cl a b hoistClSF hoist = morphS $ mapReaderT hoist  -- | Hoist a 'ClSF' and its clock along a monad morphism.-hoistClSFAndClock-  :: (Monad m1, Monad m2)-  => (forall c. m1 c -> m2 c)-  -> ClSF m1 cl a b-  -> ClSF m2 (HoistClock m1 m2 cl) a b-hoistClSFAndClock hoist-  = morphS $ withReaderT (retag id) . mapReaderT hoist+hoistClSFAndClock ::+  (Monad m1, Monad m2) =>+  (forall c. m1 c -> m2 c) ->+  ClSF m1 cl a b ->+  ClSF m2 (HoistClock m1 m2 cl) a b+hoistClSFAndClock hoist =+  morphS $ withReaderT (retag id) . mapReaderT hoist  -- | Lift a 'ClSF' into a monad transformer.-liftClSF-  :: (Monad m, MonadTrans t, Monad (t m))-  => ClSF    m  cl a b-  -> ClSF (t m) cl a b+liftClSF ::+  (Monad m, MonadTrans t, Monad (t m)) =>+  ClSF m cl a b ->+  ClSF (t m) cl a b liftClSF = hoistClSF lift  -- | Lift a 'ClSF' and its clock into a monad transformer.-liftClSFAndClock-  :: (Monad m, MonadTrans t, Monad (t m))-  => ClSF    m                 cl  a b-  -> ClSF (t m) (LiftClock m t cl) a b+liftClSFAndClock ::+  (Monad m, MonadTrans t, Monad (t m)) =>+  ClSF m cl a b ->+  ClSF (t m) (LiftClock m t cl) a b liftClSFAndClock = hoistClSFAndClock lift --- | A monadic stream function without dependency on time---   is a 'ClSF' for any clock.+{- | A monadic stream function without dependency on time+   is a 'ClSF' for any clock.+-} timeless :: Monad m => MSF m a b -> ClSF m cl a b timeless = liftTransS @@ -112,11 +116,12 @@ The former only integrates when the input is @Just 1@, whereas the latter always returns the correct time since initialisation. -}-mapMaybe-  :: Monad m-  => ClSF m cl        a         b-  -> ClSF m cl (Maybe a) (Maybe b)+mapMaybe ::+  Monad m =>+  ClSF m cl a b ->+  ClSF m cl (Maybe a) (Maybe b) mapMaybe behaviour = proc ma -> case ma of-  Nothing -> returnA                -< Nothing-  Just a  -> arr Just <<< behaviour -< a+  Nothing -> returnA -< Nothing+  Just a -> arr Just <<< behaviour -< a+ -- TODO Consider integrating up the time deltas
src/FRP/Rhine/ClSF/Except.hs view
@@ -1,20 +1,23 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+ {- | This module provides exception handling, and thus control flow, to synchronous signal functions.  The API presented here closely follows dunai's 'Control.Monad.Trans.MSF.Except', and reexports everything needed from there. -}--{-# LANGUAGE Arrows #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}--module FRP.Rhine.ClSF.Except-  ( module FRP.Rhine.ClSF.Except-  , module X-  , safe, safely, exceptS, runMSFExcept, currentInput-  )-  where+module FRP.Rhine.ClSF.Except (+  module FRP.Rhine.ClSF.Except,+  module X,+  safe,+  safely,+  exceptS,+  runMSFExcept,+  currentInput,+)+where  -- base import qualified Control.Category as Category@@ -25,18 +28,19 @@ import Control.Monad.Trans.Reader  -- dunai+import Control.Monad.Trans.MSF.Except hiding (once, once_, throwOn, throwOn', throwS, try) import Data.MonadicStreamFunction-import Control.Monad.Trans.MSF.Except hiding (try, once, once_, throwOn, throwOn', throwS)+ -- TODO Find out whether there is a cleverer way to handle exports import qualified Control.Monad.Trans.MSF.Except as MSFE  -- rhine import FRP.Rhine.ClSF.Core import FRP.Rhine.ClSF.Except.Util+import FRP.Rhine.Clock  -- * Throwing exceptions - -- | Immediately throw the incoming exception. throwS :: Monad m => ClSF (ExceptT e m) cl e a throwS = arrMCl throwE@@ -55,30 +59,33 @@  -- | Variant of 'throwOn', where the exception can vary every tick. throwOn' :: Monad m => ClSF (ExceptT e m) cl (Bool, e) ()-throwOn' = proc (b, e) -> if b-  then throwS  -< e-  else returnA -< ()+throwOn' = proc (b, e) ->+  if b+    then throwS -< e+    else returnA -< ()  -- | Throw the exception 'e' whenever the function evaluates to 'True'. throwOnCond :: Monad m => (a -> Bool) -> e -> ClSF (ExceptT e m) cl a a-throwOnCond cond e = proc a -> if cond a-  then throwS  -< e-  else returnA -< a+throwOnCond cond e = proc a ->+  if cond a+    then throwS -< e+    else returnA -< a --- | Variant of 'throwOnCond' for Kleisli arrows.--- | Throws the exception when the input is 'True'.+{- | Variant of 'throwOnCond' for Kleisli arrows.+   Throws the exception when the input is 'True'.+-} throwOnCondM :: Monad m => (a -> m Bool) -> e -> ClSF (ExceptT e m) cl a a throwOnCondM cond e = proc a -> do   b <- arrMCl (lift . cond) -< a   if b-    then throwS  -< e+    then throwS -< e     else returnA -< a  -- | When the input is @Just e@, throw the exception @e@. throwMaybe :: Monad m => ClSF (ExceptT e m) cl (Maybe e) (Maybe a) throwMaybe = proc me -> case me of   Nothing -> returnA -< Nothing-  Just e  -> throwS  -< e+  Just e -> throwS -< e  -- * Monad interface @@ -101,25 +108,26 @@ or equivalently an exception-throwing behaviour. Any clock with time domain @time@ may occur. -}-type BehaviourFExcept m time a b e-  = forall cl. time ~ Time cl => ClSFExcept m cl a b e+type BehaviourFExcept m time a b e =+  forall cl. time ~ Time cl => ClSFExcept m cl a b e  -- | Compatibility to U.S. american spelling. type BehaviorFExcept m time a b e = BehaviourFExcept m time a b e - -- | Leave the monad context, to use the 'ClSFExcept' as an 'Arrow'. runClSFExcept :: Monad m => ClSFExcept m cl a b e -> ClSF (ExceptT e m) cl a b runClSFExcept = morphS commuteExceptReader . runMSFExcept --- | Enter the monad context in the exception---   for 'ClSF's in the 'ExceptT' monad.---   The 'ClSF' will be run until it encounters an exception.+{- | Enter the monad context in the exception+   for 'ClSF's in the 'ExceptT' monad.+   The 'ClSF' will be run until it encounters an exception.+-} try :: Monad m => ClSF (ExceptT e m) cl a b -> ClSFExcept m cl a b e try = MSFE.try . morphS commuteReaderExcept --- | Within the same tick, perform a monadic action,---   and immediately throw the value as an exception.+{- | Within the same tick, perform a monadic action,+   and immediately throw the value as an exception.+-} once :: Monad m => (a -> m e) -> ClSFExcept m cl a b e once f = MSFE.once $ lift . f @@ -127,8 +135,8 @@ once_ :: Monad m => m e -> ClSFExcept m cl a b e once_ = once . const ---- | Advances a single tick with the given Kleisli arrow,---   and then throws an exception.+{- | Advances a single tick with the given Kleisli arrow,+   and then throws an exception.+-} step :: Monad m => (a -> m (b, e)) -> ClSFExcept m cl a b e step f = MSFE.step $ lift . f
src/FRP/Rhine/ClSF/Except/Util.hs view
@@ -1,7 +1,6 @@-{-|+{- | Utilities for 'FRP.Rhine.ClSF.Except' that need not be exported. -}- module FRP.Rhine.ClSF.Except.Util where  -- transformers
src/FRP/Rhine/ClSF/Random.hs view
@@ -1,16 +1,16 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-}--- | Create 'ClSF's with randomness without 'IO'.---   Uses the @MonadRandom@ package.---   This module copies the API from @dunai@'s---   'Control.Monad.Trans.MSF.Random'. -module FRP.Rhine.ClSF.Random-  ( module FRP.Rhine.ClSF.Random-  , module X-  )-  where-+{- | Create 'ClSF's with randomness without 'IO'.+   Uses the @MonadRandom@ package.+   This module copies the API from @dunai@'s+   'Control.Monad.Trans.MSF.Random'.+-}+module FRP.Rhine.ClSF.Random (+  module FRP.Rhine.ClSF.Random,+  module X,+)+where  -- transformers import Control.Monad.IO.Class@@ -20,8 +20,8 @@  -- dunai import Control.Monad.Trans.MSF.Except (performOnFirstSample)+import Control.Monad.Trans.MSF.Random as X hiding (evalRandS, getRandomRS, getRandomRS_, getRandomS, runRandS) import qualified Control.Monad.Trans.MSF.Random as MSF-import Control.Monad.Trans.MSF.Random as X hiding (runRandS, evalRandS, getRandomS, getRandomRS, getRandomRS_)  -- rhine import FRP.Rhine.ClSF.Core@@ -30,65 +30,67 @@ -- * Generating random values from the 'RandT' transformer  -- | Generates random values, updating the generator on every step.-runRandS-  :: (RandomGen g, Monad m)-  => ClSF (RandT g m) cl a     b-  -> g -- ^ The initial random seed-  -> ClSF          m  cl a (g, b)-runRandS clsf g = MSF.runRandS (morphS commuteReaderRand clsf) g+runRandS ::+  (RandomGen g, Monad m) =>+  ClSF (RandT g m) cl a b ->+  -- | The initial random seed+  g ->+  ClSF m cl a (g, b)+runRandS clsf = MSF.runRandS (morphS commuteReaderRand clsf)  -- | Updates the generator every step but discards the generator.-evalRandS-  :: (RandomGen g, Monad m)-  => ClSF (RandT g m) cl a b-  -> g-  -> ClSF          m  cl a b+evalRandS ::+  (RandomGen g, Monad m) =>+  ClSF (RandT g m) cl a b ->+  g ->+  ClSF m cl a b evalRandS clsf g = runRandS clsf g >>> arr snd --- | Updates the generator every step but discards the value,---   only outputting the generator.-execRandS-  :: (RandomGen g, Monad m)-  => ClSF (RandT g m) cl a b-  -> g-  -> ClSF          m  cl a g+{- | Updates the generator every step but discards the value,+   only outputting the generator.+-}+execRandS ::+  (RandomGen g, Monad m) =>+  ClSF (RandT g m) cl a b ->+  g ->+  ClSF m cl a g execRandS clsf g = runRandS clsf g >>> arr fst  -- | Evaluates the random computation by using the global random generator.-evalRandIOS-  :: Monad m-  =>     ClSF (RandT StdGen m) cl a b-  -> IO (ClSF               m  cl a b)-evalRandIOS clsf = do-  g <- newStdGen-  return $ evalRandS clsf g+evalRandIOS ::+  Monad m =>+  ClSF (RandT StdGen m) cl a b ->+  IO (ClSF m cl a b)+evalRandIOS clsf = evalRandS clsf <$> newStdGen  -- | Evaluates the random computation by using the global random generator on the first tick.-evalRandIOS'-  :: MonadIO m-  => ClSF (RandT StdGen m) cl a b-  -> ClSF               m  cl a b+evalRandIOS' ::+  MonadIO m =>+  ClSF (RandT StdGen m) cl a b ->+  ClSF m cl a b evalRandIOS' = performOnFirstSample . liftIO . evalRandIOS  -- * Creating random behaviours  -- | Produce a random value at every tick.-getRandomS-  :: (MonadRandom m, Random a)-  => Behaviour m time a+getRandomS ::+  (MonadRandom m, Random a) =>+  Behaviour m time a getRandomS = constMCl getRandom --- | Produce a random value at every tick,---   within a range given per tick.-getRandomRS-  :: (MonadRandom m, Random a)-  => BehaviourF m time (a, a) a+{- | Produce a random value at every tick,+   within a range given per tick.+-}+getRandomRS ::+  (MonadRandom m, Random a) =>+  BehaviourF m time (a, a) a getRandomRS = arrMCl getRandomR --- | Produce a random value at every tick,---   within a range given once.-getRandomRS_-  :: (MonadRandom m, Random a)-  => (a, a)-  -> Behaviour m time a+{- | Produce a random value at every tick,+   within a range given once.+-}+getRandomRS_ ::+  (MonadRandom m, Random a) =>+  (a, a) ->+  Behaviour m time a getRandomRS_ range = constMCl $ getRandomR range
src/FRP/Rhine/ClSF/Random/Util.hs view
@@ -1,6 +1,5 @@ module FRP.Rhine.ClSF.Random.Util where - -- transformers import Control.Monad.Trans.Reader @@ -10,4 +9,3 @@ -- | Commute one 'ReaderT' layer past a 'RandT' layer. commuteReaderRand :: ReaderT r (RandT g m) a -> RandT g (ReaderT r m) a commuteReaderRand (ReaderT f) = liftRandT $ \g -> ReaderT $ \r -> runRandT (f r) g-
src/FRP/Rhine/ClSF/Reader.hs view
@@ -1,10 +1,10 @@-{- |-Create and remove 'ReaderT' layers in 'ClSF's.--}- {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-}++{- |+Create and remove 'ReaderT' layers in 'ClSF's.+-} module FRP.Rhine.ClSF.Reader where  -- base@@ -19,31 +19,36 @@ -- rhine import FRP.Rhine.ClSF.Core - -- | Commute two 'ReaderT' transformer layers past each other commuteReaders :: ReaderT r1 (ReaderT r2 m) a -> ReaderT r2 (ReaderT r1 m) a-commuteReaders a-  = ReaderT $ \r1 -> ReaderT $ \r2 -> runReaderT (runReaderT a r2) r1+commuteReaders a =+  ReaderT $ \r1 -> ReaderT $ \r2 -> runReaderT (runReaderT a r2) r1 --- | Create ("wrap") a 'ReaderT' layer in the monad stack of a behaviour.---   Each tick, the 'ReaderT' side effect is performed---   by passing the original behaviour the extra @r@ input.-readerS-  :: Monad m-  => ClSF m cl (a, r) b -> ClSF (ReaderT r m) cl a b-readerS behaviour-  = morphS commuteReaders $ MSF.readerS $ arr swap >>> behaviour+{- | Create ("wrap") a 'ReaderT' layer in the monad stack of a behaviour.+   Each tick, the 'ReaderT' side effect is performed+   by passing the original behaviour the extra @r@ input.+-}+readerS ::+  Monad m =>+  ClSF m cl (a, r) b ->+  ClSF (ReaderT r m) cl a b+readerS behaviour =+  morphS commuteReaders $ MSF.readerS $ arr swap >>> behaviour --- | Remove ("run") a 'ReaderT' layer from the monad stack---   by making it an explicit input to the behaviour.-runReaderS-  :: Monad m-  => ClSF (ReaderT r m) cl a b -> ClSF m cl (a, r) b-runReaderS behaviour-  = arr swap >>> (MSF.runReaderS $ morphS commuteReaders behaviour)+{- | Remove ("run") a 'ReaderT' layer from the monad stack+   by making it an explicit input to the behaviour.+-}+runReaderS ::+  Monad m =>+  ClSF (ReaderT r m) cl a b ->+  ClSF m cl (a, r) b+runReaderS behaviour =+  arr swap >>> MSF.runReaderS (morphS commuteReaders behaviour)  -- | Remove a 'ReaderT' layer by passing the readonly environment explicitly.-runReaderS_-  :: Monad m-  => ClSF (ReaderT r m) cl a b -> r -> ClSF m cl a b-runReaderS_ behaviour r = arr (, r) >>> runReaderS behaviour+runReaderS_ ::+  Monad m =>+  ClSF (ReaderT r m) cl a b ->+  r ->+  ClSF m cl a b+runReaderS_ behaviour r = arr (,r) >>> runReaderS behaviour
src/FRP/Rhine/ClSF/Upsample.hs view
@@ -1,9 +1,9 @@--- | Utilities to run 'ClSF's at the speed of combined clocks---   when they are defined only for a constituent clock.- {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} +{- | Utilities to run 'ClSF's at the speed of combined clocks+   when they are defined only for a constituent clock.+-} module FRP.Rhine.ClSF.Upsample where  -- dunai@@ -11,41 +11,48 @@  -- rhine import FRP.Rhine.ClSF.Core+import FRP.Rhine.Clock import FRP.Rhine.Schedule --- | An 'MSF' can be given arbitrary other arguments---   that cause it to tick without doing anything---   and replicating the last output.+{- | An 'MSF' can be given arbitrary other arguments+   that cause it to tick without doing anything+   and replicating the last output.+-} upsampleMSF :: Monad m => b -> MSF m a b -> MSF m (Either arbitrary a) b upsampleMSF b msf = right msf >>> accumulateWith (<>) (Right b) >>> arr fromRight   where     fromRight (Right b') = b'-    fromRight (Left  _ ) = error "fromRight: This case never occurs in upsampleMSF."+    fromRight (Left _) = error "fromRight: This case never occurs in upsampleMSF."+ -- Note that the Semigroup instance of Either a arbitrary -- updates when the first argument is Right. ---- | Upsample a 'ClSF' to a parallel clock.---   The given 'ClSF' is only called when @clR@ ticks,---   otherwise the last output is replicated---   (with the given @b@ as initialisation).-upsampleR-  :: (Monad m, Time clL ~ Time clR)-  => b -> ClSF m clR a b -> ClSF m (ParallelClock m clL clR) a b+{- | Upsample a 'ClSF' to a parallel clock.+   The given 'ClSF' is only called when @clR@ ticks,+   otherwise the last output is replicated+   (with the given @b@ as initialisation).+-}+upsampleR ::+  (Monad m, Time clL ~ Time clR) =>+  b ->+  ClSF m clR a b ->+  ClSF m (ParallelClock m clL clR) a b upsampleR b clsf = readerS $ arr remap >>> upsampleMSF b (runReaderS clsf)   where-    remap (TimeInfo { tag = Left  tag     }, _) = Left tag-    remap (TimeInfo { tag = Right tag, .. }, a) = Right (TimeInfo { .. }, a)-+    remap (TimeInfo {tag = Left tag}, _) = Left tag+    remap (TimeInfo {tag = Right tag, ..}, a) = Right (TimeInfo {..}, a) --- | Upsample a 'ClSF' to a parallel clock.---   The given 'ClSF' is only called when @clL@ ticks,---   otherwise the last output is replicated---   (with the given @b@ as initialisation).-upsampleL-  :: (Monad m, Time clL ~ Time clR)-  => b -> ClSF m clL a b -> ClSF m (ParallelClock m clL clR) a b+{- | Upsample a 'ClSF' to a parallel clock.+   The given 'ClSF' is only called when @clL@ ticks,+   otherwise the last output is replicated+   (with the given @b@ as initialisation).+-}+upsampleL ::+  (Monad m, Time clL ~ Time clR) =>+  b ->+  ClSF m clL a b ->+  ClSF m (ParallelClock m clL clR) a b upsampleL b clsf = readerS $ arr remap >>> upsampleMSF b (runReaderS clsf)   where-    remap (TimeInfo { tag = Right tag     }, _) = Left tag-    remap (TimeInfo { tag = Left  tag, .. }, a) = Right (TimeInfo { .. }, a)+    remap (TimeInfo {tag = Right tag}, _) = Left tag+    remap (TimeInfo {tag = Left tag, ..}, a) = Right (TimeInfo {..}, a)
src/FRP/Rhine/ClSF/Util.hs view
@@ -1,19 +1,17 @@-{- |-Utilities to create 'ClSF's.-The fundamental effect that 'ClSF's have is-reading the time information of the clock.-It can be used for many purposes, for example digital signal processing.--}- {-# LANGUAGE Arrows #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} +{- |+Utilities to create 'ClSF's.+The fundamental effect that 'ClSF's have is+reading the time information of the clock.+It can be used for many purposes, for example digital signal processing.+-} module FRP.Rhine.ClSF.Util where - -- base import Control.Arrow import Control.Category (Category)@@ -37,7 +35,7 @@ -- rhine import FRP.Rhine.ClSF.Core import FRP.Rhine.ClSF.Except-+import FRP.Rhine.Clock  -- * Read time information @@ -91,14 +89,15 @@ since it doesn't reset after restarting the sawtooth. -} sinceStart :: (Monad m, TimeDomain time) => BehaviourF m time a (Diff time)-sinceStart = absoluteS >>> proc time -> do-  startTime <- keepFirst -< time-  returnA                -< time `diffTime` startTime-+sinceStart =+  absoluteS >>> proc time -> do+    startTime <- keepFirst -< time+    returnA -< time `diffTime` startTime  -- * Useful aliases  -- TODO Is it cleverer to generalise to Arrow?+ {- | Alias for 'Control.Category.>>>' (sequential composition) with higher operator precedence, designed to work with the other operators, e.g.: @@ -109,18 +108,22 @@ > (>->) :: Monad m => ClSF m cl a b -> ClSF m cl b c -> ClSF m cl a c -} infixr 6 >->-(>->) :: Category cat-      => cat a b-      -> cat   b c-      -> cat a   c++(>->) ::+  Category cat =>+  cat a b ->+  cat b c ->+  cat a c (>->) = (>>>)  -- | Alias for 'Control.Category.<<<'. infixl 6 <-<-(<-<) :: Category cat-      => cat   b c-      -> cat a b-      -> cat a   c++(<-<) ::+  Category cat =>+  cat b c ->+  cat a b ->+  cat a c (<-<) = (<<<)  {- | Output a constant value.@@ -131,183 +134,227 @@ arr_ :: Arrow a => b -> a c b arr_ = arr . const - -- | The identity synchronous stream function. clId :: Monad m => ClSF m cl a a clId = Control.Category.id - -- * Basic signal processing components  -- ** Integration and differentiation --- | The output of @integralFrom v0@ is the numerical Euler integral---   of the input, with initial offset @v0@.-integralFrom-  :: ( Monad m, VectorSpace v s-     , s ~ Diff td)-  => v -> BehaviorF m td v v+{- | The output of @integralFrom v0@ is the numerical Euler integral+   of the input, with initial offset @v0@.+-}+integralFrom ::+  ( Monad m+  , VectorSpace v s+  , s ~ Diff td+  ) =>+  v ->+  BehaviorF m td v v integralFrom v0 = proc v -> do   _sinceLast <- timeInfoOf sinceLast -< ()-  sumFrom v0                         -< _sinceLast *^ v+  sumFrom v0 -< _sinceLast *^ v  -- | Euler integration, with zero initial offset.-integral-  :: ( Monad m, VectorSpace v s-     , s ~ Diff td)-  => BehaviorF m td v v+integral ::+  ( Monad m+  , VectorSpace v s+  , s ~ Diff td+  ) =>+  BehaviorF m td v v integral = integralFrom zeroVector ---- | The output of @derivativeFrom v0@ is the numerical derivative of the input,---   with a Newton difference quotient.---   The input is initialised with @v0@.-derivativeFrom-  :: ( Monad m, VectorSpace v s-     , s ~ Diff td)-  => v -> BehaviorF m td v v+{- | The output of @derivativeFrom v0@ is the numerical derivative of the input,+   with a Newton difference quotient.+   The input is initialised with @v0@.+-}+derivativeFrom ::+  ( Monad m+  , VectorSpace v s+  , s ~ Diff td+  ) =>+  v ->+  BehaviorF m td v v derivativeFrom v0 = proc v -> do-  vLast         <- iPre v0  -< v+  vLast <- iPre v0 -< v   TimeInfo {..} <- timeInfo -< ()-  returnA                   -< (v ^-^ vLast) ^/ sinceLast+  returnA -< (v ^-^ vLast) ^/ sinceLast  -- | Numerical derivative with input initialised to zero.-derivative-  :: ( Monad m, VectorSpace v s-     , s ~ Diff td)-  => BehaviorF m td v v+derivative ::+  ( Monad m+  , VectorSpace v s+  , s ~ Diff td+  ) =>+  BehaviorF m td v v derivative = derivativeFrom zeroVector --- | Like 'derivativeFrom', but uses three samples to compute the derivative.---   Consequently, it is delayed by one sample.-threePointDerivativeFrom-  :: ( Monad m, VectorSpace v s-     , s ~ Diff td)-  => v -- ^ The initial position-  -> BehaviorF m td v v+{- | Like 'derivativeFrom', but uses three samples to compute the derivative.+   Consequently, it is delayed by one sample.+-}+threePointDerivativeFrom ::+  ( Monad m+  , VectorSpace v s+  , s ~ Diff td+  ) =>+  -- | The initial position+  v ->+  BehaviorF m td v v threePointDerivativeFrom v0 = proc v -> do-  dv  <- derivativeFrom v0 -< v-  dv' <- iPre zeroVector   -< dv-  returnA                  -< (dv ^+^ dv') ^/ 2+  dv <- derivativeFrom v0 -< v+  dv' <- iPre zeroVector -< dv+  returnA -< (dv ^+^ dv') ^/ 2 --- | Like 'threePointDerivativeFrom',---   but with the initial position initialised to 'zeroVector'.-threePointDerivative-  :: ( Monad m, VectorSpace v s-     , s ~ Diff td)-  => BehaviorF m td v v+{- | Like 'threePointDerivativeFrom',+   but with the initial position initialised to 'zeroVector'.+-}+threePointDerivative ::+  ( Monad m+  , VectorSpace v s+  , s ~ Diff td+  ) =>+  BehaviorF m td v v threePointDerivative = threePointDerivativeFrom zeroVector  -- ** Averaging and filters --- | A weighted moving average signal function.---   The output is the average of the first input,---   weighted by the second input---   (which is assumed to be always between 0 and 1).---   The weight is applied to the average of the last tick,---   so a weight of 1 simply repeats the past value unchanged,---   whereas a weight of 0 outputs the current value.-weightedAverageFrom-  :: ( Monad m, VectorSpace v s-     , s ~ Diff td)-  => v -- ^ The initial position-  -> BehaviorF m td (v, s) v+{- | A weighted moving average signal function.+   The output is the average of the first input,+   weighted by the second input+   (which is assumed to be always between 0 and 1).+   The weight is applied to the average of the last tick,+   so a weight of 1 simply repeats the past value unchanged,+   whereas a weight of 0 outputs the current value.+-}+weightedAverageFrom ::+  ( Monad m+  , VectorSpace v s+  , s ~ Diff td+  ) =>+  -- | The initial position+  v ->+  BehaviorF m td (v, s) v weightedAverageFrom v0 = feedback v0 $ proc ((v, weight), vAvg) -> do   let     vAvg' = weight *^ vAvg ^+^ (1 - weight) *^ v   returnA -< (vAvg', vAvg') --- | An exponential moving average, or low pass.---   It will average out, or filter,---   all features below a given time constant @t@.---   (Equivalently, it filters out frequencies above @1 / (2 * pi * t)@.)-averageFrom-  :: ( Monad m, VectorSpace v s-     , Floating s-     , s ~ Diff td)-  => v -- ^ The initial position-  -> Diff td -- ^ The time scale on which the signal is averaged-  -> BehaviorF m td v v+{- | An exponential moving average, or low pass.+   It will average out, or filter,+   all features below a given time constant @t@.+   (Equivalently, it filters out frequencies above @1 / (2 * pi * t)@.)+-}+averageFrom ::+  ( Monad m+  , VectorSpace v s+  , Floating s+  , s ~ Diff td+  ) =>+  -- | The initial position+  v ->+  -- | The time scale on which the signal is averaged+  Diff td ->+  BehaviorF m td v v averageFrom v0 t = proc v -> do   TimeInfo {..} <- timeInfo -< ()   let-    weight = exp $ - (sinceLast / t)-  weightedAverageFrom v0    -< (v, weight)-+    weight = exp $ -(sinceLast / t)+  weightedAverageFrom v0 -< (v, weight)  -- | An average, or low pass, initialised to zero.-average-  :: ( Monad m, VectorSpace v s-     , Floating s-     , s ~ Diff td)-  => Diff td -- ^ The time scale on which the signal is averaged-  -> BehaviourF m td v v+average ::+  ( Monad m+  , VectorSpace v s+  , Floating s+  , s ~ Diff td+  ) =>+  -- | The time scale on which the signal is averaged+  Diff td ->+  BehaviourF m td v v average = averageFrom zeroVector --- | A linearised version of 'averageFrom'.---   It is more efficient, but only accurate---   if the supplied time scale is much bigger---   than the average time difference between two ticks.-averageLinFrom-  :: ( Monad m, VectorSpace v s-     , s ~ Diff td)-  => v -- ^ The initial position-  -> Diff td -- ^ The time scale on which the signal is averaged-  -> BehaviourF m td v v+{- | A linearised version of 'averageFrom'.+   It is more efficient, but only accurate+   if the supplied time scale is much bigger+   than the average time difference between two ticks.+-}+averageLinFrom ::+  ( Monad m+  , VectorSpace v s+  , s ~ Diff td+  ) =>+  -- | The initial position+  v ->+  -- | The time scale on which the signal is averaged+  Diff td ->+  BehaviourF m td v v averageLinFrom v0 t = proc v -> do   TimeInfo {..} <- timeInfo -< ()   let     weight = t / (sinceLast + t)-  weightedAverageFrom v0    -< (v, weight)+  weightedAverageFrom v0 -< (v, weight)  -- | Linearised version of 'average'.-averageLin-  :: ( Monad m, VectorSpace v s-     , s ~ Diff td)-  => Diff td -- ^ The time scale on which the signal is averaged-  -> BehaviourF m td v v+averageLin ::+  ( Monad m+  , VectorSpace v s+  , s ~ Diff td+  ) =>+  -- | The time scale on which the signal is averaged+  Diff td ->+  BehaviourF m td v v averageLin = averageLinFrom zeroVector  -- *** First-order filters  -- | Alias for 'average'.-lowPass-  :: ( Monad m, VectorSpace v s-     , Floating s-     , s ~ Diff td)-  => Diff td-  -> BehaviourF m td v v+lowPass ::+  ( Monad m+  , VectorSpace v s+  , Floating s+  , s ~ Diff td+  ) =>+  Diff td ->+  BehaviourF m td v v lowPass = average  -- | Filters out frequencies below @1 / (2 * pi * t)@.-highPass-  :: ( Monad m, VectorSpace v s-     , Floating s-     , s ~ Diff td)-  => Diff td -- ^ The time constant @t@-  -> BehaviourF m td v v+highPass ::+  ( Monad m+  , VectorSpace v s+  , Floating s+  , s ~ Diff td+  ) =>+  -- | The time constant @t@+  Diff td ->+  BehaviourF m td v v highPass t = clId ^-^ lowPass t  -- | Filters out frequencies other than @1 / (2 * pi * t)@.-bandPass-  :: ( Monad m, VectorSpace v s-     , Floating s-     , s ~ Diff td)-  => Diff td -- ^ The time constant @t@-  -> BehaviourF m td v v+bandPass ::+  ( Monad m+  , VectorSpace v s+  , Floating s+  , s ~ Diff td+  ) =>+  -- | The time constant @t@+  Diff td ->+  BehaviourF m td v v bandPass t = lowPass t >>> highPass t  -- | Filters out the frequency @1 / (2 * pi * t)@.-bandStop-  :: ( Monad m, VectorSpace v s-     , Floating s-     , s ~ Diff td)-  => Diff td -- ^ The time constant @t@-  -> BehaviourF m td v v+bandStop ::+  ( Monad m+  , VectorSpace v s+  , Floating s+  , s ~ Diff td+  ) =>+  -- | The time constant @t@+  Diff td ->+  BehaviourF m td v v bandStop t = clId ^-^ bandPass t -- -- * Delays  -- | Remembers and indefinitely outputs ("holds") the first input value.@@ -316,69 +363,74 @@   a <- try throwS   safe $ arr $ const a --- | Remembers all input values that arrived within a given time window.---   New values are appended left.-historySince-  :: (Monad m, Ord (Diff (Time cl)), TimeDomain (Time cl))-  => Diff (Time cl) -- ^ The size of the time window-  -> ClSF m cl a (Seq (TimeInfo cl, a))+{- | Remembers all input values that arrived within a given time window.+   New values are appended left.+-}+historySince ::+  (Monad m, Ord (Diff (Time cl)), TimeDomain (Time cl)) =>+  -- | The size of the time window+  Diff (Time cl) ->+  ClSF m cl a (Seq (TimeInfo cl, a)) historySince dTime = readerS $ accumulateWith appendValue empty   where-    appendValue (ti, a) tias  = takeWhileL (recentlySince ti) $ (ti, a) <| tias+    appendValue (ti, a) tias = takeWhileL (recentlySince ti) $ (ti, a) <| tias     recentlySince ti (ti', _) = diffTime (absolute ti) (absolute ti') < dTime --- | Delay a signal by certain time span,---   initialising with the first input.-delayBy-  :: (Monad m, Ord (Diff td), TimeDomain td)-  => Diff td            -- ^ The time span to delay the signal-  -> BehaviorF m td a a+{- | Delay a signal by certain time span,+   initialising with the first input.+-}+delayBy ::+  (Monad m, Ord (Diff td), TimeDomain td) =>+  -- | The time span to delay the signal+  Diff td ->+  BehaviorF m td a a delayBy dTime = historySince dTime >>> arr (viewr >>> safeHead) >>> lastS undefined >>> arr snd   where-    safeHead EmptyR   = Nothing+    safeHead EmptyR = Nothing     safeHead (_ :> a) = Just a  -- * Timers --- | Throws an exception after the specified time difference,---   outputting the time passed since the 'timer' was instantiated.-timer-  :: ( Monad m-     , TimeDomain td-     , Ord (Diff td)-     )-  => Diff td-  -> BehaviorF (ExceptT () m) td a (Diff td)+{- | Throws an exception after the specified time difference,+   outputting the time passed since the 'timer' was instantiated.+-}+timer ::+  ( Monad m+  , TimeDomain td+  , Ord (Diff td)+  ) =>+  Diff td ->+  BehaviorF (ExceptT () m) td a (Diff td) timer diff = proc _ -> do   time <- sinceStart -< ()-  _    <- throwOn () -< time > diff-  returnA            -< time+  _ <- throwOn () -< time > diff+  returnA -< time  -- | Like 'timer_', but doesn't output the remaining time at all.-timer_-  :: ( Monad m-     , TimeDomain td-     , Ord (Diff td)-     )-  => Diff td-  -> BehaviorF (ExceptT () m) td a ()+timer_ ::+  ( Monad m+  , TimeDomain td+  , Ord (Diff td)+  ) =>+  Diff td ->+  BehaviorF (ExceptT () m) td a () timer_ diff = timer diff >>> arr (const ())  -- | Like 'timer', but divides the remaining time by the total time.-scaledTimer-  :: ( Monad m-     , TimeDomain td-     , Fractional (Diff td)-     , Ord        (Diff td)-     )-  => Diff td-  -> BehaviorF (ExceptT () m) td a (Diff td)+scaledTimer ::+  ( Monad m+  , TimeDomain td+  , Fractional (Diff td)+  , Ord (Diff td)+  ) =>+  Diff td ->+  BehaviorF (ExceptT () m) td a (Diff td) scaledTimer diff = timer diff >>> arr (/ diff) - -- * To be ported to Dunai --- | Remembers the last 'Just' value,---   defaulting to the given initialisation value.+{- | Remembers the last 'Just' value,+   defaulting to the given initialisation value.+-} lastS :: Monad m => a -> MSF m (Maybe a) a lastS a = arr Last >>> mappendFrom (Last (Just a)) >>> arr (getLast >>> fromJust)
src/FRP/Rhine/Clock.hs view
@@ -1,3 +1,11 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+ {- | 'Clock's are the central new notion in Rhine. There are clock types (instances of the 'Clock' type class)@@ -7,25 +15,18 @@ and certain general constructions of 'Clock's, such as clocks lifted along monad morphisms or time rescalings. -}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-}-module FRP.Rhine.Clock-  ( module FRP.Rhine.Clock-  , module X-  )+module FRP.Rhine.Clock (+  module FRP.Rhine.Clock,+  module X,+) where  -- base import qualified Control.Category as Category  -- transformers-import Control.Monad.IO.Class (liftIO, MonadIO)-import Control.Monad.Trans.Class (lift, MonadTrans)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Class (MonadTrans, lift)  -- dunai import Data.MonadicStreamFunction as X hiding ((>>>^), (^>>>))@@ -59,36 +60,41 @@ class TimeDomain (Time cl) => Clock m cl where   -- | 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.   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.-  initClock-    :: cl -- ^ The clock value, containing e.g. settings or device parameters-    -> RunningClockInit m (Time cl) (Tag cl) -- ^ The stream of time stamps, and the initial time+  initClock ::+    -- | The clock value, containing e.g. settings or device parameters+    cl ->+    -- | The stream of time stamps, and the initial time+    RunningClockInit m (Time cl) (Tag cl)  -- * Auxiliary definitions and utilities  -- | An annotated, rich time stamp. data TimeInfo cl = TimeInfo-  { -- | Time passed since the last tick-    sinceLast :: Diff (Time cl)-    -- | Time passed since the initialisation of the clock+  { sinceLast :: Diff (Time cl)+  -- ^ Time passed since the last tick   , sinceInit :: Diff (Time cl)-    -- | The absolute time of the current tick-  , absolute  :: Time cl-    -- | The tag annotation of the current tick-  , tag       :: Tag cl+  -- ^ Time passed since the initialisation of the clock+  , absolute :: Time cl+  -- ^ The absolute time of the current tick+  , tag :: Tag cl+  -- ^ The tag annotation of the current tick   }  -- | A utility that changes the tag of a 'TimeInfo'.-retag-  :: (Time cl1 ~ Time cl2)-  => (Tag cl1 -> Tag cl2)-  -> TimeInfo cl1 -> TimeInfo cl2-retag f TimeInfo {..} = TimeInfo { tag = f tag, .. }+retag ::+  (Time cl1 ~ Time cl2) =>+  (Tag cl1 -> Tag cl2) ->+  TimeInfo cl1 ->+  TimeInfo cl2+retag f TimeInfo {..} = TimeInfo {tag = f tag, ..}  -- * Certain universal building blocks to produce new clocks from given ones @@ -97,41 +103,48 @@ -- | A pure morphism of time domains is just a function. type Rescaling cl time = Time cl -> time --- | An effectful morphism of time domains is a Kleisli arrow.---   It can use a side effect to rescale a point in one time domain---   into another one.+{- | An effectful morphism of time domains is a Kleisli arrow.+   It can use a side effect to rescale a point in one time domain+   into another one.+-} type RescalingM m cl time = Time cl -> m time --- | An effectful, stateful morphism of time domains is an 'MSF'---   that uses side effects to rescale a point in one time domain---   into another one.+{- | An effectful, stateful morphism of time domains is an 'MSF'+   that uses side effects to rescale a point in one time domain+   into another one.+-} type RescalingS m cl time tag = MSF m (Time cl, Tag cl) (time, tag) --- | Like 'RescalingS', but allows for an initialisation---   of the rescaling morphism, together with the initial time.+{- | Like 'RescalingS', but allows for an initialisation+   of the rescaling morphism, together with the initial time.+-} type RescalingSInit m cl time tag = Time cl -> m (RescalingS m cl time tag, time) --- | Convert an effectful morphism of time domains into a stateful one with initialisation.---   Think of its type as @RescalingM m cl time -> RescalingSInit m cl time tag@,---   although this type is ambiguous.-rescaleMToSInit-  :: Monad m-  => (time1 -> m time2) -> time1 -> m (MSF m (time1, tag) (time2, tag), time2)-rescaleMToSInit rescaling time1 = (arrM rescaling *** Category.id, ) <$> rescaling time1+{- | Convert an effectful morphism of time domains into a stateful one with initialisation.+   Think of its type as @RescalingM m cl time -> RescalingSInit m cl time tag@,+   although this type is ambiguous.+-}+rescaleMToSInit ::+  Monad m =>+  (time1 -> m time2) ->+  time1 ->+  m (MSF m (time1, tag) (time2, tag), time2)+rescaleMToSInit rescaling time1 = (arrM rescaling *** Category.id,) <$> rescaling time1  -- ** Applying rescalings to clocks  -- | Applying a morphism of time domains yields a new clock. data RescaledClock cl time = RescaledClock   { unscaledClock :: cl-  , rescale       :: Rescaling cl time+  , rescale :: Rescaling cl time   } --instance (Monad m, TimeDomain time, Clock m cl)-      => Clock m (RescaledClock cl time) where+instance+  (Monad m, TimeDomain time, Clock m cl) =>+  Clock m (RescaledClock cl time)+  where   type Time (RescaledClock cl time) = time-  type Tag  (RescaledClock cl time) = Tag cl+  type Tag (RescaledClock cl time) = Tag cl   initClock (RescaledClock cl f) = do     (runningClock, initTime) <- initClock cl     return@@ -139,22 +152,25 @@       , f initTime       ) --- | Instead of a mere function as morphism of time domains,---   we can transform one time domain into the other with an effectful morphism.+{- | Instead of a mere function as morphism of time domains,+   we can transform one time domain into the other with an effectful morphism.+-} data RescaledClockM m cl time = RescaledClockM   { unscaledClockM :: cl   -- ^ The clock before the rescaling-  , rescaleM       :: RescalingM m cl time+  , rescaleM :: RescalingM m cl time   -- ^ Computing the new time effectfully from the old time   } -instance (Monad m, TimeDomain time, Clock m cl)-      => Clock m (RescaledClockM m cl time) where+instance+  (Monad m, TimeDomain time, Clock m cl) =>+  Clock m (RescaledClockM m cl time)+  where   type Time (RescaledClockM m cl time) = time-  type Tag  (RescaledClockM m cl time) = Tag cl+  type Tag (RescaledClockM m cl time) = Tag cl   initClock RescaledClockM {..} = do     (runningClock, initTime) <- initClock unscaledClockM-    rescaledInitTime         <- rescaleM initTime+    rescaledInitTime <- rescaleM initTime     return       ( runningClock >>> first (arrM rescaleM)       , rescaledInitTime@@ -162,26 +178,29 @@  -- | A 'RescaledClock' is trivially a 'RescaledClockM'. rescaledClockToM :: Monad m => RescaledClock cl time -> RescaledClockM m cl time-rescaledClockToM RescaledClock {..} = RescaledClockM-  { unscaledClockM = unscaledClock-  , rescaleM       = return . rescale-  }-+rescaledClockToM RescaledClock {..} =+  RescaledClockM+    { unscaledClockM = unscaledClock+    , rescaleM = return . rescale+    } --- | Instead of a mere function as morphism of time domains,---   we can transform one time domain into the other with a monadic stream function.+{- | Instead of a mere function as morphism of time domains,+   we can transform one time domain into the other with a monadic stream function.+-} data RescaledClockS m cl time tag = RescaledClockS   { unscaledClockS :: cl   -- ^ The clock before the rescaling-  , rescaleS       :: RescalingSInit m cl time tag+  , rescaleS :: RescalingSInit m cl time tag   -- ^ The rescaling stream function, and rescaled initial time,   --   depending on the initial time before rescaling   } -instance (Monad m, TimeDomain time, Clock m cl)-      => Clock m (RescaledClockS m cl time tag) where+instance+  (Monad m, TimeDomain time, Clock m cl) =>+  Clock m (RescaledClockS m cl time tag)+  where   type Time (RescaledClockS m cl time tag) = time-  type Tag  (RescaledClockS m cl time tag) = tag+  type Tag (RescaledClockS m cl time tag) = tag   initClock RescaledClockS {..} = do     (runningClock, initTime) <- initClock unscaledClockS     (rescaling, rescaledInitTime) <- rescaleS initTime@@ -191,30 +210,35 @@       )  -- | A 'RescaledClockM' is trivially a 'RescaledClockS'.-rescaledClockMToS-  :: Monad m-  => RescaledClockM m cl time -> RescaledClockS m cl time (Tag cl)-rescaledClockMToS RescaledClockM {..} = RescaledClockS-  { unscaledClockS = unscaledClockM-  , rescaleS       = rescaleMToSInit rescaleM-  }+rescaledClockMToS ::+  Monad m =>+  RescaledClockM m cl time ->+  RescaledClockS m cl time (Tag cl)+rescaledClockMToS RescaledClockM {..} =+  RescaledClockS+    { unscaledClockS = unscaledClockM+    , rescaleS = rescaleMToSInit rescaleM+    }  -- | A 'RescaledClock' is trivially a 'RescaledClockS'.-rescaledClockToS-  :: Monad m-  => RescaledClock cl time -> RescaledClockS m cl time (Tag cl)+rescaledClockToS ::+  Monad m =>+  RescaledClock cl time ->+  RescaledClockS m cl time (Tag cl) rescaledClockToS = rescaledClockMToS . rescaledClockToM  -- | Applying a monad morphism yields a new clock. data HoistClock m1 m2 cl = HoistClock   { unhoistedClock :: cl-  , monadMorphism  :: forall a . m1 a -> m2 a+  , monadMorphism :: forall a. m1 a -> m2 a   } -instance (Monad m1, Monad m2, Clock m1 cl)-      => Clock m2 (HoistClock m1 m2 cl) where+instance+  (Monad m1, Monad m2, Clock m1 cl) =>+  Clock m2 (HoistClock m1 m2 cl)+  where   type Time (HoistClock m1 m2 cl) = Time cl-  type Tag  (HoistClock m1 m2 cl) = Tag  cl+  type Tag (HoistClock m1 m2 cl) = Tag cl   initClock HoistClock {..} = do     (runningClock, initialTime) <- monadMorphism $ initClock unhoistedClock     let hoistMSF = morphS@@ -224,23 +248,24 @@       , initialTime       ) - -- | Lift a clock type into a monad transformer. type LiftClock m t cl = HoistClock m (t m) cl  -- | Lift a clock value into a monad transformer. liftClock :: (Monad m, MonadTrans t) => cl -> LiftClock m t cl-liftClock unhoistedClock = HoistClock-  { monadMorphism = lift-  , ..-  }+liftClock unhoistedClock =+  HoistClock+    { monadMorphism = lift+    , ..+    }  -- | Lift a clock type into 'MonadIO'. type IOClock m cl = HoistClock IO m cl  -- | Lift a clock value into 'MonadIO'. ioClock :: MonadIO m => cl -> IOClock m cl-ioClock unhoistedClock = HoistClock-  { monadMorphism = liftIO-  , ..-  }+ioClock unhoistedClock =+  HoistClock+    { monadMorphism = liftIO+    , ..+    }
src/FRP/Rhine/Clock/FixedStep.hs view
@@ -1,18 +1,16 @@-{- |-Implements pure clocks ticking at-every multiple of a fixed number of steps,-and a deterministic schedule for such clocks.--}- {-# LANGUAGE Arrows #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-module FRP.Rhine.Clock.FixedStep where +{- |+Implements pure clocks ticking at+every multiple of a fixed number of steps,+and a deterministic schedule for such clocks.+-}+module FRP.Rhine.Clock.FixedStep where  -- base import Data.Maybe (fromMaybe)@@ -32,10 +30,11 @@ import FRP.Rhine.ResamplingBuffer.Util import FRP.Rhine.Schedule --- | A pure (side effect free) clock with fixed step size,---   i.e. ticking at multiples of 'n'.---   The tick rate is in the type signature,---   which prevents composition of signals at different rates.+{- | A pure (side effect free) clock with fixed step size,+   i.e. ticking at multiples of 'n'.+   The tick rate is in the type signature,+   which prevents composition of signals at different rates.+-} data FixedStep (n :: Nat) where   FixedStep :: KnownNat n => FixedStep n -- TODO Does the constraint bring any benefit? @@ -45,12 +44,14 @@  instance Monad m => Clock m (FixedStep n) where   type Time (FixedStep n) = Integer-  type Tag  (FixedStep n) = ()-  initClock cl = return-    ( count >>> arr (* stepsize cl)-      &&& arr (const ())-    , 0-    )+  type Tag (FixedStep n) = ()+  initClock cl =+    return+      ( count+          >>> arr (* stepsize cl)+            &&& arr (const ())+      , 0+      )  instance GetClockProxy (FixedStep n) @@ -58,30 +59,36 @@ type Count = FixedStep 1  -- | Two 'FixedStep' clocks can always be scheduled without side effects.-scheduleFixedStep-  :: Monad m-  => Schedule m (FixedStep n1) (FixedStep n2)-scheduleFixedStep = Schedule f where-  f cl1 cl2 = return (msf, 0)-    where-      n1 = stepsize cl1-      n2 = stepsize cl2-      msf = concatS $ proc _ -> do-        k <- arr (+1) <<< count -< ()-        returnA                 -< [ (k, Left  ()) | k `mod` n1 == 0 ]-                                ++ [ (k, Right ()) | k `mod` n2 == 0 ]+scheduleFixedStep ::+  Monad m =>+  Schedule m (FixedStep n1) (FixedStep n2)+scheduleFixedStep = Schedule f+  where+    f cl1 cl2 = return (msf, 0)+      where+        n1 = stepsize cl1+        n2 = stepsize cl2+        msf = concatS $ proc _ -> do+          k <- arr (+ 1) <<< count -< ()+          returnA+            -<+              [(k, Left ()) | k `mod` n1 == 0]+                ++ [(k, Right ()) | k `mod` n2 == 0]  -- TODO The problem is that the schedule doesn't give a guarantee where in the n ticks of the first clock the second clock will tick. -- For this to work, it has to be the last. -- With scheduleFixedStep, this works, -- but the user might implement an incorrect schedule.-downsampleFixedStep-  :: (KnownNat n, Monad m)-  => ResamplingBuffer m (FixedStep k) (FixedStep (n * k)) a (Vector n a)+downsampleFixedStep ::+  (KnownNat n, Monad m) =>+  ResamplingBuffer m (FixedStep k) (FixedStep (n * k)) a (Vector n a) downsampleFixedStep = collect >>-^ arr (fromList >>> assumeSize)   where-    assumeSize = fromMaybe $ error $ unwords-      [ "You are using an incorrectly implemented schedule"-      , "for two FixedStep clocks."-      , "Use a correct schedule like downsampleFixedStep."-      ]+    assumeSize =+      fromMaybe $+        error $+          unwords+            [ "You are using an incorrectly implemented schedule"+            , "for two FixedStep clocks."+            , "Use a correct schedule like downsampleFixedStep."+            ]
src/FRP/Rhine/Clock/Periodic.hs view
@@ -1,9 +1,3 @@-{- |-Periodic clocks are defined by a stream of ticks with periodic time differences.-They model subclocks of a fixed reference clock.-The time differences are supplied at the type level.--}- {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -12,40 +6,50 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}++{- |+Periodic clocks are defined by a stream of ticks with periodic time differences.+They model subclocks of a fixed reference clock.+The time differences are supplied at the type level.+-} module FRP.Rhine.Clock.Periodic (Periodic (Periodic)) where  -- base import Data.List.NonEmpty hiding (unfold) import Data.Maybe (fromMaybe)-import GHC.TypeLits (Nat, KnownNat, natVal)+import GHC.TypeLits (KnownNat, Nat, natVal)  -- dunai import Data.MonadicStreamFunction  -- rhine+import Control.Monad.Schedule import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy-import Control.Monad.Schedule  -- * The 'Periodic' clock --- | A clock whose tick lengths cycle through---   a (nonempty) list of type-level natural numbers.---   E.g. @Periodic '[1, 2]@ ticks at times 1, 3, 4, 5, 7, 8, etc.------   The waiting side effect is formal, in 'ScheduleT'.---   You can use e.g. 'runScheduleIO' to produce an actual delay.+{- | A clock whose tick lengths cycle through+   a (nonempty) list of type-level natural numbers.+   E.g. @Periodic '[1, 2]@ ticks at times 1, 3, 4, 5, 7, 8, etc.++   The waiting side effect is formal, in 'ScheduleT'.+   You can use e.g. 'runScheduleIO' to produce an actual delay.+-} data Periodic (v :: [Nat]) where   Periodic :: Periodic (n : ns) -instance (Monad m, NonemptyNatList v)-      => Clock (ScheduleT Integer m) (Periodic v) where+instance+  (Monad m, NonemptyNatList v) =>+  Clock (ScheduleT Integer m) (Periodic v)+  where   type Time (Periodic v) = Integer-  type Tag  (Periodic v) = ()-  initClock cl = return-    ( cycleS (theList cl) >>> withSideEffect wait >>> accumulateWith (+) 0 &&& arr (const ())-    , 0-    )+  type Tag (Periodic v) = ()+  initClock cl =+    return+      ( cycleS (theList cl) >>> withSideEffect wait >>> accumulateWith (+) 0 &&& arr (const ())+      , 0+      )  instance GetClockProxy (Periodic v) @@ -66,14 +70,16 @@ instance KnownNat n => NonemptyNatList '[n] where   theList cl = headCl cl :| [] -instance (KnownNat n1, KnownNat n2, NonemptyNatList (n2 : ns))-      => NonemptyNatList (n1 : n2 : ns) where+instance+  (KnownNat n1, KnownNat n2, NonemptyNatList (n2 : ns)) =>+  NonemptyNatList (n1 : n2 : ns)+  where   theList cl = headCl cl <| theList (tailCl cl) - -- * Utilities  -- TODO Port back to dunai when naming issues are resolved+ -- | Repeatedly outputs the values of a given list, in order. cycleS :: Monad m => NonEmpty a -> MSF m () a cycleS as = unfold (second (fromMaybe as) . uncons) as
src/FRP/Rhine/Clock/Proxy.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-}+ module FRP.Rhine.Clock.Proxy where  -- base@@ -11,20 +12,21 @@ import FRP.Rhine.Clock import FRP.Rhine.Schedule --- | Witnesses the structure of a clock type,---   in particular whether 'SequentialClock's or 'ParallelClock's are involved.+{- | Witnesses the structure of a clock type,+   in particular whether 'SequentialClock's or 'ParallelClock's are involved.+-} data ClockProxy cl where-  LeafProxy-    :: (cl ~ In cl, cl ~ Out cl)-    => ClockProxy cl-  SequentialProxy-    :: ClockProxy cl1-    -> ClockProxy cl2-    -> ClockProxy (SequentialClock m cl1 cl2)-  ParallelProxy-    :: ClockProxy clL-    -> ClockProxy clR-    -> ClockProxy (ParallelClock m clL clR)+  LeafProxy ::+    (cl ~ In cl, cl ~ Out cl) =>+    ClockProxy cl+  SequentialProxy ::+    ClockProxy cl1 ->+    ClockProxy cl2 ->+    ClockProxy (SequentialClock m cl1 cl2)+  ParallelProxy ::+    ClockProxy clL ->+    ClockProxy clR ->+    ClockProxy (ParallelClock m clL clR)  inProxy :: ClockProxy cl -> ClockProxy (In cl) inProxy LeafProxy = LeafProxy@@ -36,33 +38,35 @@ outProxy (SequentialProxy _ p2) = outProxy p2 outProxy (ParallelProxy pL pR) = ParallelProxy (outProxy pL) (outProxy pR) --- | Return the incoming tag, assuming that the incoming clock is ticked,---   and 'Nothing' otherwise.+{- | Return the incoming tag, assuming that the incoming clock is ticked,+   and 'Nothing' otherwise.+-} inTag :: ClockProxy cl -> Tag cl -> Maybe (Tag (In cl))-inTag (SequentialProxy p1 _) (Left  tag1) = inTag p1 tag1-inTag (SequentialProxy _  _) (Right _)    = Nothing-inTag (ParallelProxy pL _) (Left  tagL) = Left  <$> inTag pL tagL+inTag (SequentialProxy p1 _) (Left tag1) = inTag p1 tag1+inTag (SequentialProxy _ _) (Right _) = Nothing+inTag (ParallelProxy pL _) (Left tagL) = Left <$> inTag pL tagL inTag (ParallelProxy _ pR) (Right tagR) = Right <$> inTag pR tagR inTag LeafProxy tag = Just tag --- | Return the incoming tag, assuming that the outgoing clock is ticked,---   and 'Nothing' otherwise.+{- | Return the incoming tag, assuming that the outgoing clock is ticked,+   and 'Nothing' otherwise.+-} outTag :: ClockProxy cl -> Tag cl -> Maybe (Tag (Out cl))-outTag (SequentialProxy _ _ ) (Left  _)    = Nothing+outTag (SequentialProxy _ _) (Left _) = Nothing outTag (SequentialProxy _ p2) (Right tag2) = outTag p2 tag2-outTag (ParallelProxy pL _) (Left  tagL) = Left  <$> outTag pL tagL+outTag (ParallelProxy pL _) (Left tagL) = Left <$> outTag pL tagL outTag (ParallelProxy _ pR) (Right tagR) = Right <$> outTag pR tagR outTag LeafProxy tag = Just tag  -- TODO Should this be a superclass with default implementation of clocks? But then we have a circular dependency... -- No we don't, Schedule should not depend on clock (the type).+ -- | Clocks should be able to automatically generate a proxy for themselves. class GetClockProxy cl where   getClockProxy :: ClockProxy cl--  default getClockProxy-    :: (cl ~ In cl, cl ~ Out cl)-    => ClockProxy cl+  default getClockProxy ::+    (cl ~ In cl, cl ~ Out cl) =>+    ClockProxy cl   getClockProxy = LeafProxy  instance (GetClockProxy cl1, GetClockProxy cl2) => GetClockProxy (SequentialClock m cl1 cl2) where@@ -81,8 +85,8 @@   type Cl a :: Type    toClockProxy :: a -> ClockProxy (Cl a)--  default toClockProxy-    :: GetClockProxy (Cl a)-    => a -> ClockProxy (Cl a)+  default toClockProxy ::+    GetClockProxy (Cl a) =>+    a ->+    ClockProxy (Cl a)   toClockProxy _ = getClockProxy
src/FRP/Rhine/Clock/Realtime/Audio.hs view
@@ -1,8 +1,3 @@-{- |-Provides several clocks to use for audio processing,-for realtime as well as for batch/file processing.--}- {-# LANGUAGE Arrows #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-}@@ -12,24 +7,27 @@ -- {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -- TODO Find out exact version of cabal? GHC? that have a problem with this -module FRP.Rhine.Clock.Realtime.Audio-  ( AudioClock (..)-  , AudioRate (..)-  , PureAudioClock (..)-  , PureAudioClockF-  , pureAudioClockF-  )-  where+{- |+Provides several clocks to use for audio processing,+for realtime as well as for batch/file processing.+-}+module FRP.Rhine.Clock.Realtime.Audio (+  AudioClock (..),+  AudioRate (..),+  PureAudioClock (..),+  PureAudioClockF,+  pureAudioClockF,+)+where  -- base-import GHC.Float       (double2Float)-import GHC.TypeLits    (Nat, natVal, KnownNat) import Data.Time.Clock+import GHC.Float (double2Float)+import GHC.TypeLits (KnownNat, Nat, natVal)  -- transformers import Control.Monad.IO.Class - -- dunai import Control.Monad.Trans.MSF.Except hiding (step) @@ -49,8 +47,8 @@ rateToIntegral Hz48000 = 48000 rateToIntegral Hz96000 = 96000 - -- TODO Test extensively+ {- | A clock for audio analysis and synthesis. It internally processes samples in buffers of size 'bufferSize',@@ -86,35 +84,37 @@ instance AudioClockRate Hz96000 where   theRate _ = Hz96000 --theBufferSize-  :: (KnownNat bufferSize, Integral a)-  => AudioClock rate bufferSize -> a+theBufferSize ::+  (KnownNat bufferSize, Integral a) =>+  AudioClock rate bufferSize ->+  a theBufferSize = fromInteger . natVal --instance (MonadIO m, KnownNat bufferSize, AudioClockRate rate)-      => Clock m (AudioClock rate bufferSize) where+instance+  (MonadIO m, KnownNat bufferSize, AudioClockRate rate) =>+  Clock m (AudioClock rate bufferSize)+  where   type Time (AudioClock rate bufferSize) = UTCTime-  type Tag  (AudioClock rate bufferSize) = Maybe Double+  type Tag (AudioClock rate bufferSize) = Maybe Double    initClock audioClock = do     let-      step       = picosecondsToDiffTime -- The only sufficiently precise conversion function-                     $ round (10 ^ (12 :: Integer) / theRateNum audioClock :: Double)+      step =+        picosecondsToDiffTime $ -- The only sufficiently precise conversion function+          round (10 ^ (12 :: Integer) / theRateNum audioClock :: Double)       bufferSize = theBufferSize audioClock        runningClock :: MonadIO m => UTCTime -> Maybe Double -> MSF m () (UTCTime, Maybe Double)       runningClock initialTime maybeWasLate = safely $ do         bufferFullTime <- try $ proc () -> do-          n <- count    -< ()+          n <- count -< ()           let nextTime = (realToFrac step * fromIntegral (n :: Int)) `addUTCTime` initialTime           _ <- throwOn' -< (n >= bufferSize, nextTime)-          returnA       -< (nextTime, if n == 0 then maybeWasLate else Nothing)+          returnA -< (nextTime, if n == 0 then maybeWasLate else Nothing)         currentTime <- once_ $ liftIO getCurrentTime         let           lateDiff = currentTime `diffTime` bufferFullTime-          late     = if lateDiff > 0 then Just lateDiff else Nothing+          late = if lateDiff > 0 then Just lateDiff else Nothing         safe $ runningClock bufferFullTime late     initialTime <- liftIO getCurrentTime     return@@ -141,26 +141,27 @@   thePureRateNum :: Num a => PureAudioClock rate -> a   thePureRateNum = fromInteger . thePureRateIntegral - instance (Monad m, PureAudioClockRate rate) => Clock m (PureAudioClock rate) where   type Time (PureAudioClock rate) = Double-  type Tag  (PureAudioClock rate) = ()+  type Tag (PureAudioClock rate) = () -  initClock audioClock = return-    ( arr (const (1 / thePureRateNum audioClock)) >>> sumS &&& arr (const ())-    , 0-    )+  initClock audioClock =+    return+      ( arr (const (1 / thePureRateNum audioClock)) >>> sumS &&& arr (const ())+      , 0+      )  instance GetClockProxy (PureAudioClock rate)  -- | A rescaled version of 'PureAudioClock' with 'TimeDomain' 'Float'. type PureAudioClockF (rate :: AudioRate) = RescaledClock (PureAudioClock rate) Float ---- | A rescaled version of 'PureAudioClock' with 'TimeDomain' 'Float',---   using 'double2Float' to rescale.+{- | A rescaled version of 'PureAudioClock' with 'TimeDomain' 'Float',+   using 'double2Float' to rescale.+-} pureAudioClockF :: PureAudioClockF rate-pureAudioClockF = RescaledClock-  { unscaledClock = PureAudioClock-  , rescale       = double2Float-  }+pureAudioClockF =+  RescaledClock+    { unscaledClock = PureAudioClock+    , rescale = double2Float+    }
src/FRP/Rhine/Clock/Realtime/Busy.hs view
@@ -1,7 +1,7 @@-{- | A "'Busy'" clock that ticks without waiting. -}- {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-}++-- | A "'Busy'" clock that ticks without waiting. module FRP.Rhine.Clock.Realtime.Busy where  -- base@@ -20,13 +20,13 @@  instance Clock IO Busy where   type Time Busy = UTCTime-  type Tag  Busy = ()+  type Tag Busy = ()    initClock _ = do     initialTime <- getCurrentTime     return       ( constM getCurrentTime-        &&& arr (const ())+          &&& arr (const ())       , initialTime       )
src/FRP/Rhine/Clock/Realtime/Event.hs view
@@ -1,3 +1,10 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+ {- | This module provides two things: @@ -15,22 +22,17 @@  A simple example using events and threads can be found in rhine-examples. -}--{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-module FRP.Rhine.Clock.Realtime.Event-  ( module FRP.Rhine.Clock.Realtime.Event-  , module Control.Monad.IO.Class-  , newChan-  )-  where+module FRP.Rhine.Clock.Realtime.Event (+  module FRP.Rhine.Clock.Realtime.Event,+  module Control.Monad.IO.Class,+  newChan,+)+where  -- base import Control.Concurrent.Chan++-- time import Data.Time.Clock  -- deepseq@@ -41,21 +43,21 @@ import Control.Monad.Trans.Reader  -- rhine-import FRP.Rhine.Clock.Proxy import FRP.Rhine.ClSF+import FRP.Rhine.Clock+import FRP.Rhine.Clock.Proxy import FRP.Rhine.Schedule import FRP.Rhine.Schedule.Concurrently -- -- * Monads allowing for event emission and handling  -- | A monad transformer in which events can be emitted onto a 'Chan'. type EventChanT event m = ReaderT (Chan event) m --- | Escape the 'EventChanT' layer by explicitly providing a channel---   over which events are sent.---   Often this is not needed, and 'runEventChanT' can be used instead.+{- | Escape the 'EventChanT' layer by explicitly providing a channel+   over which events are sent.+   Often this is not needed, and 'runEventChanT' can be used instead.+-} withChan :: Chan event -> EventChanT event m a -> m a withChan = flip runReaderT @@ -87,11 +89,11 @@ pass the channel to every behaviour or 'ClSF' that wants to emit events, and, by using 'eventClockOn', to every clock that should tick on the event. -}-withChanS-  :: Monad m-  => Chan event-  -> ClSF (EventChanT event m) cl a b-  -> ClSF m cl a b+withChanS ::+  Monad m =>+  Chan event ->+  ClSF (EventChanT event m) cl a b ->+  ClSF m cl a b withChanS = flip runReaderS_  -- * Event emission@@ -118,29 +120,30 @@  -- | Like 'emit', but completely evaluates the event before emitting it. emit' :: (NFData event, MonadIO m) => event -> EventChanT event m ()-emit' event = event `deepseq` do-  chan <- ask-  liftIO $ writeChan chan event+emit' event =+  event `deepseq` do+    chan <- ask+    liftIO $ writeChan chan event  -- | Like 'emitS', but completely evaluates the event before emitting it. emitS' :: (NFData event, MonadIO m) => ClSF (EventChanT event m) cl event () emitS' = arrMCl emit'  -- | Like 'emitSMaybe', but completely evaluates the event before emitting it.-emitSMaybe'-  :: (NFData event, MonadIO m)-  => ClSF (EventChanT event m) cl (Maybe event) ()+emitSMaybe' ::+  (NFData event, MonadIO m) =>+  ClSF (EventChanT event m) cl (Maybe event) () emitSMaybe' = mapMaybe emitS' >>> arr (const ()) - -- * Event clocks and schedules --- | A clock that ticks whenever an @event@ is emitted.---   It is not yet bound to a specific channel,---   since ideally, the correct channel is created automatically---   by 'runEventChanT'.---   If you want to create the channel manually and bind the clock to it,---   use 'eventClockOn'.+{- | A clock that ticks whenever an @event@ is emitted.+   It is not yet bound to a specific channel,+   since ideally, the correct channel is created automatically+   by 'runEventChanT'.+   If you want to create the channel manually and bind the clock to it,+   use 'eventClockOn'.+-} data EventClock event = EventClock  instance Semigroup (EventClock event) where@@ -148,31 +151,33 @@  instance MonadIO m => Clock (EventChanT event m) (EventClock event) where   type Time (EventClock event) = UTCTime-  type Tag  (EventClock event) = event+  type Tag (EventClock event) = event   initClock _ = do     initialTime <- liftIO getCurrentTime     return       ( constM $ do-          chan  <- ask+          chan <- ask           event <- liftIO $ readChan chan-          time  <- liftIO getCurrentTime+          time <- liftIO getCurrentTime           return (time, event)       , initialTime       )  instance GetClockProxy (EventClock event) --- | Create an event clock that is bound to a specific event channel.---   This is usually only useful if you can't apply 'runEventChanT'---   to the main loop (see 'withChanS').-eventClockOn-  :: MonadIO m-  => Chan event-  -> HoistClock (EventChanT event m) m (EventClock event)-eventClockOn chan = HoistClock-  { unhoistedClock = EventClock-  , monadMorphism  = withChan chan-  }+{- | Create an event clock that is bound to a specific event channel.+   This is usually only useful if you can't apply 'runEventChanT'+   to the main loop (see 'withChanS').+-}+eventClockOn ::+  MonadIO m =>+  Chan event ->+  HoistClock (EventChanT event m) m (EventClock event)+eventClockOn chan =+  HoistClock+    { unhoistedClock = EventClock+    , monadMorphism = withChan chan+    }  {- | Given two clocks with an 'EventChanT' layer directly atop the 'IO' monad,@@ -187,10 +192,10 @@ * An event clock and other event-unaware clocks in the 'IO' monad,   which are lifted using 'liftClock'. -}-concurrentlyWithEvents-  :: ( Time cl1 ~ Time cl2-     , Clock (EventChanT event IO) cl1-     , Clock (EventChanT event IO) cl2-     )-  => Schedule (EventChanT event IO) cl1 cl2+concurrentlyWithEvents ::+  ( Time cl1 ~ Time cl2+  , Clock (EventChanT event IO) cl1+  , Clock (EventChanT event IO) cl2+  ) =>+  Schedule (EventChanT event IO) cl1 cl2 concurrentlyWithEvents = readerSchedule concurrently
src/FRP/Rhine/Clock/Realtime/Millisecond.hs view
@@ -1,30 +1,29 @@-{- |-Provides a clock that ticks at every multiple of a fixed number of milliseconds.--}- {-# LANGUAGE DataKinds #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}++{- |+Provides a clock that ticks at every multiple of a fixed number of milliseconds.+-} module FRP.Rhine.Clock.Realtime.Millisecond where  -- base+import Control.Concurrent (threadDelay) import Data.Maybe (fromMaybe) import Data.Time.Clock-import Control.Concurrent (threadDelay) import GHC.TypeLits --- fixed-vector+-- vector-sized import Data.Vector.Sized (Vector, fromList)  -- rhine import FRP.Rhine.Clock-import FRP.Rhine.Clock.Proxy import FRP.Rhine.Clock.FixedStep-import FRP.Rhine.Schedule+import FRP.Rhine.Clock.Proxy import FRP.Rhine.ResamplingBuffer-import FRP.Rhine.ResamplingBuffer.Util import FRP.Rhine.ResamplingBuffer.Collect+import FRP.Rhine.ResamplingBuffer.Util+import FRP.Rhine.Schedule  {- | A clock ticking every 'n' milliseconds,@@ -38,30 +37,31 @@ and 'False' a lag. -} newtype Millisecond (n :: Nat) = Millisecond (RescaledClockS IO (FixedStep n) UTCTime Bool)+ -- TODO Consider changing the tag to Maybe Double  instance Clock IO (Millisecond n) where   type Time (Millisecond n) = UTCTime-  type Tag  (Millisecond n) = Bool+  type Tag (Millisecond n) = Bool   initClock (Millisecond cl) = initClock cl  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.+{- | 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.+-} waitClock :: KnownNat n => Millisecond n waitClock = Millisecond $ RescaledClockS FixedStep $ \_ -> do   initTime <- getCurrentTime@@ -70,29 +70,31 @@       beforeSleep <- getCurrentTime       let         diff :: Double-        diff      = realToFrac $ beforeSleep `diffUTCTime` initTime+        diff = realToFrac $ beforeSleep `diffUTCTime` initTime         remaining = fromInteger $ n * 1000 - round (diff * 1000000)       threadDelay remaining-      now         <- getCurrentTime -- TODO Test whether this is a performance penalty+      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 ::+  (KnownNat n, Monad m) =>+  ResamplingBuffer m (Millisecond k) (Millisecond (n * k)) a (Vector n a) downsampleMillisecond = collect >>-^ arr (fromList >>> assumeSize)   where-    assumeSize = fromMaybe $ error $ unwords-      [ "You are using an incorrectly implemented schedule"-      , "for two Millisecond clocks."-      , "Use a correct schedule like downsampleMillisecond."-      ]+    assumeSize =+      fromMaybe $+        error $+          unwords+            [ "You are using an incorrectly implemented schedule"+            , "for two Millisecond clocks."+            , "Use a correct schedule like downsampleMillisecond."+            ]  -- | Two 'Millisecond' clocks can always be scheduled deterministically. scheduleMillisecond :: Schedule IO (Millisecond n1) (Millisecond n2) scheduleMillisecond = Schedule initSchedule'   where-    initSchedule' (Millisecond cl1) (Millisecond cl2)-      = initSchedule (rescaledScheduleS scheduleFixedStep) cl1 cl2+    initSchedule' (Millisecond cl1) (Millisecond cl2) =+      initSchedule (rescaledScheduleS scheduleFixedStep) cl1 cl2
src/FRP/Rhine/Clock/Realtime/Stdin.hs view
@@ -1,12 +1,12 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+ {- | In Rhine, event sources are clocks, and so is the console. If this clock is used, every input line on the console triggers one tick of the 'StdinClock'. -}--{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-} module FRP.Rhine.Clock.Realtime.Stdin where  -- time@@ -27,7 +27,7 @@  instance MonadIO m => Clock m StdinClock where   type Time StdinClock = UTCTime-  type Tag  StdinClock = String+  type Tag StdinClock = String    initClock _ = do     initialTime <- liftIO getCurrentTime
src/FRP/Rhine/Clock/Select.hs view
@@ -1,3 +1,10 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+ {- | In the Rhine philosophy, _event sources are clocks_. Often, we want to extract certain subevents from event sources,@@ -5,13 +12,6 @@ This module provides a general purpose selection clock that ticks only on certain subevents. -}--{-# LANGUAGE Arrows #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-} module FRP.Rhine.Clock.Select where  -- rhine@@ -25,82 +25,94 @@ -- base import Data.Maybe (catMaybes, maybeToList) --- | A clock that selects certain subevents of type 'a',---   from the tag of a main clock.------   If two 'SelectClock's would tick on the same type of subevents,---   but should not have the same type,---   one should @newtype@ the subevent.+{- | A clock that selects certain subevents of type 'a',+   from the tag of a main clock.++   If two 'SelectClock's would tick on the same type of subevents,+   but should not have the same type,+   one should @newtype@ the subevent.+-} data SelectClock cl a = SelectClock-  { mainClock :: cl -- ^ The main clock+  { 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'.-  , select    :: Tag cl -> Maybe a+  , select :: Tag cl -> Maybe a   }  instance (Semigroup a, Semigroup cl) => Semigroup (SelectClock cl a) where-  cl1 <> cl2 = SelectClock-    { mainClock = mainClock cl1 <> mainClock cl2-    , select = \tag -> select cl1 tag <> select cl2 tag-    }+  cl1 <> cl2 =+    SelectClock+      { mainClock = mainClock cl1 <> mainClock cl2+      , select = \tag -> select cl1 tag <> select cl2 tag+      }  instance (Monoid cl, Semigroup a) => Monoid (SelectClock cl a) where-  mempty = SelectClock-    { mainClock = mempty-    , select = const mempty-    }-+  mempty =+    SelectClock+      { mainClock = mempty+      , select = const mempty+      }  instance (Monad m, Clock m cl) => Clock m (SelectClock cl a) where   type Time (SelectClock cl a) = Time cl-  type Tag  (SelectClock cl a) = a+  type Tag (SelectClock cl a) = a   initClock SelectClock {..} = do     (runningClock, initialTime) <- initClock mainClock     let       runningSelectClock = filterS $ proc _ -> do         (time, tag) <- runningClock -< ()-        returnA                     -< (time, ) <$> select tag+        returnA -< (time,) <$> select tag     return (runningSelectClock, initialTime)  instance GetClockProxy (SelectClock cl a) --- | A universal schedule for two subclocks of the same main clock.---   The main clock must be a 'Semigroup' (e.g. a singleton).-schedSelectClocks-  :: (Monad m, Semigroup cl, Clock m cl)-  => Schedule m (SelectClock cl a) (SelectClock cl b)+{- | A universal schedule for two subclocks of the same main clock.+   The main clock must be a 'Semigroup' (e.g. a singleton).+-}+schedSelectClocks ::+  (Monad m, Semigroup cl, Clock m cl) =>+  Schedule m (SelectClock cl a) (SelectClock cl b) schedSelectClocks = Schedule {..}   where     initSchedule subClock1 subClock2 = do-      (runningClock, initialTime) <- initClock-        $ mainClock subClock1 <> mainClock subClock2+      (runningClock, initialTime) <-+        initClock $+          mainClock subClock1 <> mainClock subClock2       let         runningSelectClocks = concatS $ proc _ -> do           (time, tag) <- runningClock -< ()-          returnA                     -< catMaybes-            [ (time, ) . Left  <$> select subClock1 tag-            , (time, ) . Right <$> select subClock2 tag ]+          returnA+            -<+              catMaybes+                [ (time,) . Left <$> select subClock1 tag+                , (time,) . Right <$> select subClock2 tag+                ]       return (runningSelectClocks, initialTime)  -- | A universal schedule for a subclock and its main clock.-schedSelectClockAndMain-  :: (Monad m, Semigroup cl, Clock m cl)-  => Schedule m cl (SelectClock cl a)+schedSelectClockAndMain ::+  (Monad m, Semigroup cl, Clock m cl) =>+  Schedule m cl (SelectClock cl a) schedSelectClockAndMain = Schedule {..}   where     initSchedule mainClock' SelectClock {..} = do-      (runningClock, initialTime) <- initClock-        $ mainClock' <> mainClock+      (runningClock, initialTime) <-+        initClock $+          mainClock' <> mainClock       let         runningSelectClock = concatS $ proc _ -> do           (time, tag) <- runningClock -< ()-          returnA                     -< catMaybes-            [ Just (time, Left tag)-            , (time, ) . Right <$> select tag ]+          returnA+            -<+              catMaybes+                [ Just (time, Left tag)+                , (time,) . Right <$> select tag+                ]       return (runningSelectClock, initialTime) ---- | Helper function that runs an 'MSF' with 'Maybe' output---   until it returns a value.+{- | Helper function that runs an 'MSF' with 'Maybe' output+   until it returns a value.+-} filterS :: Monad m => MSF m () (Maybe b) -> MSF m () b filterS = concatS . (>>> arr maybeToList)
src/FRP/Rhine/Clock/Util.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE Arrows #-} {-# LANGUAGE RecordWildCards #-}+ module FRP.Rhine.Clock.Util where  -- time-domain@@ -11,16 +12,20 @@  -- * Auxiliary definitions and utilities --- | Given a clock value and an initial time,---   generate a stream of time stamps.-genTimeInfo-  :: (Monad m, Clock m cl)-  => ClockProxy cl -> Time cl-  -> MSF m (Time cl, Tag cl) (TimeInfo cl)+{- | Given a clock value and an initial time,+   generate a stream of time stamps.+-}+genTimeInfo ::+  (Monad m, Clock m cl) =>+  ClockProxy cl ->+  Time cl ->+  MSF m (Time cl, Tag cl) (TimeInfo cl) genTimeInfo _ initialTime = proc (absolute, tag) -> do   lastTime <- iPre initialTime -< absolute-  returnA                      -< TimeInfo-    { sinceLast = absolute `diffTime` lastTime-    , sinceInit = absolute `diffTime` initialTime-    , ..-    }+  returnA+    -<+      TimeInfo+        { sinceLast = absolute `diffTime` lastTime+        , sinceInit = absolute `diffTime` initialTime+        , ..+        }
src/FRP/Rhine/Reactimation.hs view
@@ -1,18 +1,18 @@+{-# LANGUAGE GADTs #-}+ {- | Run closed 'Rhine's (which are signal functions together with matching clocks) as main loops. -}--{-# LANGUAGE GADTs #-} module FRP.Rhine.Reactimation where  -- dunai import Data.MonadicStreamFunction.InternalCore  -- rhine+import FRP.Rhine.ClSF.Core import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy-import FRP.Rhine.ClSF.Core import FRP.Rhine.Reactimation.Combinators import FRP.Rhine.Schedule import FRP.Rhine.Type@@ -46,24 +46,32 @@ main = flow $ mainSF @@ clock @ -}+ -- TODO Can we chuck the constraints into Clock m cl?-flow-  :: ( Monad m, Clock m cl-     , GetClockProxy cl-     , Time cl ~ Time (In  cl)-     , Time cl ~ Time (Out cl)-     )-  => Rhine m cl () () -> m ()+flow ::+  ( Monad m+  , Clock m cl+  , GetClockProxy cl+  , Time cl ~ Time (In cl)+  , Time cl ~ Time (Out cl)+  ) =>+  Rhine m cl () () ->+  m () flow rhine = do   msf <- eraseClock rhine   reactimate $ msf >>> arr (const ()) --- | Run a synchronous 'ClSF' with its clock as a main loop,---   similar to Yampa's, or Dunai's, 'reactimate'.-reactimateCl-  :: ( Monad m, Clock m cl-     , GetClockProxy cl-     , cl ~ In  cl, cl ~ Out cl-     )-  => cl -> ClSF m cl () () -> m ()+{- | Run a synchronous 'ClSF' with its clock as a main loop,+   similar to Yampa's, or Dunai's, 'reactimate'.+-}+reactimateCl ::+  ( Monad m+  , Clock m cl+  , GetClockProxy cl+  , cl ~ In cl+  , cl ~ Out cl+  ) =>+  cl ->+  ClSF m cl () () ->+  m () reactimateCl cl clsf = flow $ clsf @@ cl
src/FRP/Rhine/Reactimation/ClockErasure.hs view
@@ -1,13 +1,14 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TupleSections #-}+ {- | Translate clocked signal processing components to stream functions without explicit clock types.  This module is not meant to be used externally, and is thus not exported from 'FRP.Rhine'. -}-{-# LANGUAGE Arrows #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TupleSections #-} module FRP.Rhine.Reactimation.ClockErasure where  -- base@@ -18,42 +19,45 @@ import Data.MonadicStreamFunction  -- rhine++import FRP.Rhine.ClSF hiding (runReaderS) import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy import FRP.Rhine.Clock.Util-import FRP.Rhine.ClSF hiding (runReaderS) import FRP.Rhine.ResamplingBuffer import FRP.Rhine.SN --- | Run a clocked signal function as a monadic stream function,---   accepting the timestamps and tags as explicit inputs.-eraseClockClSF-  :: (Monad m, Clock m cl)-  => ClockProxy cl -> Time cl-  -> ClSF m cl a b-  -> MSF m (Time cl, Tag cl, a) b+{- | Run a clocked signal function as a monadic stream function,+   accepting the timestamps and tags as explicit inputs.+-}+eraseClockClSF ::+  (Monad m, Clock m cl) =>+  ClockProxy cl ->+  Time cl ->+  ClSF m cl a b ->+  MSF m (Time cl, Tag cl, a) b eraseClockClSF proxy initialTime clsf = proc (time, tag, a) -> do   timeInfo <- genTimeInfo proxy initialTime -< (time, tag)-  runReaderS clsf                           -< (timeInfo, a)+  runReaderS clsf -< (timeInfo, a) --- | Run a signal network as a monadic stream function.------   Depending on the incoming clock,---   input data may need to be provided,---   and depending on the outgoing clock,---   output data may be generated.---   There are thus possible invalid inputs,---   which 'eraseClockSN' does not gracefully handle.-eraseClockSN-  :: (Monad m, Clock m cl, GetClockProxy cl)-  => Time cl-  -> SN m cl a b-  -> MSF m (Time cl, Tag cl, Maybe a) (Maybe b)+{- | Run a signal network as a monadic stream function. +   Depending on the incoming clock,+   input data may need to be provided,+   and depending on the outgoing clock,+   output data may be generated.+   There are thus possible invalid inputs,+   which 'eraseClockSN' does not gracefully handle.+-}+eraseClockSN ::+  (Monad m, Clock m cl, GetClockProxy cl) =>+  Time cl ->+  SN m cl a b ->+  MSF m (Time cl, Tag cl, Maybe a) (Maybe b) -- A synchronous signal network is run by erasing the clock from the clocked signal function. eraseClockSN initialTime sn@(Synchronous clsf) = proc (time, tag, Just a) -> do   b <- eraseClockClSF (toClockProxy sn) initialTime clsf -< (time, tag, a)-  returnA                                                -< Just b+  returnA -< Just b  -- A sequentially composed signal network may either be triggered in its first component, -- or its second component. In either case,@@ -64,91 +68,95 @@   let     proxy1 = toClockProxy sn1     proxy2 = toClockProxy sn2-  in proc (time, tag, maybeA) -> do-  resBufIn <- case tag of-    Left  tagL -> do-      maybeB <- eraseClockSN initialTime sn1 -< (time, tagL, maybeA)-      returnA -< Left <$> ((time, , ) <$> outTag proxy1 tagL <*> maybeB)-    Right tagR -> do-      returnA -< Right . (time, ) <$> inTag proxy2 tagR-  maybeC <- mapMaybeS $ eraseClockResBuf (outProxy proxy1) (inProxy proxy2) initialTime resBuf -< resBufIn-  case tag of-    Left  _    -> do-      returnA -< Nothing-    Right tagR -> do-      eraseClockSN initialTime sn2 -< (time, tagR, join maybeC)-+   in+    proc (time, tag, maybeA) -> do+      resBufIn <- case tag of+        Left tagL -> do+          maybeB <- eraseClockSN initialTime sn1 -< (time, tagL, maybeA)+          returnA -< Left <$> ((time,,) <$> outTag proxy1 tagL <*> maybeB)+        Right tagR -> do+          returnA -< Right . (time,) <$> inTag proxy2 tagR+      maybeC <- mapMaybeS $ eraseClockResBuf (outProxy proxy1) (inProxy proxy2) initialTime resBuf -< resBufIn+      case tag of+        Left _ -> do+          returnA -< Nothing+        Right tagR -> do+          eraseClockSN initialTime sn2 -< (time, tagR, join maybeC) eraseClockSN initialTime (Parallel snL snR) = proc (time, tag, maybeA) -> do   case tag of-    Left  tagL -> eraseClockSN initialTime snL -< (time, tagL, maybeA)+    Left tagL -> eraseClockSN initialTime snL -< (time, tagL, maybeA)     Right tagR -> eraseClockSN initialTime snR -< (time, tagR, maybeA)- eraseClockSN initialTime (Postcompose sn clsf) =   let     proxy = toClockProxy sn-  in proc input@(time, tag, _) -> do-  bMaybe <- eraseClockSN initialTime sn -< input-  mapMaybeS $ eraseClockClSF (outProxy proxy) initialTime clsf -< (time, , ) <$> outTag proxy tag <*> bMaybe-+   in+    proc input@(time, tag, _) -> do+      bMaybe <- eraseClockSN initialTime sn -< input+      mapMaybeS $ eraseClockClSF (outProxy proxy) initialTime clsf -< (time,,) <$> outTag proxy tag <*> bMaybe eraseClockSN initialTime (Precompose clsf sn) =   let     proxy = toClockProxy sn-  in proc (time, tag, aMaybe) -> do-  bMaybe <- mapMaybeS $ eraseClockClSF (inProxy proxy) initialTime clsf -< (time, , ) <$> inTag proxy tag <*> aMaybe-  eraseClockSN initialTime sn -< (time, tag, bMaybe)-+   in+    proc (time, tag, aMaybe) -> do+      bMaybe <- mapMaybeS $ eraseClockClSF (inProxy proxy) initialTime clsf -< (time,,) <$> inTag proxy tag <*> aMaybe+      eraseClockSN initialTime sn -< (time, tag, bMaybe) eraseClockSN initialTime (Feedback buf0 sn) =   let     proxy = toClockProxy sn-  in feedback buf0 $ proc ((time, tag, aMaybe), buf) -> do-  (cMaybe, buf') <- case inTag proxy tag of-    Nothing -> do-      returnA -< (Nothing, buf)-    Just tagIn -> do-      timeInfo <- genTimeInfo (inProxy proxy) initialTime -< (time, tagIn)-      (c, buf') <- arrM $ uncurry get -< (buf, timeInfo)-      returnA -< (Just c, buf')-  bdMaybe <- eraseClockSN initialTime sn -< (time, tag, (, ) <$> aMaybe <*> cMaybe)-  case (, ) <$> outTag proxy tag <*> bdMaybe of-    Nothing -> do-      returnA -< (Nothing, buf')-    Just (tagOut, (b, d)) -> do-      timeInfo <- genTimeInfo (outProxy proxy) initialTime -< (time, tagOut)-      buf'' <- arrM $ uncurry $ uncurry put -< ((buf', timeInfo), d)-      returnA -< (Just b, buf'')-+   in+    feedback buf0 $ proc ((time, tag, aMaybe), buf) -> do+      (cMaybe, buf') <- case inTag proxy tag of+        Nothing -> do+          returnA -< (Nothing, buf)+        Just tagIn -> do+          timeInfo <- genTimeInfo (inProxy proxy) initialTime -< (time, tagIn)+          (c, buf') <- arrM $ uncurry get -< (buf, timeInfo)+          returnA -< (Just c, buf')+      bdMaybe <- eraseClockSN initialTime sn -< (time, tag, (,) <$> aMaybe <*> cMaybe)+      case (,) <$> outTag proxy tag <*> bdMaybe of+        Nothing -> do+          returnA -< (Nothing, buf')+        Just (tagOut, (b, d)) -> do+          timeInfo <- genTimeInfo (outProxy proxy) initialTime -< (time, tagOut)+          buf'' <- arrM $ uncurry $ uncurry put -< ((buf', timeInfo), d)+          returnA -< (Just b, buf'') eraseClockSN initialTime (FirstResampling sn buf) =   let     proxy = toClockProxy sn-  in proc (time, tag, acMaybe) -> do-    bMaybe <- eraseClockSN initialTime sn -< (time, tag, fst <$> acMaybe)-    let-      resBufInput = case (inTag proxy tag, outTag proxy tag, snd <$> acMaybe) of-        (Just tagIn, _, Just c) -> Just $ Left (time, tagIn, c)-        (_, Just tagOut, _) -> Just $ Right (time, tagOut)-        _ -> Nothing-    dMaybe <- mapMaybeS $ eraseClockResBuf (inProxy proxy) (outProxy proxy) initialTime buf -< resBufInput-    returnA -< (,) <$> bMaybe <*> join dMaybe+   in+    proc (time, tag, acMaybe) -> do+      bMaybe <- eraseClockSN initialTime sn -< (time, tag, fst <$> acMaybe)+      let+        resBufInput = case (inTag proxy tag, outTag proxy tag, snd <$> acMaybe) of+          (Just tagIn, _, Just c) -> Just $ Left (time, tagIn, c)+          (_, Just tagOut, _) -> Just $ Right (time, tagOut)+          _ -> Nothing+      dMaybe <- mapMaybeS $ eraseClockResBuf (inProxy proxy) (outProxy proxy) initialTime buf -< resBufInput+      returnA -< (,) <$> bMaybe <*> join dMaybe --- | Translate a resampling buffer into a monadic stream function.------   The input decides whether the buffer is to accept input or has to produce output.---   (In the latter case, only time information is provided.)-eraseClockResBuf-  :: ( Monad m-     , Clock m cl1, Clock m cl2-     , Time cl1 ~ Time cl2-     )-  => ClockProxy cl1 -> ClockProxy cl2 -> Time cl1-  -> ResBuf m cl1 cl2 a b-  -> MSF m (Either (Time cl1, Tag cl1, a) (Time cl2, Tag cl2)) (Maybe b)+{- | Translate a resampling buffer into a monadic stream function.++   The input decides whether the buffer is to accept input or has to produce output.+   (In the latter case, only time information is provided.)+-}+eraseClockResBuf ::+  ( Monad m+  , Clock m cl1+  , Clock m cl2+  , Time cl1 ~ Time cl2+  ) =>+  ClockProxy cl1 ->+  ClockProxy cl2 ->+  Time cl1 ->+  ResBuf m cl1 cl2 a b ->+  MSF m (Either (Time cl1, Tag cl1, a) (Time cl2, Tag cl2)) (Maybe b) eraseClockResBuf proxy1 proxy2 initialTime resBuf0 = feedback resBuf0 $ proc (input, resBuf) -> do   case input of     Left (time1, tag1, a) -> do-      timeInfo1 <- genTimeInfo proxy1 initialTime   -< (time1, tag1)-      resBuf'   <- arrM (uncurry $ uncurry put)     -< ((resBuf, timeInfo1), a)-      returnA                                       -< (Nothing, resBuf')+      timeInfo1 <- genTimeInfo proxy1 initialTime -< (time1, tag1)+      resBuf' <- arrM (uncurry $ uncurry put) -< ((resBuf, timeInfo1), a)+      returnA -< (Nothing, resBuf')     Right (time2, tag2) -> do-      timeInfo2    <- genTimeInfo proxy2 initialTime -< (time2, tag2)-      (b, resBuf') <- arrM (uncurry get)             -< (resBuf, timeInfo2)-      returnA                                        -< (Just b, resBuf')+      timeInfo2 <- genTimeInfo proxy2 initialTime -< (time2, tag2)+      (b, resBuf') <- arrM (uncurry get) -< (resBuf, timeInfo2)+      returnA -< (Just b, resBuf')
src/FRP/Rhine/Reactimation/Combinators.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+ {- | Combinators to create 'Rhine's (main programs) from basic components such as 'ClSF's, clocks, 'ResamplingBuffer's and 'Schedule's.@@ -11,43 +15,44 @@ * @*@ composes parallely. * @>@ composes sequentially. -}--{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}- module FRP.Rhine.Reactimation.Combinators where - -- rhine+import FRP.Rhine.ClSF.Core import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy-import FRP.Rhine.ClSF.Core import FRP.Rhine.ResamplingBuffer-import FRP.Rhine.Schedule import FRP.Rhine.SN import FRP.Rhine.SN.Combinators+import FRP.Rhine.Schedule import FRP.Rhine.Type - -- * Combinators and syntactic sugar for high-level composition of signal networks. - infix 5 @@--- | Create a synchronous 'Rhine' by combining a clocked signal function with a matching clock.---   Synchronicity is ensured by requiring that data enters (@In cl@)---   and leaves (@Out cl@) the system at the same as it is processed (@cl@).-(@@) :: ( cl ~ In cl-        , cl ~ Out cl )-     => ClSF m cl a b -> cl -> Rhine m cl a b++{- FOURMOLU_DISABLE -}+{- | Create a synchronous 'Rhine' by combining a clocked signal function with a matching clock.+   Synchronicity is ensured by requiring that data enters (@In cl@)+   and leaves (@Out cl@) the system at the same as it is processed (@cl@).+-}+(@@) ::+  ( cl ~ In cl+  , cl ~ Out cl+  ) =>+  ClSF  m cl a b ->+          cl     ->+  Rhine m cl a b (@@) = Rhine . Synchronous +{- | A point at which sequential asynchronous composition+   ("resampling") of signal networks can happen.+-}+data ResamplingPoint m cla clb a b+  = ResamplingPoint+      (ResamplingBuffer m (Out cla) (In clb) a b)+      (Schedule m cla clb) --- | A point at which sequential asynchronous composition---   ("resampling") of signal networks can happen.-data ResamplingPoint m cla clb a b = ResamplingPoint-  (ResamplingBuffer m (Out cla) (In clb) a b)-  (Schedule m cla clb) -- TODO Make a record out of it? -- TODO This is aesthetically displeasing. --      For the buffer, the associativity doesn't matter, but for the Schedule,@@ -57,21 +62,26 @@  -- | Syntactic sugar for 'ResamplingPoint'. infix 8 -@--(-@-) :: ResamplingBuffer m (Out cl1) (In cl2) a b-      -> Schedule         m      cl1      cl2-      -> ResamplingPoint  m      cl1      cl2  a b+(-@-) ::+  ResamplingBuffer m (Out cl1) (In cl2) a b ->+  Schedule         m      cl1      cl2      ->+  ResamplingPoint  m      cl1      cl2  a b (-@-) = ResamplingPoint --- | A purely syntactical convenience construction---   enabling quadruple syntax for sequential composition, as described below.+{- | A purely syntactical convenience construction+   enabling quadruple syntax for sequential composition, as described below.+-} infix 2 >---data RhineAndResamplingPoint m cl1 cl2 a c = forall b.-     RhineAndResamplingPoint (Rhine m cl1 a b) (ResamplingPoint m cl1 cl2 b c) +data RhineAndResamplingPoint m cl1 cl2 a c+  = forall b.+    RhineAndResamplingPoint (Rhine m cl1 a b) (ResamplingPoint m cl1 cl2 b c)+ -- | Syntactic sugar for 'RhineAndResamplingPoint'.-(>--) :: Rhine                   m cl1     a b-      -> ResamplingPoint         m cl1 cl2   b c-      -> RhineAndResamplingPoint m cl1 cl2 a   c+(>--) ::+  Rhine                   m cl1     a b   ->+  ResamplingPoint         m cl1 cl2   b c ->+  RhineAndResamplingPoint m cl1 cl2 a   c (>--) = RhineAndResamplingPoint  {- | The combinators for sequential composition allow for the following syntax:@@ -94,18 +104,19 @@ @ -} infixr 1 -->-(-->) :: ( Clock m cl1-         , Clock m cl2-         , Time cl1 ~ Time cl2-         , Time (Out cl1) ~ Time cl1-         , Time (In  cl2) ~ Time cl2-         , Clock m (Out cl1), Clock m (Out cl2)-         , Clock m (In  cl1), Clock m (In  cl2)-         , GetClockProxy cl1, GetClockProxy cl2-         )-      => RhineAndResamplingPoint   m cl1 cl2  a b-      -> Rhine m                         cl2    b c-      -> Rhine m  (SequentialClock m cl1 cl2) a   c+(-->) ::+  ( Clock m cl1+  , Clock m cl2+  , Time cl1 ~ Time cl2+  , Time (Out cl1) ~ Time cl1+  , Time (In  cl2) ~ Time cl2+  , Clock m (Out cl1), Clock m (Out cl2)+  , Clock m (In  cl1), Clock m (In  cl2)+  , GetClockProxy cl1, GetClockProxy cl2+  ) =>+  RhineAndResamplingPoint   m cl1 cl2  a b ->+  Rhine m                         cl2    b c ->+  Rhine m  (SequentialClock m cl1 cl2) a   c RhineAndResamplingPoint (Rhine sn1 cl1) (ResamplingPoint rb cc) --> (Rhine sn2 cl2)  = Rhine (Sequential sn1 rb sn2) (SequentialClock cl1 cl2 cc) @@ -116,10 +127,10 @@  -- | Syntactic sugar for 'RhineParallelAndSchedule'. infix 4 ++@-(++@)-  :: Rhine                    m clL     a b-  -> Schedule                 m clL clR-  -> RhineParallelAndSchedule m clL clR a b+(++@) ::+  Rhine                    m clL     a b ->+  Schedule                 m clL clR     ->+  RhineParallelAndSchedule m clL clR a b (++@) = RhineParallelAndSchedule  {- | The combinators for parallel composition allow for the following syntax:@@ -139,26 +150,26 @@ @ -} infix 3 @++-(@++)-  :: ( Monad m, Clock m clL, Clock m clR-     , Clock m (Out clL), Clock m (Out clR)-     , GetClockProxy clL, GetClockProxy clR-     , Time clL ~ Time (Out clL), Time clR ~ Time (Out clR)-     , Time clL ~ Time (In  clL), Time clR ~ Time (In  clR)-     , Time clL ~ Time clR-     )-       => RhineParallelAndSchedule m clL clR  a b-       -> Rhine                    m     clR  a c-       -> Rhine m (ParallelClock   m clL clR) a (Either b c)+(@++) ::+  ( Monad m, Clock m clL, Clock m clR+  , Clock m (Out clL), Clock m (Out clR)+  , GetClockProxy clL, GetClockProxy clR+  , Time clL ~ Time (Out clL), Time clR ~ Time (Out clR)+  , Time clL ~ Time (In  clL), Time clR ~ Time (In  clR)+  , Time clL ~ Time clR+  ) =>+  RhineParallelAndSchedule m clL clR  a         b    ->+  Rhine                    m     clR  a            c ->+  Rhine m (ParallelClock   m clL clR) a (Either b c) RhineParallelAndSchedule (Rhine sn1 clL) schedule @++ (Rhine sn2 clR)   = Rhine (sn1 ++++ sn2) (ParallelClock clL clR schedule)  -- | Further syntactic sugar for 'RhineParallelAndSchedule'. infix 4 ||@-(||@)-  :: Rhine                    m clL     a b-  -> Schedule                 m clL clR-  -> RhineParallelAndSchedule m clL clR a b+(||@) ::+  Rhine                    m clL     a b ->+  Schedule                 m clL clR     ->+  RhineParallelAndSchedule m clL clR a b (||@) = RhineParallelAndSchedule  {- | The combinators for parallel composition allow for the following syntax:@@ -178,53 +189,54 @@ @ -} infix 3 @||-(@||)-  :: ( Monad m, Clock m clL, Clock m clR-     , Clock m (Out clL), Clock m (Out clR)-     , GetClockProxy clL, GetClockProxy clR-     , Time clL ~ Time (Out clL), Time clR ~ Time (Out clR)-     , Time clL ~ Time (In  clL), Time clR ~ Time (In  clR)-     , Time clL ~ Time clR-     )-       => RhineParallelAndSchedule m clL clR  a b-       -> Rhine                    m     clR  a b-       -> Rhine m (ParallelClock   m clL clR) a b+(@||) ::+  ( Monad m, Clock m clL, Clock m clR+  , Clock m (Out clL), Clock m (Out clR)+  , GetClockProxy clL, GetClockProxy clR+  , Time clL ~ Time (Out clL), Time clR ~ Time (Out clR)+  , Time clL ~ Time (In  clL), Time clR ~ Time (In  clR)+  , Time clL ~ Time clR+  ) =>+  RhineParallelAndSchedule m clL clR  a b ->+  Rhine                    m     clR  a b ->+  Rhine m (ParallelClock   m clL clR) a b RhineParallelAndSchedule (Rhine sn1 clL) schedule @|| (Rhine sn2 clR)   = Rhine (sn1 |||| sn2) (ParallelClock clL clR schedule)   -- | Postcompose a 'Rhine' with a pure function.-(@>>^)-  :: Monad m-  => Rhine m cl a b-  ->             (b -> c)-  -> Rhine m cl a      c+(@>>^) ::+  Monad m =>+  Rhine m cl a b       ->+              (b -> c) ->+  Rhine m cl a      c Rhine sn cl @>>^ f = Rhine (sn >>>^ f) cl  -- | Precompose a 'Rhine' with a pure function.-(^>>@)-  :: Monad m-  =>           (a -> b)-  -> Rhine m cl      b c-  -> Rhine m cl a      c+(^>>@) ::+  Monad m =>+            (a -> b)  ->+  Rhine m cl      b c ->+  Rhine m cl a      c f ^>>@ Rhine sn cl = Rhine (f ^>>> sn) cl  -- | Postcompose a 'Rhine' with a 'ClSF'.-(@>-^)-  :: ( Clock m (Out cl)-     , Time cl ~ Time (Out cl)-     )-  => Rhine m      cl  a b-  -> ClSF  m (Out cl)   b c-  -> Rhine m      cl  a   c+(@>-^) ::+  ( Clock m (Out cl)+  , Time cl ~ Time (Out cl)+  ) =>+  Rhine m      cl  a b   ->+  ClSF  m (Out cl)   b c ->+  Rhine m      cl  a   c Rhine sn cl @>-^ clsf = Rhine (sn >--^ clsf) cl  -- | Precompose a 'Rhine' with a 'ClSF'.-(^->@)-  :: ( Clock m (In cl)-     , Time cl ~ Time (In cl)-     )-  => ClSF  m (In cl) a b-  -> Rhine m     cl    b c-  -> Rhine m     cl  a   c+(^->@) ::+  ( Clock m (In cl)+  , Time cl ~ Time (In cl)+  ) =>+  ClSF  m (In cl) a b   ->+  Rhine m     cl    b c ->+  Rhine m     cl  a   c clsf ^->@ Rhine sn cl = Rhine (clsf ^--> sn) cl+{- FOURMOLU_ENABLE -}
src/FRP/Rhine/ResamplingBuffer.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+ {- | This module introduces 'ResamplingBuffer's, which are primitives that consume and produce data at different rates.@@ -5,15 +9,11 @@ (resampling) buffers form the boundaries between synchronous signal functions ticking at different speeds. -}--{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies #-}-module FRP.Rhine.ResamplingBuffer-  ( module FRP.Rhine.ResamplingBuffer-  , module FRP.Rhine.Clock-  )-  where+module FRP.Rhine.ResamplingBuffer (+  module FRP.Rhine.ResamplingBuffer,+  module FRP.Rhine.Clock,+)+where  -- rhine import FRP.Rhine.Clock@@ -37,30 +37,30 @@ * 'b': The output type -} data ResamplingBuffer m cla clb a b = ResamplingBuffer-  { put-      :: TimeInfo cla-      -> a-      -> m (   ResamplingBuffer m cla clb a b)-    -- ^ Store one input value of type 'a' at a given time stamp,-    --   and return a continuation.-  , get-      :: TimeInfo clb-      -> m (b, ResamplingBuffer m cla clb a b)-    -- ^ Retrieve one output value of type 'b' at a given time stamp,-    --   and a continuation.+  { put ::+      TimeInfo cla ->+      a ->+      m (ResamplingBuffer m cla clb a b)+  -- ^ Store one input value of type 'a' at a given time stamp,+  --   and return a continuation.+  , get ::+      TimeInfo clb ->+      m (b, ResamplingBuffer m cla clb a b)+  -- ^ Retrieve one output value of type 'b' at a given time stamp,+  --   and a continuation.   }  -- | A type synonym to allow for abbreviation. type ResBuf m cla clb a b = ResamplingBuffer m cla clb a b - -- | Hoist a 'ResamplingBuffer' along a monad morphism.-hoistResamplingBuffer-  :: (Monad m1, Monad m2)-  => (forall c. m1 c -> m2 c)-  -> ResamplingBuffer m1 cla clb a b-  -> ResamplingBuffer m2 cla clb a b-hoistResamplingBuffer hoist ResamplingBuffer {..} = ResamplingBuffer-  { put = (((hoistResamplingBuffer hoist <$>) . hoist) .) . put-  , get = (second (hoistResamplingBuffer hoist) <$>) . hoist . get-  }+hoistResamplingBuffer ::+  (Monad m1, Monad m2) =>+  (forall c. m1 c -> m2 c) ->+  ResamplingBuffer m1 cla clb a b ->+  ResamplingBuffer m2 cla clb a b+hoistResamplingBuffer hoist ResamplingBuffer {..} =+  ResamplingBuffer+    { put = (((hoistResamplingBuffer hoist <$>) . hoist) .) . put+    , get = (second (hoistResamplingBuffer hoist) <$>) . hoist . get+    }
src/FRP/Rhine/ResamplingBuffer/Collect.hs view
@@ -1,10 +1,10 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RecordWildCards #-}+ {- | Resampling buffers that collect the incoming data in some data structure and release all of it on output. -}--{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE RecordWildCards #-} module FRP.Rhine.ResamplingBuffer.Collect where  -- containers@@ -14,42 +14,48 @@ import FRP.Rhine.ResamplingBuffer import FRP.Rhine.ResamplingBuffer.Timeless --- | Collects all input in a list, with the newest element at the head,---   which is returned and emptied upon `get`.+{- | Collects all input in a list, with the newest element at the head,+   which is returned and emptied upon `get`.+-} collect :: Monad m => ResamplingBuffer m cl1 cl2 a [a] collect = timelessResamplingBuffer AsyncMealy {..} []   where     amPut as a = return $ a : as-    amGet as   = return (as, [])-+    amGet as = return (as, []) --- | Reimplementation of 'collect' with sequences,---   which gives a performance benefit if the sequence needs to be reversed or searched.+{- | Reimplementation of 'collect' with sequences,+   which gives a performance benefit if the sequence needs to be reversed or searched.+-} collectSequence :: Monad m => ResamplingBuffer m cl1 cl2 a (Seq a) collectSequence = timelessResamplingBuffer AsyncMealy {..} empty   where     amPut as a = return $ a <| as-    amGet as   = return (as, empty)+    amGet as = return (as, empty) --- | 'pureBuffer' collects all input values lazily in a list---   and processes it when output is required.---   Semantically, @pureBuffer f == collect >>-^ arr f@,---   but 'pureBuffer' is slightly more efficient.+{- | 'pureBuffer' collects all input values lazily in a list+   and processes it when output is required.+   Semantically, @pureBuffer f == collect >>-^ arr f@,+   but 'pureBuffer' is slightly more efficient.+-} pureBuffer :: Monad m => ([a] -> b) -> ResamplingBuffer m cl1 cl2 a b pureBuffer f = timelessResamplingBuffer AsyncMealy {..} []   where     amPut as a = return (a : as)-    amGet as   = return (f as, [])+    amGet as = return (f as, [])  -- TODO Test whether strictness works here, or consider using deepSeq--- | A buffer collecting all incoming values with a folding function.---   It is strict, i.e. the state value 'b' is calculated on every 'put'.-foldBuffer-  :: Monad m-  => (a -> b -> b) -- ^ The folding function-  -> b -- ^ The initial value-  -> ResamplingBuffer m cl1 cl2 a b++{- | A buffer collecting all incoming values with a folding function.+   It is strict, i.e. the state value 'b' is calculated on every 'put'.+-}+foldBuffer ::+  Monad m =>+  -- | The folding function+  (a -> b -> b) ->+  -- | The initial value+  b ->+  ResamplingBuffer m cl1 cl2 a b foldBuffer f = timelessResamplingBuffer AsyncMealy {..}   where     amPut b a = let !b' = f a b in return b'-    amGet b   = return (b, b)+    amGet b = return (b, b)
src/FRP/Rhine/ResamplingBuffer/FIFO.hs view
@@ -1,8 +1,8 @@+{-# LANGUAGE RecordWildCards #-}+ {- | Different implementations of FIFO buffers. -}--{-# LANGUAGE RecordWildCards #-} module FRP.Rhine.ResamplingBuffer.FIFO where  -- base@@ -17,31 +17,33 @@  -- * FIFO (first-in-first-out) buffers --- | An unbounded FIFO buffer.---   If the buffer is empty, it will return 'Nothing'.+{- | An unbounded FIFO buffer.+   If the buffer is empty, it will return 'Nothing'.+-} fifoUnbounded :: Monad m => ResamplingBuffer m cl1 cl2 a (Maybe a) fifoUnbounded = timelessResamplingBuffer AsyncMealy {..} empty   where     amPut as a = return $ a <| as-    amGet as   = case viewr as of-      EmptyR   -> return (Nothing, empty)-      as' :> a -> return (Just a , as'  )+    amGet as = case viewr as of+      EmptyR -> return (Nothing, empty)+      as' :> a -> return (Just a, as') --- |  A bounded FIFO buffer that forgets the oldest values when the size is above a given threshold.---    If the buffer is empty, it will return 'Nothing'.+{- |  A bounded FIFO buffer that forgets the oldest values when the size is above a given threshold.+    If the buffer is empty, it will return 'Nothing'.+-} fifoBounded :: Monad m => Int -> ResamplingBuffer m cl1 cl2 a (Maybe a) fifoBounded threshold = timelessResamplingBuffer AsyncMealy {..} empty   where     amPut as a = return $ take threshold $ a <| as     amGet as = case viewr as of-      EmptyR   -> return (Nothing, empty)-      as' :> a -> return (Just a , as'  )+      EmptyR -> return (Nothing, empty)+      as' :> a -> return (Just a, as')  -- | An unbounded FIFO buffer that also returns its current size. fifoWatch :: Monad m => ResamplingBuffer m cl1 cl2 a (Maybe a, Int) fifoWatch = timelessResamplingBuffer AsyncMealy {..} empty   where     amPut as a = return $ a <| as-    amGet as   = case viewr as of-      EmptyR   -> return ((Nothing, 0         ), empty)-      as' :> a -> return ((Just a , length as'), as'  )+    amGet as = case viewr as of+      EmptyR -> return ((Nothing, 0), empty)+      as' :> a -> return ((Just a, length as'), as')
src/FRP/Rhine/ResamplingBuffer/Interpolation.hs view
@@ -1,11 +1,11 @@-{- |-Interpolation buffers.--}- {-# LANGUAGE Arrows #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-}++{- |+Interpolation buffers.+-} module FRP.Rhine.ResamplingBuffer.Interpolation where  -- containers@@ -17,26 +17,30 @@ -- rhine import FRP.Rhine.ClSF import FRP.Rhine.ResamplingBuffer-import FRP.Rhine.ResamplingBuffer.Util import FRP.Rhine.ResamplingBuffer.KeepLast+import FRP.Rhine.ResamplingBuffer.Util  -- | A simple linear interpolation based on the last calculated position and velocity.-linear-  :: ( Monad m, Clock m cl1, Clock m cl2-     , VectorSpace v s-     , s ~ Diff (Time cl1)-     , s ~ Diff (Time cl2)-     )-  => v -- ^ The initial velocity (derivative of the signal)-  -> v -- ^ The initial position-  -> ResamplingBuffer m cl1 cl2 v v-linear initVelocity initPosition-  =    (derivativeFrom initPosition &&& clId) &&& timeInfoOf sinceInit-  ^->> keepLast ((initVelocity, initPosition), 0)-  >>-^ proc ((velocity, lastPosition), sinceInit1) -> do-    sinceInit2 <- timeInfoOf sinceInit -< ()-    let diff = sinceInit2 - sinceInit1-    returnA -< lastPosition ^+^ diff *^ velocity+linear ::+  ( Monad m+  , Clock m cl1+  , Clock m cl2+  , VectorSpace v s+  , s ~ Diff (Time cl1)+  , s ~ Diff (Time cl2)+  ) =>+  -- | The initial velocity (derivative of the signal)+  v ->+  -- | The initial position+  v ->+  ResamplingBuffer m cl1 cl2 v v+linear initVelocity initPosition =+  (derivativeFrom initPosition &&& clId) &&& timeInfoOf sinceInit+    ^->> keepLast ((initVelocity, initPosition), 0)+      >>-^ proc ((velocity, lastPosition), sinceInit1) -> do+        sinceInit2 <- timeInfoOf sinceInit -< ()+        let diff = sinceInit2 - sinceInit1+        returnA -< lastPosition ^+^ diff *^ velocity  {- | sinc-Interpolation, or Whittaker-Shannon-Interpolation.@@ -49,44 +53,53 @@ the buffer only remembers the past values within a given window, which should be chosen much larger than the average time between @cl1@'s ticks. -}-sinc-  :: ( Monad m, Clock m cl1, Clock m cl2-     , VectorSpace v s-     , Ord (s)-     , Floating (s)-     , s ~ Diff (Time cl1)-     , s ~ Diff (Time cl2)-     )-  => s-  -- ^ The size of the interpolation window+sinc ::+  ( Monad m+  , Clock m cl1+  , Clock m cl2+  , VectorSpace v s+  , Ord s+  , Floating s+  , s ~ Diff (Time cl1)+  , s ~ Diff (Time cl2)+  ) =>+  -- | The size of the interpolation window   --   (for how long in the past to remember incoming values)-  -> ResamplingBuffer m cl1 cl2 v v-sinc windowSize = historySince windowSize ^->> keepLast empty >>-^ proc as -> do-  sinceInit2 <- sinceInitS -< ()-  returnA                  -< vectorSum $ mkSinc sinceInit2 <$> as+  s ->+  ResamplingBuffer m cl1 cl2 v v+sinc windowSize =+  historySince windowSize+    ^->> keepLast empty >>-^ proc as -> do+      sinceInit2 <- sinceInitS -< ()+      returnA -< vectorSum $ mkSinc sinceInit2 <$> as   where-    mkSinc sinceInit2 (TimeInfo {..}, as)-      = let t = pi * (sinceInit2 - sinceInit) / sinceLast-        in  (sin t / t) *^ as+    mkSinc sinceInit2 (TimeInfo {..}, as) =+      let t = pi * (sinceInit2 - sinceInit) / sinceLast+       in (sin t / t) *^ as     vectorSum = foldr (^+^) zeroVector  -- TODO Do we want to give initial values?--- | Interpolates the signal with Hermite splines,---   using 'threePointDerivative'.------   Caution: In order to calculate the derivatives of the incoming signal,---   it has to be delayed by two ticks of @cl1@.---   In a non-realtime situation, a higher quality is achieved---   if the ticks of @cl2@ are delayed by two ticks of @cl1@.-cubic-  :: ( Monad m-     , VectorSpace v s-     , Floating v, Eq v-     , s ~ Diff (Time cl1)-     , s ~ Diff (Time cl2)-     )-  => ResamplingBuffer m cl1 cl2 v v-cubic = ((iPre zeroVector &&& threePointDerivative) &&& (sinceInitS >-> iPre 0))++{- | Interpolates the signal with Hermite splines,+   using 'threePointDerivative'.++   Caution: In order to calculate the derivatives of the incoming signal,+   it has to be delayed by two ticks of @cl1@.+   In a non-realtime situation, a higher quality is achieved+   if the ticks of @cl2@ are delayed by two ticks of @cl1@.+-}+cubic ::+  ( Monad m+  , VectorSpace v s+  , Floating v+  , Eq v+  , s ~ Diff (Time cl1)+  , s ~ Diff (Time cl2)+  ) =>+  ResamplingBuffer m cl1 cl2 v v+{- FOURMOLU_DISABLE -}+cubic =+  ((iPre zeroVector &&& threePointDerivative) &&& (sinceInitS >-> iPre 0))     >-> (clId &&& iPre (zeroVector, 0))    ^->> keepLast ((zeroVector, 0), (zeroVector, 0))    >>-^ proc (((dv, v), t1), ((dv', v'), t1')) -> do@@ -100,3 +113,4 @@               ^+^ (-2 * tcubed + 3 * tsquared        ) *^  v               ^+^ (     tcubed -     tsquared        ) *^ dv      returnA -< vInter+{- FOURMOLU_ENABLE -}
src/FRP/Rhine/ResamplingBuffer/KeepLast.hs view
@@ -1,19 +1,20 @@+{-# LANGUAGE RecordWildCards #-}+ {- | A buffer keeping the last value, or zero-order hold. -}--{-# LANGUAGE RecordWildCards #-} module FRP.Rhine.ResamplingBuffer.KeepLast where  import FRP.Rhine.ResamplingBuffer import FRP.Rhine.ResamplingBuffer.Timeless --- | Always keeps the last input value,---   or in case of no input an initialisation value.---   If @cl2@ approximates continuity,---   this behaves like a zero-order hold.+{- | Always keeps the last input value,+   or in case of no input an initialisation value.+   If @cl2@ approximates continuity,+   this behaves like a zero-order hold.+-} keepLast :: Monad m => a -> ResamplingBuffer m cl1 cl2 a a keepLast = timelessResamplingBuffer AsyncMealy {..}   where-    amPut _ a = return a-    amGet   a = return (a, a)+    amGet a = return (a, a)+    amPut _ = return
src/FRP/Rhine/ResamplingBuffer/LIFO.hs view
@@ -1,8 +1,8 @@+{-# LANGUAGE RecordWildCards #-}+ {- | Different implementations of LIFO buffers. -}--{-# LANGUAGE RecordWildCards #-} module FRP.Rhine.ResamplingBuffer.LIFO where  -- base@@ -17,31 +17,33 @@  -- * LIFO (last-in-first-out) buffers --- | An unbounded LIFO buffer.---   If the buffer is empty, it will return 'Nothing'.+{- | An unbounded LIFO buffer.+   If the buffer is empty, it will return 'Nothing'.+-} lifoUnbounded :: Monad m => ResamplingBuffer m cl1 cl2 a (Maybe a) lifoUnbounded = timelessResamplingBuffer AsyncMealy {..} empty   where     amPut as a = return $ a <| as-    amGet as   = case viewl as of-      EmptyL   -> return (Nothing, empty)-      a :< as' -> return (Just a , as'  )+    amGet as = case viewl as of+      EmptyL -> return (Nothing, empty)+      a :< as' -> return (Just a, as') --- |  A bounded LIFO buffer that forgets the oldest values when the size is above a given threshold.---   If the buffer is empty, it will return 'Nothing'.+{- |  A bounded LIFO buffer that forgets the oldest values when the size is above a given threshold.+   If the buffer is empty, it will return 'Nothing'.+-} lifoBounded :: Monad m => Int -> ResamplingBuffer m cl1 cl2 a (Maybe a) lifoBounded threshold = timelessResamplingBuffer AsyncMealy {..} empty   where     amPut as a = return $ take threshold $ a <| as     amGet as = case viewl as of-      EmptyL   -> return (Nothing, empty)-      a :< as' -> return (Just a , as'  )+      EmptyL -> return (Nothing, empty)+      a :< as' -> return (Just a, as')  -- | An unbounded LIFO buffer that also returns its current size. lifoWatch :: Monad m => ResamplingBuffer m cl1 cl2 a (Maybe a, Int) lifoWatch = timelessResamplingBuffer AsyncMealy {..} empty   where     amPut as a = return $ a <| as-    amGet as   = case viewl as of-      EmptyL   -> return ((Nothing, 0         ), empty)-      a :< as' -> return ((Just a , length as'), as'  )+    amGet as = case viewl as of+      EmptyL -> return ((Nothing, 0), empty)+      a :< as' -> return ((Just a, length as'), as')
src/FRP/Rhine/ResamplingBuffer/MSF.hs view
@@ -1,8 +1,8 @@+{-# LANGUAGE RecordWildCards #-}+ {- | Collect and process all incoming values statefully and with time stamps. -}--{-# LANGUAGE RecordWildCards #-} module FRP.Rhine.ResamplingBuffer.MSF where  -- dunai@@ -11,29 +11,30 @@ -- rhine import FRP.Rhine.ResamplingBuffer --- | Given a monadic stream function that accepts---   a varying number of inputs (a list),---   a `ResamplingBuffer` can be formed---   that collects all input in a timestamped list.-msfBuffer-  :: Monad m-  => MSF m (TimeInfo cl2, [(TimeInfo cl1, a)]) b-  -- ^ The monadic stream function that consumes+{- | Given a monadic stream function that accepts+   a varying number of inputs (a list),+   a `ResamplingBuffer` can be formed+   that collects all input in a timestamped list.+-}+msfBuffer ::+  Monad m =>+  -- | The monadic stream function that consumes   --   a single time stamp for the moment when an output value is required,   --   and a list of timestamped inputs,   --   and outputs a single value.   --   The list will contain the /newest/ element in the head.-  -> ResamplingBuffer m cl1 cl2 a b+  MSF m (TimeInfo cl2, [(TimeInfo cl1, a)]) b ->+  ResamplingBuffer m cl1 cl2 a b msfBuffer = msfBuffer' []   where-    msfBuffer'-      :: Monad m-      => [(TimeInfo cl1, a)]-      -> MSF m (TimeInfo cl2, [(TimeInfo cl1, a)]) b-      -> ResamplingBuffer m cl1 cl2 a b+    msfBuffer' ::+      Monad m =>+      [(TimeInfo cl1, a)] ->+      MSF m (TimeInfo cl2, [(TimeInfo cl1, a)]) b ->+      ResamplingBuffer m cl1 cl2 a b     msfBuffer' as msf = ResamplingBuffer {..}       where         put ti1 a = return $ msfBuffer' ((ti1, a) : as) msf-        get ti2   = do+        get ti2 = do           (b, msf') <- unMSF msf (ti2, as)           return (b, msfBuffer msf')
src/FRP/Rhine/ResamplingBuffer/Timeless.hs view
@@ -1,46 +1,57 @@+{-# LANGUAGE RecordWildCards #-}+ {- | Resampling buffers from asynchronous Mealy machines. These are used in many other modules implementing 'ResamplingBuffer's. -}--{-# LANGUAGE RecordWildCards #-} module FRP.Rhine.ResamplingBuffer.Timeless where  import FRP.Rhine.ResamplingBuffer --- | An asynchronous, effectful Mealy machine description.---   (Input and output do not happen simultaneously.)---   It can be used to create 'ResamplingBuffer's.+{- | An asynchronous, effectful Mealy machine description.+   (Input and output do not happen simultaneously.)+   It can be used to create 'ResamplingBuffer's.+-}+{- FOURMOLU_DISABLE -} data AsyncMealy m s a b = AsyncMealy-  { amPut :: s -> a -> m     s -- ^ Given the previous state and an input value, return the new state.-  , amGet :: s      -> m (b, s) -- ^ Given the previous state, return an output value and a new state.+  { amPut :: s -> a -> m     s+  -- ^ Given the previous state and an input value, return the new state.+  , amGet :: s      -> m (b, s)+  -- ^ Given the previous state, return an output value and a new state.   }+{- FOURMOLU_ENABLE -} --- | A resampling buffer that is unaware of the time information of the clock,---   and thus clock-polymorphic.---   It is built from an asynchronous Mealy machine description.---   Whenever 'get' is called on @timelessResamplingBuffer machine s@,---   the method 'amGet' is called on @machine@ with state @s@,---   discarding the time stamp. Analogously for 'put'.-timelessResamplingBuffer-  :: Monad m-  => AsyncMealy m s a b -- The asynchronous Mealy machine from which the buffer is built-  -> s -- ^ The initial state-  -> ResamplingBuffer m cl1 cl2 a b+{- | A resampling buffer that is unaware of the time information of the clock,+   and thus clock-polymorphic.+   It is built from an asynchronous Mealy machine description.+   Whenever 'get' is called on @timelessResamplingBuffer machine s@,+   the method 'amGet' is called on @machine@ with state @s@,+   discarding the time stamp. Analogously for 'put'.+-}+timelessResamplingBuffer ::+  Monad m =>+  AsyncMealy m s a b -> -- The asynchronous Mealy machine from which the buffer is built++  -- | The initial state+  s ->+  ResamplingBuffer m cl1 cl2 a b timelessResamplingBuffer AsyncMealy {..} = go   where     go s =       let         put _ a = go <$> amPut s a-        get _   = do+        get _ = do           (b, s') <- amGet s           return (b, go s')-      in ResamplingBuffer {..}+       in+        ResamplingBuffer {..}  -- | A resampling buffer that only accepts and emits units. trivialResamplingBuffer :: Monad m => ResamplingBuffer m cl1 cl2 () ()-trivialResamplingBuffer = timelessResamplingBuffer AsyncMealy-  { amPut = const (const (return ()))-  , amGet = const (return ((), ()))-  }-  ()+trivialResamplingBuffer =+  timelessResamplingBuffer+    AsyncMealy+      { amPut = const (const (return ()))+      , amGet = const (return ((), ()))+      }+    ()
src/FRP/Rhine/ResamplingBuffer/Util.hs view
@@ -1,8 +1,8 @@+{-# LANGUAGE RankNTypes #-}+ {- | Several utilities to create 'ResamplingBuffer's. -}--{-# LANGUAGE RankNTypes #-} module FRP.Rhine.ResamplingBuffer.Util where  -- transformers@@ -12,73 +12,81 @@ import Data.MonadicStreamFunction.InternalCore  -- rhine-import FRP.Rhine.Clock import FRP.Rhine.ClSF+import FRP.Rhine.Clock import FRP.Rhine.ResamplingBuffer  -- * Utilities to build 'ResamplingBuffer's from smaller components  infix 2 >>-^++{- FOURMOLU_DISABLE -}+ -- | Postcompose a 'ResamplingBuffer' with a matching 'ClSF'.-(>>-^) :: Monad m-      => ResamplingBuffer m cl1 cl2 a b-      -> ClSF             m     cl2   b c-      -> ResamplingBuffer m cl1 cl2 a   c+(>>-^) ::+  Monad m =>+  ResamplingBuffer m cl1 cl2 a b   ->+  ClSF             m     cl2   b c ->+  ResamplingBuffer m cl1 cl2 a   c resBuf >>-^ clsf = ResamplingBuffer put_ get_   where     put_ theTimeInfo a = (>>-^ clsf) <$> put resBuf theTimeInfo a-    get_ theTimeInfo   = do+    get_ theTimeInfo = do       (b, resBuf') <- get resBuf theTimeInfo-      (c, clsf')   <- unMSF clsf b `runReaderT` theTimeInfo+      (c, clsf') <- unMSF clsf b `runReaderT` theTimeInfo       return (c, resBuf' >>-^ clsf') - infix 1 ^->>+ -- | Precompose a 'ResamplingBuffer' with a matching 'ClSF'.-(^->>) :: Monad m-      => ClSF             m cl1     a b-      -> ResamplingBuffer m cl1 cl2   b c-      -> ResamplingBuffer m cl1 cl2 a   c+(^->>) ::+  Monad m =>+  ClSF             m cl1     a b   ->+  ResamplingBuffer m cl1 cl2   b c ->+  ResamplingBuffer m cl1 cl2 a   c clsf ^->> resBuf = ResamplingBuffer put_ get_   where     put_ theTimeInfo a = do       (b, clsf') <- unMSF clsf a `runReaderT` theTimeInfo-      resBuf'    <- put resBuf theTimeInfo b+      resBuf' <- put resBuf theTimeInfo b       return $ clsf' ^->> resBuf'-    get_ theTimeInfo   = second (clsf ^->>) <$> get resBuf theTimeInfo-+    get_ theTimeInfo = second (clsf ^->>) <$> get resBuf theTimeInfo  infixl 4 *-*+ -- | Parallely compose two 'ResamplingBuffer's.-(*-*) :: Monad m-      => ResamplingBuffer m cl1 cl2  a      b-      -> ResamplingBuffer m cl1 cl2     c      d-      -> ResamplingBuffer m cl1 cl2 (a, c) (b, d)+(*-*) ::+  Monad m =>+  ResamplingBuffer m cl1 cl2  a      b    ->+  ResamplingBuffer m cl1 cl2     c      d ->+  ResamplingBuffer m cl1 cl2 (a, c) (b, d) resBuf1 *-* resBuf2 = ResamplingBuffer put_ get_   where     put_ theTimeInfo (a, c) = do       resBuf1' <- put resBuf1 theTimeInfo a       resBuf2' <- put resBuf2 theTimeInfo c       return $ resBuf1' *-* resBuf2'-    get_ theTimeInfo        = do+    get_ theTimeInfo = do       (b, resBuf1') <- get resBuf1 theTimeInfo       (d, resBuf2') <- get resBuf2 theTimeInfo       return ((b, d), resBuf1' *-* resBuf2')  infixl 4 &-&+ -- | Parallely compose two 'ResamplingBuffer's, duplicating the input.-(&-&) :: Monad m-      => ResamplingBuffer m cl1 cl2  a  b-      -> ResamplingBuffer m cl1 cl2  a     c-      -> ResamplingBuffer m cl1 cl2  a (b, c)+(&-&) ::+  Monad m =>+  ResamplingBuffer m cl1 cl2  a  b    ->+  ResamplingBuffer m cl1 cl2  a     c ->+  ResamplingBuffer m cl1 cl2  a (b, c) resBuf1 &-& resBuf2 = arr (\a -> (a, a)) ^->> resBuf1 *-* resBuf2 ---- | Given a 'ResamplingBuffer' where the output type depends on the input type polymorphically,---   we can produce a timestamped version that simply annotates every input value---   with the 'TimeInfo' when it arrived.-timestamped-  :: Monad m-  => (forall b. ResamplingBuffer m cl clf b (f b))-  -> ResamplingBuffer m cl clf a (f (a, TimeInfo cl))+{- | Given a 'ResamplingBuffer' where the output type depends on the input type polymorphically,+   we can produce a timestamped version that simply annotates every input value+   with the 'TimeInfo' when it arrived.+-}+timestamped ::+  Monad m =>+  (forall b. ResamplingBuffer m cl clf b (f b)) ->+  ResamplingBuffer m cl clf a (f (a, TimeInfo cl)) timestamped resBuf = (clId &&& timeInfo) ^->> resBuf
src/FRP/Rhine/SN.hs view
@@ -1,3 +1,8 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+ {- | Asynchronous signal networks are combinations of clocked signal functions ('ClSF's) and matching 'ResamplingBuffer's,@@ -6,21 +11,16 @@ This module defines the 'SN' type, combinators are found in a submodule. -}--{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-} module FRP.Rhine.SN where - -- rhine+import FRP.Rhine.ClSF.Core import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy-import FRP.Rhine.ClSF.Core import FRP.Rhine.ResamplingBuffer import FRP.Rhine.Schedule +{- FOURMOLU_DISABLE -}  {- | An 'SN' is a side-effectful asynchronous /__s__ignal __n__etwork/, where input, data processing (including side effects) and output@@ -37,73 +37,79 @@ data SN m cl a b where   -- | A synchronous monadic stream function is the basic building block.   --   For such an 'SN', data enters and leaves the system at the same rate as it is processed.-  Synchronous-    :: ( cl ~ In cl, cl ~ Out cl)-    => ClSF m cl a b-    -> SN   m cl a b+  Synchronous ::+    ( cl ~ In cl, cl ~ Out cl) =>+    ClSF m cl a b ->+    SN   m cl a b+   -- | Two 'SN's may be sequentially composed if there is a matching 'ResamplingBuffer' between them.-  Sequential-    :: ( Clock m clab, Clock m clcd-       , Clock m (Out clab), Clock m (Out clcd)-       , Clock m (In  clab), Clock m (In  clcd)-       , GetClockProxy clab, GetClockProxy clcd-       , Time clab ~ Time clcd-       , Time clab ~ Time (Out clab)-       , Time clcd ~ Time (In  clcd)-       )-    => SN               m      clab            a b-    -> ResamplingBuffer m (Out clab) (In clcd)   b c-    -> SN               m                clcd      c d-    -> SN m (SequentialClock m clab      clcd) a     d+  Sequential ::+    ( Clock m clab, Clock m clcd+    , Clock m (Out clab), Clock m (Out clcd)+    , Clock m (In  clab), Clock m (In  clcd)+    , GetClockProxy clab, GetClockProxy clcd+    , Time clab ~ Time clcd+    , Time clab ~ Time (Out clab)+    , Time clcd ~ Time (In  clcd)+    ) =>+    SN               m      clab            a b     ->+    ResamplingBuffer m (Out clab) (In clcd)   b c   ->+    SN               m                clcd      c d ->+    SN m (SequentialClock m clab      clcd) a     d+   -- | Two 'SN's with the same input and output data may be parallely composed.-  Parallel-    :: ( Clock m cl1, Clock m cl2-       , Clock m (Out cl1), Clock m (Out cl2)-       , GetClockProxy cl1, GetClockProxy cl2-       , Time cl1 ~ Time (Out cl1)-       , Time cl2 ~ Time (Out cl2)-       , Time cl1 ~ Time cl2-       , Time cl1 ~ Time (In cl1)-       , Time cl2 ~ Time (In cl2)-       )-    => SN m                  cl1      a b-    -> SN m                      cl2  a b-    -> SN m (ParallelClock m cl1 cl2) a b+  Parallel ::+    ( Clock m cl1, Clock m cl2+    , Clock m (Out cl1), Clock m (Out cl2)+    , GetClockProxy cl1, GetClockProxy cl2+    , Time cl1 ~ Time (Out cl1)+    , Time cl2 ~ Time (Out cl2)+    , Time cl1 ~ Time cl2+    , Time cl1 ~ Time (In cl1)+    , Time cl2 ~ Time (In cl2)+    ) =>+    SN m                  cl1      a b ->+    SN m                      cl2  a b ->+    SN m (ParallelClock m cl1 cl2) a b+   -- | Bypass the signal network by forwarding data in parallel through a 'ResamplingBuffer'.-  FirstResampling-    :: ( Clock m (In cl), Clock m (Out cl)-       , Time cl ~ Time (Out cl)-       , Time cl ~ Time (In cl)-       )-    => SN               m cl               a      b-    -> ResamplingBuffer m (In cl) (Out cl)    c      d-    -> SN               m cl              (a, c) (b, d)+  FirstResampling ::+    ( Clock m (In cl), Clock m (Out cl)+    , Time cl ~ Time (Out cl)+    , Time cl ~ Time (In cl)+    ) =>+    SN               m cl               a      b    ->+    ResamplingBuffer m (In cl) (Out cl)    c      d ->+    SN               m cl              (a, c) (b, d)+   -- | A 'ClSF' can always be postcomposed onto an 'SN' if the clocks match on the output.-  Postcompose-    :: ( Clock m (Out cl)-       , Time cl ~ Time (Out cl)-       )-    => SN    m      cl  a b-    -> ClSF  m (Out cl)   b c-    -> SN    m      cl  a   c+  Postcompose ::+    ( Clock m (Out cl)+    , Time cl ~ Time (Out cl)+    ) =>+    SN    m      cl  a b   ->+    ClSF  m (Out cl)   b c ->+    SN    m      cl  a   c+   -- | A 'ClSF' can always be precomposed onto an 'SN' if the clocks match on the input.-  Precompose-    :: ( Clock m (In cl)-       , Time cl ~ Time (In cl)-       )-    => ClSF m (In cl) a b-    -> SN   m     cl    b c-    -> SN   m     cl  a   c+  Precompose ::+    ( Clock m (In cl)+    , Time cl ~ Time (In cl)+    ) =>+    ClSF m (In cl) a b   ->+    SN   m     cl    b c ->+    SN   m     cl  a   c+   -- | Data can be looped back to the beginning of an 'SN',   --   but it must be resampled since the 'Out' and 'In' clocks are generally different.-  Feedback-    :: ( Clock m (In cl),  Clock m (Out cl)-       , Time (In cl) ~ Time cl-       , Time (Out cl) ~ Time cl-       )-    => ResBuf m (Out cl) (In cl) d c-    -> SN     m cl (a, c) (b, d)-    -> SN     m cl  a      b+  Feedback ::+    ( Clock m (In cl),  Clock m (Out cl)+    , Time (In cl) ~ Time cl+    , Time (Out cl) ~ Time cl+    ) =>+    ResBuf m (Out cl) (In cl) d c ->+    SN     m cl (a, c) (b, d) ->+    SN     m cl  a      b  instance GetClockProxy cl => ToClockProxy (SN m cl a b) where   type Cl (SN m cl a b) = cl
src/FRP/Rhine/SN/Combinators.hs view
@@ -1,20 +1,20 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+ {- | Combinators for composing signal networks sequentially and parallely. -}--{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-} module FRP.Rhine.SN.Combinators where - -- rhine import FRP.Rhine.ClSF.Core+import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy import FRP.Rhine.ResamplingBuffer.Util-import FRP.Rhine.Schedule import FRP.Rhine.SN-+import FRP.Rhine.Schedule +{- FOURMOLU_DISABLE -} -- | Postcompose a signal network with a pure function. (>>>^)   :: Monad m@@ -75,21 +75,17 @@   where     sn1 = sn11 **** sn21     sn2 = sn12 **** sn22-    rb  = rb1 *-* rb2-Parallel sn11 sn12 **** Parallel sn21 sn22-  = Parallel (sn11 **** sn21) (sn12 **** sn22)-+    rb = rb1 *-* rb2+Parallel sn11 sn12 **** Parallel sn21 sn22 =+  Parallel (sn11 **** sn21) (sn12 **** sn22) Precompose clsf sn1 **** sn2 = Precompose (first clsf) $ sn1 **** sn2 sn1 **** Precompose clsf sn2 = Precompose (second clsf) $ sn1 **** sn2 Postcompose sn1 clsf **** sn2 = Postcompose (sn1 **** sn2) (first clsf) sn1 **** Postcompose sn2 clsf = Postcompose (sn1 **** sn2) (second clsf)- Feedback buf sn1 **** sn2 = Feedback buf $ (\((a, c), c1) -> ((a, c1), c)) ^>>> (sn1 **** sn2) >>>^ (\((b, d1), d) -> ((b, d), d1)) sn1 **** Feedback buf sn2 = Feedback buf $ (\((a, c), c1) -> (a, (c, c1))) ^>>> (sn1 **** sn2) >>>^ (\(b, (d, d1)) -> ((b, d), d1))- FirstResampling sn1 buf **** sn2 = (\((a1, c1), c) -> ((a1, c), c1)) ^>>> FirstResampling (sn1 **** sn2) buf >>>^ (\((b1, d), d1) -> ((b1, d1), d)) sn1 **** FirstResampling sn2 buf = (\(a, (a1, c1)) -> ((a, a1), c1)) ^>>> FirstResampling (sn1 **** sn2) buf >>>^ (\((b, b1), d1) -> (b, (b1, d1)))- -- Note that the patterns above are the only ones that can occur. -- This is ensured by the clock constraints in the SF constructors. Synchronous _ **** Parallel _ _ = error "Impossible pattern: Synchronous _ **** Parallel _ _"
src/FRP/Rhine/Schedule.hs view
@@ -1,3 +1,12 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+ {- | 'Schedule's are the compatibility mechanism between two different clocks. A schedule' implements the the universal clocks such that those two given clocks@@ -9,16 +18,6 @@  Specific implementations of schedules are found in submodules. -}--{-# LANGUAGE Arrows #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies #-}- module FRP.Rhine.Schedule where  -- transformers@@ -33,250 +32,266 @@  -- * The schedule type --- | A schedule implements a combination of two clocks.---   It outputs a time stamp and an 'Either' value,---   which specifies which of the two subclocks has ticked.-data Schedule m cl1 cl2-  = (Time cl1 ~ Time cl2)-  => Schedule-    { initSchedule-        :: cl1 -> cl2-        -> RunningClockInit m (Time cl1) (Either (Tag cl1) (Tag cl2))-    }+{- | A schedule implements a combination of two clocks.+   It outputs a time stamp and an 'Either' value,+   which specifies which of the two subclocks has ticked.+-}+data Schedule m cl1 cl2 = (Time cl1 ~ Time cl2) =>+  Schedule+  { initSchedule ::+      cl1 ->+      cl2 ->+      RunningClockInit m (Time cl1) (Either (Tag cl1) (Tag cl2))+  }+ -- The type constraint in the constructor is actually useful when pattern matching on 'Schedule', -- which is interesting since a constraint like 'Monad m' is useful. -- When reformulating as a GADT, it might get used, -- but that would mean that we can't use record syntax. - -- * Utilities to create new schedules from existing ones  -- | Lift a schedule along a monad morphism.-hoistSchedule-  :: (Monad m1, Monad m2)-  => (forall a . m1 a -> m2 a)-  -> Schedule m1 cl1 cl2-  -> Schedule m2 cl1 cl2+hoistSchedule ::+  (Monad m1, Monad m2) =>+  (forall a. m1 a -> m2 a) ->+  Schedule m1 cl1 cl2 ->+  Schedule m2 cl1 cl2 hoistSchedule hoist Schedule {..} = Schedule initSchedule'   where-    initSchedule' cl1 cl2 = hoist-      $ first (hoistMSF hoist) <$> initSchedule cl1 cl2-    hoistMSF = morphS+    initSchedule' cl1 cl2 =+      hoist $+        first (hoistMSF hoist) <$> initSchedule cl1 cl2     -- TODO This should be a dunai issue+    hoistMSF = morphS  -- | Swaps the clocks for a given schedule.-flipSchedule-  :: Monad m-  => Schedule m cl1 cl2-  -> Schedule m cl2 cl1+flipSchedule ::+  Monad m =>+  Schedule m cl1 cl2 ->+  Schedule m cl2 cl1 flipSchedule Schedule {..} = Schedule initSchedule_   where     initSchedule_ cl2 cl1 = first (arr (second swapEither) <<<) <$> initSchedule cl1 cl2  -- TODO I originally wanted to rescale a schedule and its clocks at the same time. -- That's rescaleSequentialClock.--- | If a schedule works for two clocks, a rescaling of the clocks---   also applies to the schedule.-rescaledSchedule-  :: Monad m-  => Schedule m cl1 cl2-  -> Schedule m (RescaledClock cl1 time) (RescaledClock cl2 time)++{- | If a schedule works for two clocks, a rescaling of the clocks+   also applies to the schedule.+-}+rescaledSchedule ::+  Monad m =>+  Schedule m cl1 cl2 ->+  Schedule m (RescaledClock cl1 time) (RescaledClock cl2 time) rescaledSchedule schedule = Schedule initSchedule'   where     initSchedule' cl1 cl2 = initSchedule (rescaledScheduleS schedule) (rescaledClockToS cl1) (rescaledClockToS cl2)  -- | As 'rescaledSchedule', with a stateful rescaling-rescaledScheduleS-  :: Monad m-  => Schedule m cl1 cl2-  -> Schedule m (RescaledClockS m cl1 time tag1) (RescaledClockS m cl2 time tag2)+rescaledScheduleS ::+  Monad m =>+  Schedule m cl1 cl2 ->+  Schedule m (RescaledClockS m cl1 time tag1) (RescaledClockS m cl2 time tag2) rescaledScheduleS Schedule {..} = Schedule initSchedule'   where     initSchedule' (RescaledClockS cl1 rescaleS1) (RescaledClockS cl2 rescaleS2) = do-      (runningSchedule, initTime ) <- initSchedule cl1 cl2-      (rescaling1     , initTime') <- rescaleS1 initTime-      (rescaling2     , _        ) <- rescaleS2 initTime-      let runningSchedule'-            = runningSchedule >>> proc (time, tag12) -> case tag12 of-                Left  tag1 -> do-                  (time', tag1') <- rescaling1 -< (time, tag1)-                  returnA -< (time', Left  tag1')-                Right tag2 -> do-                  (time', tag2') <- rescaling2 -< (time, tag2)-                  returnA -< (time', Right tag2')+      (runningSchedule, initTime) <- initSchedule cl1 cl2+      (rescaling1, initTime') <- rescaleS1 initTime+      (rescaling2, _) <- rescaleS2 initTime+      let runningSchedule' =+            runningSchedule >>> proc (time, tag12) -> case tag12 of+              Left tag1 -> do+                (time', tag1') <- rescaling1 -< (time, tag1)+                returnA -< (time', Left tag1')+              Right tag2 -> do+                (time', tag2') <- rescaling2 -< (time, tag2)+                returnA -< (time', Right tag2')       return (runningSchedule', initTime') -- -- TODO What's the most general way we can lift a schedule this way?--- | Lifts a schedule into the 'ReaderT' transformer,---   supplying the same environment to its scheduled clocks.-readerSchedule-  :: ( Monad m-     , Clock (ReaderT r m) cl1, Clock (ReaderT r m) cl2-     , Time cl1 ~ Time cl2-     )-  => Schedule m-       (HoistClock (ReaderT r m) m cl1) (HoistClock (ReaderT r m) m cl2)-  -> Schedule (ReaderT r m) cl1 cl2-readerSchedule Schedule {..}-  = Schedule $ \cl1 cl2 -> ReaderT $ \r -> first liftTransS-  <$> initSchedule++{- | Lifts a schedule into the 'ReaderT' transformer,+   supplying the same environment to its scheduled clocks.+-}+readerSchedule ::+  ( Monad m+  , Clock (ReaderT r m) cl1+  , Clock (ReaderT r m) cl2+  , Time cl1 ~ Time cl2+  ) =>+  Schedule+    m+    (HoistClock (ReaderT r m) m cl1)+    (HoistClock (ReaderT r m) m cl2) ->+  Schedule (ReaderT r m) cl1 cl2+readerSchedule Schedule {..} =+  Schedule $ \cl1 cl2 -> ReaderT $ \r ->+    first liftTransS+      <$> initSchedule         (HoistClock cl1 $ flip runReaderT r)         (HoistClock cl2 $ flip runReaderT r) - -- * Composite clocks  -- ** Sequentially combined clocks --- | Two clocks can be combined with a schedule as a clock---   for an asynchronous sequential composition of signal networks.-data SequentialClock m cl1 cl2-  = Time cl1 ~ Time cl2-  => SequentialClock-    { sequentialCl1      :: cl1-    , sequentialCl2      :: cl2-    , sequentialSchedule :: Schedule m cl1 cl2-    }+{- | Two clocks can be combined with a schedule as a clock+   for an asynchronous sequential composition of signal networks.+-}+data SequentialClock m cl1 cl2 = Time cl1 ~ Time cl2 =>+  SequentialClock+  { sequentialCl1 :: cl1+  , sequentialCl2 :: cl2+  , sequentialSchedule :: Schedule m cl1 cl2+  }  -- | Abbrevation synonym. type SeqClock m cl1 cl2 = SequentialClock m cl1 cl2 -instance (Monad m, Clock m cl1, Clock m cl2)-      => Clock m (SequentialClock m cl1 cl2) where+instance+  (Monad m, Clock m cl1, Clock m cl2) =>+  Clock m (SequentialClock m cl1 cl2)+  where   type Time (SequentialClock m cl1 cl2) = Time cl1-  type Tag  (SequentialClock m cl1 cl2) = Either (Tag cl1) (Tag cl2)-  initClock SequentialClock {..}-    = initSchedule sequentialSchedule sequentialCl1 sequentialCl2+  type Tag (SequentialClock m cl1 cl2) = Either (Tag cl1) (Tag cl2)+  initClock SequentialClock {..} =+    initSchedule sequentialSchedule sequentialCl1 sequentialCl2 --- | @cl1@ is a subclock of @SequentialClock m cl1 cl2@,---   therefore it is always possible to schedule these two clocks deterministically.---   The left subclock of the combined clock always ticks instantly after @cl1@.+{- | @cl1@ is a subclock of @SequentialClock m cl1 cl2@,+   therefore it is always possible to schedule these two clocks deterministically.+   The left subclock of the combined clock always ticks instantly after @cl1@.+-} schedSeq1 :: (Monad m, Semigroup cl1) => Schedule m cl1 (SequentialClock m cl1 cl2)-schedSeq1 = Schedule $ \cl1 SequentialClock { sequentialSchedule = Schedule {..}, .. } -> do+schedSeq1 = Schedule $ \cl1 SequentialClock {sequentialSchedule = Schedule {..}, ..} -> do   (runningClock, initTime) <- initSchedule (cl1 <> sequentialCl1) sequentialCl2   return (duplicateSubtick runningClock, initTime) --- | As 'schedSeq1', but for the right subclock.---   The right subclock of the combined clock always ticks instantly before @cl2@.+{- | As 'schedSeq1', but for the right subclock.+   The right subclock of the combined clock always ticks instantly before @cl2@.+-} schedSeq2 :: (Monad m, Semigroup cl2, Time cl1 ~ Time cl2) => Schedule m (SequentialClock m cl1 cl2) cl2-schedSeq2 = Schedule $ \SequentialClock { sequentialSchedule = Schedule {..}, .. } cl2 -> do+schedSeq2 = Schedule $ \SequentialClock {sequentialSchedule = Schedule {..}, ..} cl2 -> do   (runningClock, initTime) <- initSchedule sequentialCl1 (sequentialCl2 <> cl2)   return (duplicateSubtick (runningClock >>> second (arr swapEither)) >>> second (arr remap), initTime)-    where-      remap (Left tag2)          = Left $ Right tag2-      remap (Right (Left tag2))  = Right tag2-      remap (Right (Right tag1)) = Left $ Left tag1+  where+    remap (Left tag2) = Left $ Right tag2+    remap (Right (Left tag2)) = Right tag2+    remap (Right (Right tag1)) = Left $ Left tag1+ -- TODO Why did I need the constraint on the time domains here, but not in schedSeq1? --      Same for schedPar2 - -- ** Parallelly combined clocks ---- | Two clocks can be combined with a schedule as a clock---   for an asynchronous parallel composition of signal networks.-data ParallelClock m cl1 cl2-  = Time cl1 ~ Time cl2-  => ParallelClock-    { parallelCl1      :: cl1-    , parallelCl2      :: cl2-    , parallelSchedule :: Schedule m cl1 cl2-    }+{- | Two clocks can be combined with a schedule as a clock+   for an asynchronous parallel composition of signal networks.+-}+data ParallelClock m cl1 cl2 = Time cl1 ~ Time cl2 =>+  ParallelClock+  { parallelCl1 :: cl1+  , parallelCl2 :: cl2+  , parallelSchedule :: Schedule m cl1 cl2+  }  -- | Abbrevation synonym. type ParClock m cl1 cl2 = ParallelClock m cl1 cl2 -instance (Monad m, Clock m cl1, Clock m cl2)-      => Clock m (ParallelClock m cl1 cl2) where+instance+  (Monad m, Clock m cl1, Clock m cl2) =>+  Clock m (ParallelClock m cl1 cl2)+  where   type Time (ParallelClock m cl1 cl2) = Time cl1-  type Tag  (ParallelClock m cl1 cl2) = Either (Tag cl1) (Tag cl2)-  initClock ParallelClock {..}-    = initSchedule parallelSchedule parallelCl1 parallelCl2-+  type Tag (ParallelClock m cl1 cl2) = Either (Tag cl1) (Tag cl2)+  initClock ParallelClock {..} =+    initSchedule parallelSchedule parallelCl1 parallelCl2 --- | Like 'schedSeq1', but for parallel clocks.---   The left subclock of the combined clock always ticks instantly after @cl1@.+{- | Like 'schedSeq1', but for parallel clocks.+   The left subclock of the combined clock always ticks instantly after @cl1@.+-} schedPar1 :: (Monad m, Semigroup cl1) => Schedule m cl1 (ParallelClock m cl1 cl2)-schedPar1 = Schedule $ \cl1 ParallelClock { parallelSchedule = Schedule {..}, .. } -> do+schedPar1 = Schedule $ \cl1 ParallelClock {parallelSchedule = Schedule {..}, ..} -> do   (runningClock, initTime) <- initSchedule (cl1 <> parallelCl1) parallelCl2   return (duplicateSubtick runningClock, initTime) --- | Like 'schedPar1',---   but the left subclock of the combined clock always ticks instantly /before/ @cl1@.+{- | Like 'schedPar1',+   but the left subclock of the combined clock always ticks instantly /before/ @cl1@.+-} schedPar1' :: (Monad m, Semigroup cl1) => Schedule m cl1 (ParallelClock m cl1 cl2)-schedPar1' = Schedule $ \cl1 ParallelClock { parallelSchedule = Schedule {..}, .. } -> do+schedPar1' = Schedule $ \cl1 ParallelClock {parallelSchedule = Schedule {..}, ..} -> do   (runningClock, initTime) <- initSchedule (parallelCl1 <> cl1) parallelCl2   return (duplicateSubtick runningClock >>> arr (second remap), initTime)-    where-      remap (Left tag1)         = Right $ Left tag1-      remap (Right (Left tag1)) = Left tag1-      remap tag                 = tag+  where+    remap (Left tag1) = Right $ Left tag1+    remap (Right (Left tag1)) = Left tag1+    remap tag = tag --- | Like 'schedPar1', but for the right subclock.---   The right subclock of the combined clock always ticks instantly before @cl2@.+{- | Like 'schedPar1', but for the right subclock.+   The right subclock of the combined clock always ticks instantly before @cl2@.+-} schedPar2 :: (Monad m, Semigroup cl2, Time cl1 ~ Time cl2) => Schedule m (ParallelClock m cl1 cl2) cl2-schedPar2 = Schedule $ \ParallelClock { parallelSchedule = Schedule {..}, .. } cl2 -> do+schedPar2 = Schedule $ \ParallelClock {parallelSchedule = Schedule {..}, ..} cl2 -> do   (runningClock, initTime) <- initSchedule parallelCl1 (parallelCl2 <> cl2)   return (duplicateSubtick (runningClock >>> second (arr swapEither)) >>> second (arr remap), initTime)-    where-      remap (Left tag2)          = Left $ Right tag2-      remap (Right (Left tag2))  = Right tag2-      remap (Right (Right tag1)) = Left $ Left tag1+  where+    remap (Left tag2) = Left $ Right tag2+    remap (Right (Left tag2)) = Right tag2+    remap (Right (Right tag1)) = Left $ Left tag1 --- | Like 'schedPar1',---   but the right subclock of the combined clock always ticks instantly /after/ @cl2@.+{- | Like 'schedPar1',+   but the right subclock of the combined clock always ticks instantly /after/ @cl2@.+-} schedPar2' :: (Monad m, Semigroup cl2, Time cl1 ~ Time cl2) => Schedule m (ParallelClock m cl1 cl2) cl2-schedPar2' = Schedule $ \ParallelClock { parallelSchedule = Schedule {..}, .. } cl2 -> do+schedPar2' = Schedule $ \ParallelClock {parallelSchedule = Schedule {..}, ..} cl2 -> do   (runningClock, initTime) <- initSchedule parallelCl1 (parallelCl2 <> cl2)   return (duplicateSubtick (runningClock >>> second (arr swapEither)) >>> second (arr remap), initTime)-    where-      remap (Left tag2)          = Right tag2-      remap (Right (Left tag2))  = Left $ Right tag2-      remap (Right (Right tag1)) = Left $ Left tag1-+  where+    remap (Left tag2) = Right tag2+    remap (Right (Left tag2)) = Left $ Right tag2+    remap (Right (Right tag1)) = Left $ Left tag1  -- * Navigating the clock tree  -- | The clock that represents the rate at which data enters the system. type family In cl where   In (SequentialClock m cl1 cl2) = In cl1-  In (ParallelClock   m cl1 cl2) = ParallelClock m (In cl1) (In cl2)-  In cl                          = cl+  In (ParallelClock m cl1 cl2) = ParallelClock m (In cl1) (In cl2)+  In cl = cl  -- | The clock that represents the rate at which data leaves the system. type family Out cl where   Out (SequentialClock m cl1 cl2) = Out cl2-  Out (ParallelClock   m cl1 cl2) = ParallelClock m (Out cl1) (Out cl2)-  Out cl                          = cl-+  Out (ParallelClock m cl1 cl2) = ParallelClock m (Out cl1) (Out cl2)+  Out cl = cl --- | A tree representing possible last times to which---   the constituents of a clock may have ticked.+{- | A tree representing possible last times to which+   the constituents of a clock may have ticked.+-} data LastTime cl where-  SequentialLastTime-    :: LastTime cl1 -> LastTime cl2-    -> LastTime (SequentialClock m cl1 cl2)-  ParallelLastTime-    :: LastTime cl1 -> LastTime cl2-    -> LastTime (ParallelClock   m cl1 cl2)+  SequentialLastTime ::+    LastTime cl1 ->+    LastTime cl2 ->+    LastTime (SequentialClock m cl1 cl2)+  ParallelLastTime ::+    LastTime cl1 ->+    LastTime cl2 ->+    LastTime (ParallelClock m cl1 cl2)   LeafLastTime :: Time cl -> LastTime cl - -- | An inclusion of a clock into a tree of parallel compositions of clocks. data ParClockInclusion clS cl where-  ParClockInL-    :: ParClockInclusion (ParallelClock m clL clR) cl-    -> ParClockInclusion                  clL      cl-  ParClockInR-    :: ParClockInclusion (ParallelClock m clL clR) cl-    -> ParClockInclusion                      clR  cl+  ParClockInL ::+    ParClockInclusion (ParallelClock m clL clR) cl ->+    ParClockInclusion clL cl+  ParClockInR ::+    ParClockInclusion (ParallelClock m clL clR) cl ->+    ParClockInclusion clR cl   ParClockRefl :: ParClockInclusion cl cl --- | Generates a tag for the composite clock from a tag of a leaf clock,---   given a parallel clock inclusion.+{- | Generates a tag for the composite clock from a tag of a leaf clock,+   given a parallel clock inclusion.+-} parClockTagInclusion :: ParClockInclusion clS cl -> Tag clS -> Tag cl-parClockTagInclusion (ParClockInL parClockInL) tag = parClockTagInclusion parClockInL $ Left  tag+parClockTagInclusion (ParClockInL parClockInL) tag = parClockTagInclusion parClockInL $ Left tag parClockTagInclusion (ParClockInR parClockInR) tag = parClockTagInclusion parClockInR $ Right tag-parClockTagInclusion ParClockRefl              tag = tag+parClockTagInclusion ParClockRefl tag = tag
src/FRP/Rhine/Schedule/Concurrently.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+ {- | Many clocks tick at nondeterministic times (such as event sources),@@ -6,10 +10,6 @@ Using concurrency, they can still be scheduled with all clocks in 'IO', by running the clocks in separate threads. -}--{-# LANGUAGE Arrows #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-} module FRP.Rhine.Schedule.Concurrently where  -- base@@ -29,53 +29,56 @@ import FRP.Rhine.Clock import FRP.Rhine.Schedule ---- | Runs two clocks in separate GHC threads---   and collects the results in the foreground thread.---   Caution: The data processing will still happen in the same thread---   (since data processing and scheduling are separated concerns).-concurrently-  :: ( Clock IO cl1, Clock IO cl2-     , Time cl1 ~ Time cl2-     )-  => Schedule IO cl1 cl2+{- | Runs two clocks in separate GHC threads+   and collects the results in the foreground thread.+   Caution: The data processing will still happen in the same thread+   (since data processing and scheduling are separated concerns).+-}+concurrently ::+  ( Clock IO cl1+  , Clock IO cl2+  , Time cl1 ~ Time cl2+  ) =>+  Schedule IO cl1 cl2 concurrently = Schedule $ \cl1 cl2 -> do   iMVar <- newEmptyMVar-  mvar  <- newEmptyMVar-  _ <- launchSubthread cl1 Left  iMVar mvar+  mvar <- newEmptyMVar+  _ <- launchSubthread cl1 Left iMVar mvar   _ <- launchSubthread cl2 Right iMVar mvar   initTime <- takeMVar iMVar -- The first clock to be initialised sets the first time stamp-  _        <- takeMVar iMVar -- Initialise the second clock+  _ <- takeMVar iMVar -- Initialise the second clock   return (constM $ takeMVar mvar, initTime)   where     launchSubthread cl leftright iMVar mvar = forkIO $ do       (runningClock, initTime) <- initClock cl       putMVar iMVar initTime       reactimate $ runningClock >>> second (arr leftright) >>> arrM (putMVar mvar)+ -- TODO These threads can't be killed from outside easily since we've lost their ids -- => make a MaybeT or ExceptT variant  -- TODO Test whether signal networks also share the writer and except effects correctly with these schedules --- | As 'concurrently', but in the @WriterT w IO@ monad.---   Both background threads share a joint variable with the foreground---   to which the writer effect writes.-concurrentlyWriter-  :: ( Monoid w-     , Clock (WriterT w IO) cl1-     , Clock (WriterT w IO) cl2-     , Time cl1 ~ Time cl2-     )-  => Schedule (WriterT w IO) cl1 cl2+{- | As 'concurrently', but in the @WriterT w IO@ monad.+   Both background threads share a joint variable with the foreground+   to which the writer effect writes.+-}+concurrentlyWriter ::+  ( Monoid w+  , Clock (WriterT w IO) cl1+  , Clock (WriterT w IO) cl2+  , Time cl1 ~ Time cl2+  ) =>+  Schedule (WriterT w IO) cl1 cl2 concurrentlyWriter = Schedule $ \cl1 cl2 -> do   iMVar <- lift newEmptyMVar-  mvar  <- lift newEmptyMVar-  _ <- launchSubthread cl1 Left  iMVar mvar+  mvar <- lift newEmptyMVar+  _ <- launchSubthread cl1 Left iMVar mvar   _ <- launchSubthread cl2 Right iMVar mvar   -- The first clock to be initialised sets the first time stamp   (initTime, w1) <- lift $ takeMVar iMVar-   -- Initialise the second clock-  (_       , w2) <- lift $ takeMVar iMVar+  -- Initialise the second clock+  (_, w2) <- lift $ takeMVar iMVar   tell w1   tell w2   return (constM (WriterT $ takeMVar mvar), initTime)@@ -83,35 +86,37 @@     launchSubthread cl leftright iMVar mvar = lift $ forkIO $ do       ((runningClock, initTime), w) <- runWriterT $ initClock cl       putMVar iMVar (initTime, w)-      reactimate $ runWriterS runningClock >>> proc (w', (time, tag_)) ->-        arrM (putMVar mvar) -< ((time, leftright tag_), w')+      reactimate $+        runWriterS runningClock >>> proc (w', (time, tag_)) ->+          arrM (putMVar mvar) -< ((time, leftright tag_), w') --- | Schedule in the @ExceptT e IO@ monad.---   Whenever one clock encounters an exception in 'ExceptT',---   this exception is thrown in the other clock's 'ExceptT' layer as well,---   and in the schedule's (i.e. in the main clock's) thread.-concurrentlyExcept-  :: ( Clock (ExceptT e IO) cl1-     , Clock (ExceptT e IO) cl2-     , Time cl1 ~ Time cl2-     )-  => Schedule (ExceptT e IO) cl1 cl2+{- | Schedule in the @ExceptT e IO@ monad.+   Whenever one clock encounters an exception in 'ExceptT',+   this exception is thrown in the other clock's 'ExceptT' layer as well,+   and in the schedule's (i.e. in the main clock's) thread.+-}+concurrentlyExcept ::+  ( Clock (ExceptT e IO) cl1+  , Clock (ExceptT e IO) cl2+  , Time cl1 ~ Time cl2+  ) =>+  Schedule (ExceptT e IO) cl1 cl2 concurrentlyExcept = Schedule $ \cl1 cl2 -> do   (iMVar, mvar, errorref) <- lift $ do     iMVar <- newEmptyMVar -- The initialisation time is transferred over this variable. It's written to twice.-    mvar  <- newEmptyMVar -- The ticks and exceptions are transferred over this variable. It receives two 'Left' values in total.+    mvar <- newEmptyMVar -- The ticks and exceptions are transferred over this variable. It receives two 'Left' values in total.     errorref <- newIORef Nothing -- Used to broadcast the exception to both clocks-    _ <- launchSubThread cl1 Left  iMVar mvar errorref+    _ <- launchSubThread cl1 Left iMVar mvar errorref     _ <- launchSubThread cl2 Right iMVar mvar errorref     return (iMVar, mvar, errorref)   catchAndDrain mvar $ do     initTime <- ExceptT $ takeMVar iMVar -- The first clock to be initialised sets the first time stamp-    _        <- ExceptT $ takeMVar iMVar -- Initialise the second clock+    _ <- ExceptT $ takeMVar iMVar -- Initialise the second clock     let runningSchedule = constM $ do           eTick <- lift $ takeMVar mvar           case eTick of             Right tick -> return tick-            Left e     -> do+            Left e -> do               lift $ writeIORef errorref $ Just e -- Broadcast the exception to both clocks               throwE e     return (runningSchedule, initTime)@@ -121,30 +126,34 @@       case initialised of         Right (runningClock, initTime) -> do           putMVar iMVar $ Right initTime-          Left e <- runExceptT $ reactimate $ runningClock >>> proc (td, tag2) -> do-            arrM (lift . putMVar mvar)               -< Right (td, leftright tag2)-            me <- constM (lift $ readIORef errorref) -< ()-            _  <- throwMaybe                         -< me-            returnA -< ()+          Left e <-+            runExceptT $+              reactimate $+                runningClock >>> proc (td, tag2) -> do+                  arrM (lift . putMVar mvar) -< Right (td, leftright tag2)+                  me <- constM (lift $ readIORef errorref) -< ()+                  _ <- throwMaybe -< me+                  returnA -< ()           putMVar mvar $ Left e -- Either throw own exception or acknowledge the exception from the other clock         Left e -> void $ putMVar iMVar $ Left e     catchAndDrain mvar initScheduleAction = catchE initScheduleAction $ \e -> do-      _ <- reactimate $ (constM $ ExceptT $ takeMVar mvar) >>> arr (const ()) -- Drain the mvar until the other clock acknowledges the exception+      _ <- reactimate $ constM (ExceptT $ takeMVar mvar) >>> arr (const ()) -- Drain the mvar until the other clock acknowledges the exception       throwE e  -- | As 'concurrentlyExcept', with a single possible exception value.-concurrentlyMaybe-  :: ( Clock (MaybeT IO) cl1-     , Clock (MaybeT IO) cl2-     , Time cl1 ~ Time cl2-     )-  => Schedule (MaybeT IO) cl1 cl2-concurrentlyMaybe = Schedule $ \cl1 cl2 -> initSchedule-  (hoistSchedule exceptTIOToMaybeTIO concurrentlyExcept)+concurrentlyMaybe ::+  ( Clock (MaybeT IO) cl1+  , Clock (MaybeT IO) cl2+  , Time cl1 ~ Time cl2+  ) =>+  Schedule (MaybeT IO) cl1 cl2+concurrentlyMaybe = Schedule $ \cl1 cl2 ->+  initSchedule+    (hoistSchedule exceptTIOToMaybeTIO concurrentlyExcept)     (HoistClock cl1 maybeTIOToExceptTIO)     (HoistClock cl2 maybeTIOToExceptTIO)-      where-        exceptTIOToMaybeTIO :: ExceptT () IO a -> MaybeT IO a-        exceptTIOToMaybeTIO = exceptToMaybeT-        maybeTIOToExceptTIO :: MaybeT IO a -> ExceptT () IO a-        maybeTIOToExceptTIO = maybeToExceptT ()+  where+    exceptTIOToMaybeTIO :: ExceptT () IO a -> MaybeT IO a+    exceptTIOToMaybeTIO = exceptToMaybeT+    maybeTIOToExceptTIO :: MaybeT IO a -> ExceptT () IO a+    maybeTIOToExceptTIO = maybeToExceptT ()
src/FRP/Rhine/Schedule/Trans.hs view
@@ -1,11 +1,11 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+ {- | Clocks implemented in the 'ScheduleT' monad transformer can always be scheduled (by construction). -}--{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies #-} module FRP.Rhine.Schedule.Trans where  -- dunai@@ -16,59 +16,62 @@ import FRP.Rhine.Clock import FRP.Rhine.Schedule - -- * Universal schedule for the 'ScheduleT' monad transformer --- | Two clocks in the 'ScheduleT' monad transformer---   can always be canonically scheduled.---   Indeed, this is the purpose for which 'ScheduleT' was defined.-schedule-  :: ( Monad m-     , Clock (ScheduleT (Diff (Time cl1)) m) cl1-     , Clock (ScheduleT (Diff (Time cl1)) m) cl2-     , Time cl1 ~ Time cl2-     , Ord (Diff (Time cl1))-     , Num (Diff (Time cl1))-     )-  => Schedule (ScheduleT (Diff (Time cl1)) m) cl1 cl2+{- | Two clocks in the 'ScheduleT' monad transformer+   can always be canonically scheduled.+   Indeed, this is the purpose for which 'ScheduleT' was defined.+-}+schedule ::+  ( Monad m+  , Clock (ScheduleT (Diff (Time cl1)) m) cl1+  , Clock (ScheduleT (Diff (Time cl1)) m) cl2+  , Time cl1 ~ Time cl2+  , Ord (Diff (Time cl1))+  , Num (Diff (Time cl1))+  ) =>+  Schedule (ScheduleT (Diff (Time cl1)) m) cl1 cl2 schedule = Schedule {..}   where     initSchedule cl1 cl2 = do       (runningClock1, initTime) <- initClock cl1-      (runningClock2, _)        <- initClock cl2+      (runningClock2, _) <- initClock cl2       return         ( runningSchedule cl1 cl2 runningClock1 runningClock2         , initTime         )      -- Combines the two individual running clocks to one running clock.-    runningSchedule-      :: ( Monad m-         , Clock (ScheduleT (Diff (Time cl1)) m) cl1-         , Clock (ScheduleT (Diff (Time cl2)) m) cl2-         , Time cl1 ~ Time cl2-         , Ord (Diff (Time cl1))-         , Num (Diff (Time cl1))-         )-      => cl1 -> cl2-      -> MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl1, Tag cl1)-      -> MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl2, Tag cl2)-      -> MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl1, Either (Tag cl1) (Tag cl2))+    runningSchedule ::+      ( Monad m+      , Clock (ScheduleT (Diff (Time cl1)) m) cl1+      , Clock (ScheduleT (Diff (Time cl2)) m) cl2+      , Time cl1 ~ Time cl2+      , Ord (Diff (Time cl1))+      , Num (Diff (Time cl1))+      ) =>+      cl1 ->+      cl2 ->+      MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl1, Tag cl1) ->+      MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl2, Tag cl2) ->+      MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl1, Either (Tag cl1) (Tag cl2))     runningSchedule cl1 cl2 rc1 rc2 = MSF $ \_ -> do       -- Race both clocks against each other       raceResult <- race (unMSF rc1 ()) (unMSF rc2 ())       case raceResult of         -- The first clock ticks first...-        Left  (((time, tag1), rc1'), cont2) -> return-          -- so we can emit its time stamp...-          ( (time, Left tag1)-          -- and continue.-          , runningSchedule cl1 cl2 rc1' (MSF $ const cont2)-          )+        Left (((time, tag1), rc1'), cont2) ->+          return+            -- so we can emit its time stamp...+            ( (time, Left tag1)+            , -- and continue.+              runningSchedule cl1 cl2 rc1' (MSF $ const cont2)+            )         -- The second clock ticks first...-        Right (cont1, ((time, tag2), rc2')) -> return-          -- so we can emit its time stamp...-          ( (time, Right tag2)-          -- and continue.-          , runningSchedule cl1 cl2 (MSF $ const cont1) rc2'-          )+        Right (cont1, ((time, tag2), rc2')) ->+          return+            -- so we can emit its time stamp...+            ( (time, Right tag2)+            , -- and continue.+              runningSchedule cl1 cl2 (MSF $ const cont1) rc2'+            )
src/FRP/Rhine/Schedule/Util.hs view
@@ -1,20 +1,20 @@ -- | Utility to define certain deterministic schedules.- module FRP.Rhine.Schedule.Util where  -- dunai import Data.MonadicStreamFunction import Data.MonadicStreamFunction.Async --- | In a composite running clock,---   duplicate the tick of one subclock.+{- | In a composite running clock,+   duplicate the tick of one subclock.+-} duplicateSubtick :: Monad m => MSF m () (time, Either a b) -> MSF m () (time, Either a (Either a b)) duplicateSubtick runningClock = concatS $ runningClock >>> arr duplicateLeft   where-    duplicateLeft (time, Left a)  = [(time, Left a), (time, Right $ Left a)]+    duplicateLeft (time, Left a) = [(time, Left a), (time, Right $ Left a)]     duplicateLeft (time, Right b) = [(time, Right $ Right b)]  -- TODO Why is stuff like this not in base? Maybe send pull request... swapEither :: Either a b -> Either b a-swapEither (Left  a) = Right a-swapEither (Right b) = Left  b+swapEither (Left a) = Right a+swapEither (Right b) = Left b
src/FRP/Rhine/Type.hs view
@@ -1,25 +1,25 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+ {- | The type of a complete Rhine program: A signal network together with a matching clock value. -}--{-# LANGUAGE Arrows #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE FlexibleContexts #-} module FRP.Rhine.Type where  -- dunai import Data.MonadicStreamFunction  -- rhine-import FRP.Rhine.Reactimation.ClockErasure import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy-import FRP.Rhine.SN+import FRP.Rhine.Reactimation.ClockErasure import FRP.Rhine.ResamplingBuffer (ResamplingBuffer)-import FRP.Rhine.Schedule (Out, In)+import FRP.Rhine.SN+import FRP.Rhine.Schedule (In, Out)  {- | A 'Rhine' consists of a 'SN' together with a clock of matching type 'cl'.@@ -34,14 +34,13 @@ using 'eraseClock'. -} data Rhine m cl a b = Rhine-  { sn    :: SN m cl a b+  { sn :: SN m cl a b   , clock :: cl   }  instance GetClockProxy cl => ToClockProxy (Rhine m cl a b) where   type Cl (Rhine m cl a b) = cl - {- | Start the clock and the signal network, effectively hiding the clock type from the outside.@@ -49,10 +48,10 @@ Since the caller will not know when the clock @'In' cl@ ticks, the input 'a' has to be given at all times, even those when it doesn't tick. -}-eraseClock-  :: (Monad m, Clock m cl, GetClockProxy cl)-  => Rhine  m cl a        b-  -> m (MSF m    a (Maybe b))+eraseClock ::+  (Monad m, Clock m cl, GetClockProxy cl) =>+  Rhine m cl a b ->+  m (MSF m a (Maybe b)) eraseClock Rhine {..} = do   (runningClock, initTime) <- initClock clock   -- Run the main loop@@ -66,15 +65,17 @@ Since output and input will generally tick at different clocks, the data needs to be resampled. -}-feedbackRhine-  :: ( Clock m (In cl),  Clock m (Out cl)-     , Time (In cl) ~ Time cl-     , Time (Out cl) ~ Time cl-     )-  => ResamplingBuffer m (Out cl) (In cl) d c-  -> Rhine            m cl (a, c) (b, d)-  -> Rhine            m cl  a      b-feedbackRhine buf Rhine { .. } = Rhine-  { sn = Feedback buf sn-  , clock-  }+feedbackRhine ::+  ( Clock m (In cl)+  , Clock m (Out cl)+  , Time (In cl) ~ Time cl+  , Time (Out cl) ~ Time cl+  ) =>+  ResamplingBuffer m (Out cl) (In cl) d c ->+  Rhine m cl (a, c) (b, d) ->+  Rhine m cl a b+feedbackRhine buf Rhine {..} =+  Rhine+    { sn = Feedback buf sn+    , clock+    }