rhine 0.4.0.4 → 0.5.0.0

raw patch · 51 files changed

+2639/−1118 lines, 51 filesdep +deepseqdep +vector-sizeddep −rhinedep ~freedep ~transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq, vector-sized

Dependencies removed: rhine

Dependency ranges changed: free, transformers

API changes (from Hackage documentation)

Files

• ChangeLog.md +46/−0
• README.md +1/−1
• examples/Demonstration.hs +0/−52
• examples/HelloWorld.hs +0/−6
• rhine.cabal +30/−33
• src/Control/Monad/Schedule.hs +9/−0
• src/FRP/Rhine.hs +38/−10
• src/FRP/Rhine/ClSF.hs +18/−0
• src/FRP/Rhine/ClSF/Core.hs +123/−0
• src/FRP/Rhine/ClSF/Except.hs +134/−0
• src/FRP/Rhine/ClSF/Except/Util.hs +17/−0
• src/FRP/Rhine/ClSF/Reader.hs +49/−0
• src/FRP/Rhine/ClSF/Upsample.hs +55/−0
• src/FRP/Rhine/ClSF/Util.hs +383/−0
• src/FRP/Rhine/Clock.hs +160/−48
• src/FRP/Rhine/Clock/Count.hs +0/−16
• src/FRP/Rhine/Clock/FixedRate.hs +0/−21
• src/FRP/Rhine/Clock/FixedStep.hs +84/−0
• src/FRP/Rhine/Clock/Periodic.hs +88/−0
• src/FRP/Rhine/Clock/Realtime/Audio.hs +22/−13
• src/FRP/Rhine/Clock/Realtime/Busy.hs +7/−5
• src/FRP/Rhine/Clock/Realtime/Event.hs +196/−0
• src/FRP/Rhine/Clock/Realtime/Millisecond.hs +51/−31
• src/FRP/Rhine/Clock/Realtime/Stdin.hs +18/−13
• src/FRP/Rhine/Clock/Select.hs +46/−15
• src/FRP/Rhine/Clock/Step.hs +0/−53
• src/FRP/Rhine/Reactimation.hs +33/−27
• src/FRP/Rhine/Reactimation/Combinators.hs +187/−0
• src/FRP/Rhine/Reactimation/Tick.hs +79/−75
• src/FRP/Rhine/ResamplingBuffer.hs +22/−7
• src/FRP/Rhine/ResamplingBuffer/Collect.hs +6/−1
• src/FRP/Rhine/ResamplingBuffer/FIFO.hs +16/−3
• src/FRP/Rhine/ResamplingBuffer/Interpolation.hs +81/−9
• src/FRP/Rhine/ResamplingBuffer/KeepLast.hs +6/−0
• src/FRP/Rhine/ResamplingBuffer/LIFO.hs +47/−0
• src/FRP/Rhine/ResamplingBuffer/MSF.hs +11/−7
• src/FRP/Rhine/ResamplingBuffer/Timeless.hs +6/−1
• src/FRP/Rhine/ResamplingBuffer/Util.hs +31/−16
• src/FRP/Rhine/SF.hs +0/−55
• src/FRP/Rhine/SF/Combinators.hs +0/−141
• src/FRP/Rhine/SN.hs +63/−0
• src/FRP/Rhine/SN/Combinators.hs +85/−0
• src/FRP/Rhine/Schedule.hs +179/−37
• src/FRP/Rhine/Schedule/Concurrently.hs +130/−13
• src/FRP/Rhine/Schedule/Trans.hs +30/−24
• src/FRP/Rhine/Schedule/Util.hs +20/−0
• src/FRP/Rhine/SyncSF.hs +0/−240
• src/FRP/Rhine/SyncSF/Except.hs +0/−128
• src/FRP/Rhine/SyncSF/Except/Util.hs +0/−12
• src/FRP/Rhine/TimeDomain.hs +11/−5
• src/FRP/Rhine/Type.hs +21/−0

@@ -0,0 +1,46 @@+# Revision history for rhine++The version numbering follows the package `dunai`.+Since `rhine` reexports modules from `dunai`,+every major version in `dunai` triggers a major version in `rhine`.++## 0.5.0.0++* Deprecated GHC 7.*+* Big module reorganisation:+  * Renamed `SyncSF` to `ClSF` and many other renames+    (https://github.com/turion/rhine/issues/45)+  * `FRP.Rhine` by default exports all components+    (signal functions, clocks, schedules, resampling buffers)+* Refactored some fixed step clocks+* Added interpolation buffers++Note that this is the first release that is not in sync+with `dunai`'s version numbers.+`rhine-0.5` depends on `dunai-0.4`.++## 0.4.0.0 -- 2017.12.04++* Documentation typos fixed+* Added `ChangeLog.md`++## 0.3.0.0++* Version bump+* Documentation typos fixed (Thanks to Gabor Greif)++## 0.2.0.0++* Travis CI support+* Removed several utilities that are now in `dunai`+* Extended averaging functions++## 0.1.1.0++* Added `FRP.Rhine.Clock.Realtime.Stdin` (console keyboard event clock)+* Added `FRP.Rhine.Clock.Select` (event selection clock)+* Added `FRP.Rhine.ClSF.Except` (synchronous exception handling)++## 0.1.0.0++* Initial version

@@ -1,4 +1,4 @@-* README+# README --------  This is the main library.

@@ -1,52 +0,0 @@-{-# LANGUAGE DataKinds        #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes       #-}-{-# LANGUAGE TypeFamilies     #-}--import FRP.Rhine-import FRP.Rhine.Clock.Realtime.Millisecond-import FRP.Rhine.Schedule.Concurrently-import FRP.Rhine.ResamplingBuffer.Collect---- | Create a simple message containing the time stamp since program start,---   for each tick of the clock.---   Since 'createMessage' works for arbitrary clocks (and doesn't need further input data),---   it is a 'Behaviour'.---   @td@ is the 'TimeDomain' of any clock used to sample,---   and it needs to be constrained in order for time differences---   to have a 'Show' instance.-createMessage-  :: (Monad m, Show (Diff td))-  => String-  -> Behaviour m td String-createMessage str-  =   timeInfoOf sinceStart >-> arr show-  >-> arr (("Clock " ++ str ++ " has ticked at: ") ++)---- | Output a message /every second/ (= every 1000 milliseconds).---   Let us assume we want to assure that 'printEverySecond'---   is only called every second,---   then we constrain its type signature with the clock @Millisecond 1000@.-printEverySecond :: Show a => SyncSF IO (Millisecond 1000) a ()-printEverySecond = arrMSync print---- | Specialise 'createMessage' to a specific clock.-ms500 :: SyncSF IO (Millisecond 500) () String-ms500 = createMessage "500 MS"---ms1200 :: SyncSF IO (Millisecond 1200) () String-ms1200 = createMessage "1200 MS"---- | Create messages every 500 ms and every 1200 ms,---   collecting all of them in a list,---   which is output every second.-main :: IO ()-main = flow $-  ms500 @@ waitClock **@ concurrently @** ms1200 @@ waitClock-  >-- collect -@- concurrently -->-  printEverySecond @@ waitClock---- | Uncomment the following for a type error (the clocks don't match):---- typeError = ms500 >>> printEverySecond

@@ -1,6 +0,0 @@-{-# LANGUAGE DataKinds #-}-import FRP.Rhine-import FRP.Rhine.Clock.Realtime.Millisecond--main :: IO ()-main = flow $ arrMSync_ (putStrLn "Hello World!") @@ (waitClock :: Millisecond 100)

@@ -1,6 +1,6 @@ name:                rhine -version:             0.4.0.4+version:             0.5.0.0  synopsis: Functional Reactive Programming with type-level clocks @@ -18,7 +18,7 @@   several standard scheduling and resampling solutions are implemented.   Own schedules and resampling buffers can be implemented in a reusable fashion.   A (synchronous) program outputting "Hello World!" every tenth of a second looks like this:-  @flow $ arrMSync_ (putStrLn "Hello World!") @@ (waitClock :: Millisecond 100)@+  @flow $ constMCl (putStrLn "Hello World!") \@\@ (waitClock :: Millisecond 100)@   license:             BSD3@@ -33,9 +33,11 @@  build-type:          Simple +extra-source-files:  ChangeLog.md+ extra-doc-files:     README.md -cabal-version:       >=1.18+cabal-version:       1.18  source-repository head   type:     git@@ -44,7 +46,7 @@ source-repository this   type:     git   location: git@github.com:turion/rhine.git-  tag:      v0.4.0.4+  tag:      v0.5.0.0   library@@ -52,68 +54,63 @@     Control.Monad.Schedule     FRP.Rhine     FRP.Rhine.Clock-    FRP.Rhine.Clock.Count-    FRP.Rhine.Clock.FixedRate+    FRP.Rhine.Clock.Periodic     FRP.Rhine.Clock.Realtime.Audio     FRP.Rhine.Clock.Realtime.Busy+    FRP.Rhine.Clock.Realtime.Event     FRP.Rhine.Clock.Realtime.Millisecond     FRP.Rhine.Clock.Realtime.Stdin     FRP.Rhine.Clock.Select-    FRP.Rhine.Clock.Step+    FRP.Rhine.Clock.FixedStep+    FRP.Rhine.ClSF+    FRP.Rhine.ClSF.Core+    FRP.Rhine.ClSF.Except+    FRP.Rhine.ClSF.Reader+    FRP.Rhine.ClSF.Upsample+    FRP.Rhine.ClSF.Util     FRP.Rhine.Reactimation     FRP.Rhine.Reactimation.Tick+    FRP.Rhine.Reactimation.Combinators     FRP.Rhine.ResamplingBuffer     FRP.Rhine.ResamplingBuffer.Collect     FRP.Rhine.ResamplingBuffer.FIFO     FRP.Rhine.ResamplingBuffer.Interpolation     FRP.Rhine.ResamplingBuffer.KeepLast+    FRP.Rhine.ResamplingBuffer.LIFO     FRP.Rhine.ResamplingBuffer.MSF     FRP.Rhine.ResamplingBuffer.Timeless     FRP.Rhine.ResamplingBuffer.Util     FRP.Rhine.Schedule     FRP.Rhine.Schedule.Concurrently     FRP.Rhine.Schedule.Trans-    FRP.Rhine.SF-    FRP.Rhine.SF.Combinators-    FRP.Rhine.SyncSF-    FRP.Rhine.SyncSF.Except+    FRP.Rhine.SN+    FRP.Rhine.SN.Combinators     FRP.Rhine.TimeDomain+    FRP.Rhine.Type    other-modules:-    FRP.Rhine.SyncSF.Except.Util+    FRP.Rhine.ClSF.Except.Util+    FRP.Rhine.Schedule.Util    -- LANGUAGE extensions used by modules in this package.   -- other-extensions:    -- Other library packages from which modules are imported.-  build-depends:       base         >= 4.9   && < 4.12+  build-depends:       base         >= 4.9      && < 4.12                     ,  dunai        == 0.4.0.*-                    ,  transformers >= 0.4   && < 0.6+                    ,  transformers == 0.5.*                     ,  time         == 1.8.*-                    ,  free         == 5.1.*-                    ,  containers   >= 0.5   && < 0.6+                    ,  free         == 5.0.*+                    ,  containers   == 0.5.*+                    ,  vector-sized >= 0.6      && < 1.1+                    ,  deepseq      == 1.4.*    -- Directories containing source files.   hs-source-dirs:      src    ghc-options:         -Wall+                       -Wno-unticked-promoted-constructors+                       -Wno-type-defaults    -- Base language which the package is written in.-  default-language:    Haskell2010---executable HelloWorld-  hs-source-dirs:      examples-  main-is:             HelloWorld.hs-  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N-  build-depends:       base  >= 4.9 && < 4.12-                     , rhine-  default-language:    Haskell2010--executable Demonstration-  hs-source-dirs:      examples-  main-is:             Demonstration.hs-  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N-  build-depends:       base  >= 4.9 && < 4.12-                     , rhine   default-language:    Haskell2010

@@ -1,3 +1,12 @@+{- |+This module supplies a general purpose monad transformer+that adds a syntactical "delay", or "waiting" side effect.++This allows for universal and deterministic scheduling of clocks+that implement their waiting actions in 'ScheduleT'.+See 'FRP.Rhine.Schedule.Trans' for more details.+-}+ {-# LANGUAGE DeriveFunctor #-} module Control.Monad.Schedule where 

@@ -9,20 +9,48 @@ import FRP.Rhine.Clock.Realtime.Millisecond  main :: IO ()-main = flow $ arrMSync_ (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+import Data.MonadicStreamFunction         as X hiding ((>>>^), (^>>>))+import Data.VectorSpace                   as X+import Data.VectorSpace.Specific ()+import Data.VectorSpace.Tuples ()  -- rhine-import FRP.Rhine.Clock            as X-import FRP.Rhine.Reactimation     as X-import FRP.Rhine.ResamplingBuffer as X-import FRP.Rhine.Schedule         as X-import FRP.Rhine.SF               as X-import FRP.Rhine.SF.Combinators   as X-import FRP.Rhine.SyncSF           as X-import FRP.Rhine.TimeDomain       as X+import FRP.Rhine.Clock                    as X+import FRP.Rhine.ClSF                     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++-- 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.Millisecond 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.FIFO as X+import FRP.Rhine.ResamplingBuffer.LIFO as X+import FRP.Rhine.ResamplingBuffer.Collect as X+import FRP.Rhine.ResamplingBuffer.Timeless as X+import FRP.Rhine.ResamplingBuffer.KeepLast as X+import FRP.Rhine.ResamplingBuffer.Util as X++import FRP.Rhine.Schedule.Trans as X+import FRP.Rhine.Schedule.Concurrently as X+import FRP.Rhine.Schedule.Util as X

@@ -0,0 +1,18 @@+{- |+Clocked signal functions, i.e. monadic stream functions ('MSF's)+that are aware of time.+This module reexports core functionality+(such as time effects and 'Behaviour's),+exception handling, reader monad handling,+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+++-- rhine+import FRP.Rhine.ClSF.Core   as X+import FRP.Rhine.ClSF.Except as X+import FRP.Rhine.ClSF.Reader as X+import FRP.Rhine.ClSF.Util   as X

@@ -0,0 +1,123 @@+{- |+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++-- base+import Control.Arrow++-- transformers+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader (ReaderT, mapReaderT, withReaderT)++-- dunai+import Data.MonadicStreamFunction (MSF, arrM, arrM_, liftMSFPurer, liftMSFTrans)+import Data.MonadicStreamFunction as X hiding ((>>>^), (^>>>))++-- rhine+import FRP.Rhine.Clock      as X+++-- * 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@.+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 (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++-- | 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++-- * 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 hoist = liftMSFPurer $ 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+  = liftMSFPurer $ 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 = 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 = hoistClSFAndClock lift++-- | 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 = liftMSFTrans++-- | Utility to lift Kleisli arrows directly to 'ClSF's.+arrMCl :: Monad m => (a -> m b) -> ClSF m cl a b+arrMCl = timeless . arrM++-- | Version without input.+constMCl :: Monad m => m b -> ClSF m cl a b+constMCl = timeless . arrM_++{- | Call a 'ClSF' every time the input is 'Just a'.++Caution: This will not change the time differences since the last tick.+For example,+while @integrate 1@ is approximately the same as @timeInfoOf sinceInit@,+@mapMaybe $ integrate 1@ is very different from+@mapMaybe $ timeInfoOf sinceInit@.+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 behaviour = proc ma -> case ma of+  Nothing -> returnA                -< Nothing+  Just a  -> arr Just <<< behaviour -< a+-- TODO Consider integrating up the time deltas

@@ -0,0 +1,134 @@+{- | 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, Empty, exceptS, runMSFExcept, currentInput+  )+  where++-- base+import qualified Control.Category as Category++-- transformers+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except as X+import Control.Monad.Trans.Reader++-- dunai+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++-- * Throwing exceptions+++-- | Immediately throw the incoming exception.+throwS :: Monad m => ClSF (ExceptT e m) cl e a+throwS = arrMCl throwE++-- | Immediately throw the given exception.+throw :: Monad m => e -> MSF (ExceptT e m) a b+throw = arrM_ . throwE++-- | Do not throw an exception.+pass :: Monad m => MSF (ExceptT e m) a a+pass = Category.id++-- | Throw the given exception when the 'Bool' turns true.+throwOn :: Monad m => e -> ClSF (ExceptT e m) cl Bool ()+throwOn e = proc b -> throwOn' -< (b, e)++-- | 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 -< ()++-- | 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++-- | 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+    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++-- * Monad interface++{- | A synchronous exception-throwing signal function.+It is based on a @newtype@ from Dunai, 'MSFExcept',+to exhibit a monad interface /in the exception type/.+`return` then corresponds to throwing an exception,+and `(>>=)` is exception handling.+(For more information, see the documentation of 'MSFExcept'.)++* @m@:  The monad that the signal function may take side effects in+* @cl@: The clock on which the signal function ticks+* @a@:  The input type+* @b@:  The output type+* @e@:  The type of exceptions that can be thrown+-}+type ClSFExcept m cl a b e = MSFExcept (ReaderT (TimeInfo cl) m) a b e++{- | A clock polymorphic 'ClSFExcept',+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++-- | 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 = liftMSFPurer 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.+try :: Monad m => ClSF (ExceptT e m) cl a b -> ClSFExcept m cl a b e+try = MSFE.try . liftMSFPurer commuteReaderExcept++-- | 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++-- | A variant of 'once' without input.+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.+step :: Monad m => (a -> m (b, e)) -> ClSFExcept m cl a b e+step f = MSFE.step $ lift . f

@@ -0,0 +1,17 @@+{-|+Utilities for 'FRP.Rhine.ClSF.Except' that need not be exported.+-}++module FRP.Rhine.ClSF.Except.Util where++-- transformers+import Control.Monad.Trans.Except+import Control.Monad.Trans.Reader++-- | Commute a 'ReaderT' layer past an 'ExceptT' layer.+commuteExceptReader :: ExceptT e (ReaderT r m) a -> ReaderT r (ExceptT e m) a+commuteExceptReader a = ReaderT $ \r -> ExceptT $ runReaderT (runExceptT a) r++-- | Commute the effects of the 'ReaderT' and the 'ExceptT' monad.+commuteReaderExcept :: ReaderT r (ExceptT e m) a -> ExceptT e (ReaderT r m) a+commuteReaderExcept a = ExceptT $ ReaderT $ \r -> runExceptT $ runReaderT a r

@@ -0,0 +1,49 @@+{- |+Create and remove 'ReaderT' layers in 'ClSF's.+-}++{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+module FRP.Rhine.ClSF.Reader where++-- base+import Data.Tuple (swap)++-- transformers+import Control.Monad.Trans.Reader++-- dunai+import qualified Control.Monad.Trans.MSF.Reader as MSF++-- 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++-- | 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+  = liftMSFPurer 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 $ liftMSFPurer 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

@@ -0,0 +1,55 @@+-- | Utilities to run 'ClSF's at the speed of combined clocks+--   when they are defined only for a constituent clock.++{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}++module FRP.Rhine.ClSF.Upsample where++-- base+import Data.Semigroup++-- dunai+import Control.Monad.Trans.MSF.Reader+--import Data.MonadicStreamFunction++-- rhine+import FRP.Rhine.ClSF.Core+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.+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."+-- 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+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)+++-- | 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)

@@ -0,0 +1,383 @@+{- |+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 #-}++module FRP.Rhine.ClSF.Util where+++-- base+import Control.Arrow+import Control.Category (Category)+import qualified Control.Category (id)+import Data.Maybe (fromJust)+import Data.Monoid (Last (Last), getLast)++-- containers+import Data.Sequence++-- transformers+import Control.Monad.Trans.Reader (ask, asks)++-- dunai+import Control.Monad.Trans.MSF.Reader (readerS)+import Data.MonadicStreamFunction (arrM_, sumFrom, delay, feedback)+import Data.MonadicStreamFunction.Instances.VectorSpace ()+import Data.VectorSpace++-- rhine+import FRP.Rhine.ClSF.Core+import FRP.Rhine.ClSF.Except+++-- * Read time information++-- | Read the environment variable, i.e. the 'TimeInfo'.+timeInfo :: Monad m => ClSF m cl a (TimeInfo cl)+timeInfo = arrM_ ask++{- | Utility to apply functions to the current 'TimeInfo',+such as record selectors:+@+printAbsoluteTime :: ClSF IO cl () ()+printAbsoluteTime = timeInfoOf absolute >>> arrMCl print+@+-}+timeInfoOf :: Monad m => (TimeInfo cl -> b) -> ClSF m cl a b+timeInfoOf f = arrM_ $ asks f++-- | Continuously return the time difference since the last tick.+sinceLastS :: Monad m => ClSF m cl a (Diff (Time cl))+sinceLastS = timeInfoOf sinceLast++-- | Continuously return the time difference since clock initialisation.+sinceInitS :: Monad m => ClSF m cl a (Diff (Time cl))+sinceInitS = timeInfoOf sinceInit++-- | Continuously return the absolute time.+absoluteS :: Monad m => ClSF m cl a (Time cl)+absoluteS = timeInfoOf absolute++-- | Continuously return the tag of the current tick.+tagS :: Monad m => ClSF m cl a (Tag cl)+tagS = timeInfoOf tag++{- |+Calculate the time passed since this 'ClSF' was instantiated.+This is _not_ the same as 'sinceInitS',+which measures the time since clock initialisation.++For example, the following gives a sawtooth signal:++@+sawtooth = safely $ do+  try $ sinceStart >>> proc time -> do+    throwOn () -< time > 1+    returnA    -< time+  safe sawtooth+@++If you replace 'sinceStart' by 'sinceInitS',+it will usually hang after one second,+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+++-- * 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.:++> clsf1 >-> clsf2 @@ clA ||@ sched @|| clsf3 >-> clsf4 @@ clB++The type signature specialises e.g. to++> (>->) :: 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+(>->) = (>>>)++-- | Alias for 'Control.Category.<<<'.+infixl 6 <-<+(<-<) :: Category cat+      => cat   b c+      -> cat a b+      -> cat a   c+(<-<) = (<<<)++{- | Output a constant value.+Specialises e.g. to this type signature:++> arr_ :: Monad m => b -> ClSF m cl a b+-}+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+     , Groundfield v ~ Diff td)+  => v -> BehaviorF m td v v+integralFrom v0 = proc v -> do+  _sinceLast <- timeInfoOf sinceLast -< ()+  sumFrom v0                         -< _sinceLast *^ v++-- | Euler integration, with zero initial offset.+integral+  :: ( Monad m, VectorSpace v+     , Groundfield v ~ 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+     , Groundfield v ~ Diff td)+  => v -> BehaviorF m td v v+derivativeFrom v0 = proc v -> do+  vLast         <- delay v0 -< v+  TimeInfo {..} <- timeInfo -< ()+  returnA                   -< (v ^-^ vLast) ^/ sinceLast++-- | Numerical derivative with input initialised to zero.+derivative+  :: ( Monad m, VectorSpace v+     , Groundfield v ~ 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+     , Groundfield v ~ Diff td)+  => v -- ^ The initial position+  -> BehaviorF m td v v+threePointDerivativeFrom v0 = proc v -> do+  dv  <- derivativeFrom v0 -< v+  dv' <- delay zeroVector  -< dv+  returnA                  -< (dv ^+^ dv') ^/ 2++-- | Like 'threePointDerivativeFrom',+--   but with the initial position initialised to 'zeroVector'.+threePointDerivative+  :: ( Monad m, VectorSpace v+     , Groundfield v ~ 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+     , Groundfield v ~ Diff td)+  => v -- ^ The initial position+  -> BehaviorF m td (v, Groundfield v) 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+     , Floating (Groundfield v)+     , Groundfield v ~ Diff td)+  => v -- ^ The initial position+  -> Diff td -- ^ The time scale on which the signal is averaged+  -> BehaviorF m td v v+averageFrom v0 t = proc v -> do+  TimeInfo {..} <- timeInfo -< ()+  let+    weight = exp $ - (sinceLast / t)+  weightedAverageFrom v0    -< (v, weight)+++-- | An average, or low pass, initialised to zero.+average+  :: ( Monad m, VectorSpace v+     , Floating (Groundfield v)+     , Groundfield v ~ Diff td)+  => Diff td -- ^ The time scale on which the signal is averaged+  -> 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+     , Groundfield v ~ Diff td)+  => v -- ^ The initial position+  -> Diff td -- ^ The time scale on which the signal is averaged+  -> BehaviourF m td v v+averageLinFrom v0 t = proc v -> do+  TimeInfo {..} <- timeInfo -< ()+  let+    weight = t / (sinceLast + t)+  weightedAverageFrom v0    -< (v, weight)++-- | Linearised version of 'average'.+averageLin+  :: ( Monad m, VectorSpace v+     , Groundfield v ~ Diff td)+  => Diff td -- ^ The time scale on which the signal is averaged+  -> BehaviourF m td v v+averageLin = averageLinFrom zeroVector++-- *** First-order filters++-- | Alias for 'average'.+lowPass+  :: ( Monad m, VectorSpace v+     , Floating (Groundfield v)+     , Groundfield v ~ Diff td)+  => Diff td+  -> BehaviourF m td v v+lowPass = average++-- | Filters out frequencies below @1 / (2 * pi * t)@.+highPass+  :: ( Monad m, VectorSpace v+     , Floating (Groundfield v)+     , Groundfield v ~ Diff td)+  => Diff td -- ^ The time constant @t@+  -> BehaviourF m td v v+highPass t = clId ^-^ lowPass t++-- | Filters out frequencies other than @1 / (2 * pi * t)@.+bandPass+  :: ( Monad m, VectorSpace v+     , Floating (Groundfield v)+     , Groundfield v ~ Diff td)+  => Diff td -- ^ The time constant @t@+  -> BehaviourF m td v v+bandPass t = lowPass t >>> highPass t++-- | Filters out the frequency @1 / (2 * pi * t)@.+bandStop+  :: ( Monad m, VectorSpace v+     , Floating (Groundfield v)+     , Groundfield v ~ Diff td)+  => Diff td -- ^ The time constant @t@+  -> BehaviourF m td v v+bandStop t = clId ^-^ bandPass t++++-- * Delays++-- | Remembers and indefinitely outputs ("holds") the first input value.+keepFirst :: Monad m => ClSF m cl a a+keepFirst = safely $ do+  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))+historySince dTime = readerS $ accumulateWith appendValue empty+  where+    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.+delayBy+  :: (Monad m, Ord (Diff (Time cl)), TimeDomain (Time cl))+  => Diff (Time cl) -- ^ The time span to delay the signal+  -> ClSF m cl a a+delayBy dTime = historySince dTime >>> arr (viewr >>> safeHead) >>> lastS undefined >>> arr snd+  where+    safeHead EmptyR   = Nothing+    safeHead (_ :> a) = Just a+-- TODO Think about how to do it without undefined (maybe exceptions)++-- * 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)+timer diff = proc _ -> do+  time <- sinceStart -< ()+  _    <- 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_ 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 diff = timer diff >>> arr (/ diff)+++-- * To be ported to Dunai++-- | 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)

@@ -1,46 +1,74 @@-{-# LANGUAGE Arrows                #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE FlexibleInstances     #-}+{- |+'Clock's are the central new notion in Rhine.+There are clock types (instances of the 'Clock' type class)+and their values.++This module provides the 'Clock' type class, several utilities,+and certain general constructions of 'Clock's,+such as clocks lifted along monad morphisms or time rescalings.+-}+{-# LANGUAGE Arrows #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE RecordWildCards       #-}-{-# LANGUAGE TypeFamilies          #-}-module FRP.Rhine.Clock where+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+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)  -- dunai-import Data.MonadicStreamFunction+import Data.MonadicStreamFunction as X hiding ((>>>^), (^>>>))  -- rhine-import FRP.Rhine.TimeDomain+import FRP.Rhine.TimeDomain as X  -- * The 'Clock' type class  {- |-A clock creates a stream of time stamps,+A clock creates a stream of time stamps and additional information, possibly together with side effects in a monad 'm' that cause the environment to wait until the specified time is reached.+-}+type RunningClock m time tag = MSF m () (time, tag) -Since we want to leverage Haskell's type system to annotate signal functions by their clocks,+{- |+When initialising a clock, the initial time is measured+(typically by means of a side effect),+and a running clock is returned.+-}+type RunningClockInit m time tag = m (RunningClock m time tag, time)++{- |+Since we want to leverage Haskell's type system to annotate signal networks by their clocks, each clock must be an own type, 'cl'. Different values of the same clock type should tick at the same speed, and only differ in implementation details. Often, clocks are singletons. -}-class TimeDomain (TimeDomainOf cl) => Clock m cl where+class TimeDomain (Time cl) => Clock m cl where   -- | The time domain, i.e. type of the time stamps the clock creates.-  type TimeDomainOf cl+  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.-  startClock+  initClock     :: cl -- ^ The clock value, containing e.g. settings or device parameters-    -> m (MSF m () (TimeDomainOf cl, Tag cl), TimeDomainOf cl) -- ^ The stream of time stamps, and the initial time+    -> RunningClockInit m (Time cl) (Tag cl) -- ^ The stream of time stamps, and the initial time   -- * Auxiliary definitions and utilities@@ -48,18 +76,18 @@ -- | An annotated, rich time stamp. data TimeInfo cl = TimeInfo   { -- | Time passed since the last tick-    sinceTick  :: Diff (TimeDomainOf cl)+    sinceLast :: Diff (Time cl)     -- | Time passed since the initialisation of the clock-  , sinceStart :: Diff (TimeDomainOf cl)+  , sinceInit :: Diff (Time cl)     -- | The absolute time of the current tick-  , absolute   :: TimeDomainOf cl+  , absolute  :: Time cl     -- | The tag annotation of the current tick-  , tag        :: Tag cl+  , tag       :: Tag cl   }  -- | A utility that changes the tag of a 'TimeInfo'. retag-  :: (TimeDomainOf cl1 ~ TimeDomainOf cl2)+  :: (Time cl1 ~ Time cl2)   => (Tag cl1 -> Tag cl2)   -> TimeInfo cl1 -> TimeInfo cl2 retag f TimeInfo {..} = TimeInfo { tag = f tag, .. }@@ -69,73 +97,144 @@ --   generate a stream of time stamps. genTimeInfo   :: (Monad m, Clock m cl)-  => cl -> TimeDomainOf cl-  -> MSF m (TimeDomainOf cl, Tag cl) (TimeInfo cl)+  => cl -> Time cl+  -> MSF m (Time cl, Tag cl) (TimeInfo cl) genTimeInfo _ initialTime = proc (absolute, tag) -> do   lastTime <- iPre initialTime -< absolute   returnA                      -< TimeInfo-    { sinceTick  = absolute `diffTime` lastTime-    , sinceStart = absolute `diffTime` initialTime+    { sinceLast = absolute `diffTime` lastTime+    , sinceInit = absolute `diffTime` initialTime     , ..     }   -- * Certain universal building blocks to produce new clocks from given ones +-- ** Rescalings of time domains++-- | 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.+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.+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.+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++-- ** Applying rescalings to clocks+ -- | Applying a morphism of time domains yields a new clock.-data RescaledClock cl td = RescaledClock+data RescaledClock cl time = RescaledClock   { unscaledClock :: cl-  , rescale       :: TimeDomainOf cl -> td+  , rescale       :: Rescaling cl time   }  -instance (Monad m, TimeDomain td, Clock m cl)-      => Clock m (RescaledClock cl td) where-  type TimeDomainOf (RescaledClock cl td) = td-  type Tag          (RescaledClock cl td) = Tag cl-  startClock (RescaledClock cl f) = do-    (runningClock, initTime) <- startClock cl+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+  initClock (RescaledClock cl f) = do+    (runningClock, initTime) <- initClock cl     return       ( runningClock >>> first (arr f)       , 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.+data RescaledClockM m cl time = RescaledClockM+  { unscaledClockM :: cl+  -- ^ The clock before the rescaling+  , 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+  type Time (RescaledClockM m cl time) = time+  type Tag  (RescaledClockM m cl time) = Tag cl+  initClock RescaledClockM {..} = do+    (runningClock, initTime) <- initClock unscaledClockM+    rescaledInitTime         <- rescaleM initTime+    return+      ( runningClock >>> first (arrM rescaleM)+      , rescaledInitTime+      )++-- | A 'RescaledClock' is trivially a 'RescaledClockM'.+rescaledClockToM :: Monad m => RescaledClock cl time -> RescaledClockM m cl time+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.-data RescaledClockS m cl td tag = RescaledClockS+data RescaledClockS m cl time tag = RescaledClockS   { unscaledClockS :: cl   -- ^ The clock before the rescaling-  , rescaleS       :: TimeDomainOf cl-                   -> m (MSF m (TimeDomainOf cl, Tag cl) (td, tag), td)+  , 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 td, Clock m cl)-      => Clock m (RescaledClockS m cl td tag) where-  type TimeDomainOf (RescaledClockS m cl td tag) = td-  type Tag          (RescaledClockS m cl td tag) = tag-  startClock RescaledClockS {..} = do-    (runningClock, initTime) <- startClock unscaledClockS+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+  initClock RescaledClockS {..} = do+    (runningClock, initTime) <- initClock unscaledClockS     (rescaling, rescaledInitTime) <- rescaleS initTime     return       ( runningClock >>> rescaling       , rescaledInitTime       ) +-- | 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+  } +-- | A 'RescaledClock' is trivially a 'RescaledClockS'.+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-  { hoistedClock  :: cl-  , monadMorphism :: forall a . m1 a -> m2 a+  { unhoistedClock :: cl+  , monadMorphism  :: forall a . m1 a -> m2 a   }  instance (Monad m1, Monad m2, Clock m1 cl)       => Clock m2 (HoistClock m1 m2 cl) where-  type TimeDomainOf (HoistClock m1 m2 cl) = TimeDomainOf cl-  type Tag          (HoistClock m1 m2 cl) = Tag          cl-  startClock HoistClock {..} = do-    (runningClock, initialTime) <- monadMorphism $ startClock hoistedClock+  type Time (HoistClock m1 m2 cl) = Time cl+  type Tag  (HoistClock m1 m2 cl) = Tag  cl+  initClock HoistClock {..} = do+    (runningClock, initialTime) <- monadMorphism $ initClock unhoistedClock     let hoistMSF = liftMSFPurer     -- TODO Look out for API changes in dunai here     return@@ -143,10 +242,23 @@       , 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 hoistedClock = HoistClock+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   , ..   }

@@ -1,16 +0,0 @@-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies          #-}-module FRP.Rhine.Clock.Count where----- rhine-import FRP.Rhine---- | A singleton clock that counts the ticks.-data Count = Count -- Sesame street anyone?--instance Monad m => Clock m Count where-  type TimeDomainOf Count = Integer-  type Tag          Count = ()-  startClock _ = return (count &&& arr (const ()), 0)

@@ -1,21 +0,0 @@-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies          #-}--module FRP.Rhine.Clock.FixedRate where----- rhine-import FRP.Rhine----- | A side-effect-free clock ticking at a fixed rate.-newtype FixedRate = FixedRate Double--instance Monad m => Clock m FixedRate where-  type TimeDomainOf FixedRate = Double-  type Tag FixedRate = ()-  startClock (FixedRate timeStep) = return-    ( arr (const timeStep) >>> sumS &&& arr (const ())-    , 0-    )

@@ -0,0 +1,84 @@+{- |+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+++-- base+import Data.Maybe (fromMaybe)+import GHC.TypeLits++-- fixed-vector+import Data.Vector.Sized (Vector, fromList)++-- dunai+import Data.MonadicStreamFunction.Async (concatS)++-- rhine+import FRP.Rhine.Clock+import FRP.Rhine.ResamplingBuffer+import FRP.Rhine.ResamplingBuffer.Collect+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.+data FixedStep (n :: Nat) where+  FixedStep :: KnownNat n => FixedStep n -- TODO Does the constraint bring any benefit?++-- | Extract the type-level natural number as an integer.+stepsize :: FixedStep n -> Integer+stepsize fixedStep@FixedStep = natVal fixedStep++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+    )++-- | A singleton clock that counts the ticks.+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 ]++-- 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 = 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."+      ]

@@ -0,0 +1,88 @@+{- |+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 #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+module FRP.Rhine.Clock.Periodic (Periodic (Periodic)) where++-- base+import Control.Monad (forever)+import Data.List.NonEmpty hiding (unfold)+import Data.Maybe (fromMaybe)+import GHC.TypeLits (Nat, KnownNat, natVal)++-- dunai+import Control.Monad.Trans.MSF.Except+import Control.Monad.Trans.MSF.Maybe (listToMaybeS, runMaybeT)+import Data.MonadicStreamFunction++-- rhine+import FRP.Rhine.Clock+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.+data Periodic (v :: [Nat]) where+  Periodic :: Periodic (n : ns)++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 >>> sumS &&& arr (const ())+    , 0+    )++-- * Type-level trickery to extract the type value from the singleton++data HeadClProxy (n :: Nat) where+  HeadClProxy :: Periodic (n : ns) -> HeadClProxy n++headCl :: KnownNat n => Periodic (n : ns) -> Integer+headCl cl = natVal $ HeadClProxy cl++tailCl :: Periodic (n1 : n2 : ns) -> Periodic (n2 : ns)+tailCl Periodic = Periodic++class NonemptyNatList (v :: [Nat]) where+  theList :: Periodic v -> NonEmpty Integer++instance KnownNat n => NonemptyNatList '[n] where+  theList cl = headCl cl :| []++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++{-+-- TODO Port back to dunai when naming issues are resolved+delayList :: [a] -> MSF a a+delayList [] = id+delayList (a : as) = delayList as >>> delay a+-}

@@ -1,9 +1,14 @@-{-# LANGUAGE Arrows                #-}-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE KindSignatures        #-}+{- |+Provides several clocks to use for audio processing,+for realtime as well as for batch/file processing.+-}++{-# LANGUAGE Arrows #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeFamilies #-}  -- {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -- TODO Find out exact version of cabal? GHC? that have a problem with this@@ -12,6 +17,7 @@   ( AudioClock (..)   , AudioRate (..)   , PureAudioClock (..)+  , PureAudioClockF   , pureAudioClockF   )   where@@ -26,10 +32,10 @@   -- dunai-import Control.Monad.Trans.MSF.Except+import Control.Monad.Trans.MSF.Except hiding (step)  -- rhine-import FRP.Rhine+import FRP.Rhine.Clock  -- | Rates at which audio signals are typically sampled. data AudioRate@@ -89,10 +95,10 @@  instance (MonadIO m, KnownNat bufferSize, AudioClockRate rate)       => Clock m (AudioClock rate bufferSize) where-  type TimeDomainOf (AudioClock rate bufferSize) = UTCTime-  type Tag          (AudioClock rate bufferSize) = Maybe Double+  type Time (AudioClock rate bufferSize) = UTCTime+  type Tag  (AudioClock rate bufferSize) = Maybe Double -  startClock audioClock = do+  initClock audioClock = do     let       step       = picosecondsToDiffTime -- The only sufficiently precise conversion function                      $ round (10 ^ (12 :: Integer) / theRateNum audioClock :: Double)@@ -135,10 +141,10 @@   instance (Monad m, PureAudioClockRate rate) => Clock m (PureAudioClock rate) where-  type TimeDomainOf (PureAudioClock rate) = Double-  type Tag          (PureAudioClock rate) = ()+  type Time (PureAudioClock rate) = Double+  type Tag  (PureAudioClock rate) = () -  startClock audioClock = return+  initClock audioClock = return     ( arr (const (1 / thePureRateNum audioClock)) >>> sumS &&& arr (const ())     , 0     )@@ -147,6 +153,9 @@ -- | 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. pureAudioClockF :: PureAudioClockF rate pureAudioClockF = RescaledClock   { unscaledClock = PureAudioClock

@@ -1,12 +1,14 @@+{- | A "'Busy'" clock that ticks without waiting. -}+ {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeFamilies #-} module FRP.Rhine.Clock.Realtime.Busy where  -- base import Data.Time.Clock  -- rhine-import FRP.Rhine+import FRP.Rhine.Clock  {- | A clock that ticks without waiting.@@ -16,10 +18,10 @@ data Busy = Busy  instance Clock IO Busy where-  type TimeDomainOf Busy = UTCTime-  type Tag          Busy = ()+  type Time Busy = UTCTime+  type Tag  Busy = () -  startClock _ = do+  initClock _ = do     initialTime <- getCurrentTime     return       ( arrM_ getCurrentTime

@@ -0,0 +1,196 @@+{- |+This module provides two things:++* Clocks that tick whenever events arrive on a 'Control.Concurrent.Chan',+  and useful utilities.+* Primitives to emit events.++Note that _events work across multiple clocks_,+i.e. it is possible (and encouraged) to emit events from signals+on a different clock than the event clock.+This is in line with the Rhine philosophy that _event sources are clocks_.++Events even work well across separate threads,+and constitute the recommended way of communication between threads in Rhine.++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 #-}+{-# LANGUAGE TypeSynonymInstances #-}+module FRP.Rhine.Clock.Realtime.Event+  ( module FRP.Rhine.Clock.Realtime.Event+  , module Control.Monad.IO.Class+  , newChan+  )+  where++-- base+import Control.Concurrent.Chan+import Data.Time.Clock+import Data.Semigroup++-- deepseq+import Control.DeepSeq++-- transformers+import Control.Monad.IO.Class+import Control.Monad.Trans.Reader++-- rhine+import FRP.Rhine.ClSF+import FRP.Rhine.Clock+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.+withChan :: Chan event -> EventChanT event m a -> m a+withChan = flip runReaderT++{- | Create a channel across which events can be communicated,+and subsequently execute all event effects on this channel.++Ideally, this action is run _outside_ of 'flow',+e.g. @runEventChanT $ flow myRhine@.+This way, exactly one channel is created.++Caution: Don't use this with 'liftMSFPurer',+since it would create a new channel every tick.+Instead, create one @chan :: Chan c@, e.g. with 'newChan',+and then use 'withChanS'.+-}+runEventChanT :: MonadIO m => EventChanT event m a -> m a+runEventChanT a = do+  chan <- liftIO $ newChan+  runReaderT a chan++{- | Remove ("run") an 'EventChanT' layer from the monad stack+by passing it explicitly the channel over which events are sent.++This is usually only needed if you can't use 'runEventChanT'+to create the channel.+Typically, create a @chan :: Chan c@ in your main program+before the main loop (e.g. 'flow') would be run,+then, by using this function,+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 = flip runReaderS_++-- * Event emission++{- | Emit a single event.+This causes every 'EventClock' on the same monad to tick immediately.++Be cautious when emitting events from a signal clocked by an 'EventClock'.+Nothing prevents you from emitting more events than are handled,+causing the event buffer to grow indefinitely.+-}+emit :: MonadIO m => event -> EventChanT event m ()+emit event = do+  chan <- ask+  liftIO $ writeChan chan event++-- | Emit an event on every tick.+emitS :: MonadIO m => ClSF (EventChanT event m) cl event ()+emitS = arrMCl emit++-- | Emit an event whenever the input value is @Just event@.+emitSMaybe :: MonadIO m => ClSF (EventChanT event m) cl (Maybe event) ()+emitSMaybe = mapMaybe emitS >>> arr (const ())++-- | 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++-- | 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' = 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'.+data EventClock event = EventClock++instance Semigroup (EventClock event) where+  (<>) _ _ = EventClock++instance MonadIO m => Clock (EventChanT event m) (EventClock event) where+  type Time (EventClock event) = UTCTime+  type Tag  (EventClock event) = event+  initClock _ = do+    initialTime <- liftIO getCurrentTime+    return+      ( arrM_ $ do+          chan  <- ask+          event <- liftIO $ readChan chan+          time  <- liftIO $ getCurrentTime+          return (time, event)+      , initialTime+      )++-- | 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,+you can schedule them using concurrent GHC threads,+and share the event channel.++Typical use cases:++* Different subevent selection clocks+  (implemented i.e. with 'FRP.Rhine.Clock.Select')+  on top of the same main event source.+* 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 = readerSchedule concurrently

@@ -1,18 +1,31 @@-{-# LANGUAGE Arrows         #-}-{-# LANGUAGE DataKinds      #-}+{- |+Provides a clock that ticks at every multiple of a fixed number of milliseconds.+-}++{-# LANGUAGE Arrows #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-}-{-# LANGUAGE TypeFamilies   #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} module FRP.Rhine.Clock.Realtime.Millisecond where  -- base+import Data.Maybe (fromMaybe) import Data.Time.Clock import Control.Concurrent (threadDelay)-import GHC.TypeLits       (Nat, KnownNat)+import GHC.TypeLits +-- fixed-vector+import Data.Vector.Sized (Vector, fromList)  -- rhine-import FRP.Rhine-import FRP.Rhine.Clock.Step+import FRP.Rhine.Clock+import FRP.Rhine.Clock.FixedStep+import FRP.Rhine.Schedule+import FRP.Rhine.ResamplingBuffer+import FRP.Rhine.ResamplingBuffer.Util+import FRP.Rhine.ResamplingBuffer.Collect  {- | A clock ticking every 'n' milliseconds,@@ -25,43 +38,50 @@ where 'True' represents successful realtime, and 'False' a lag. -}-type Millisecond (n :: Nat) = RescaledClockS IO (Step n) UTCTime Bool+newtype Millisecond (n :: Nat) = Millisecond (RescaledClockS IO (FixedStep n) UTCTime Bool) -- TODO Consider changing the tag to Maybe Double --- | This clock simply sleeps 'n' milliseconds after each tick.---   The current time is measured, but no adjustment is made.---   Consequently, the tag is constantly 'False',---   since the clock will accumulate the computation time as lag.-sleepClock :: KnownNat n => Millisecond n-sleepClock = sleepClock_ Step-  where-    sleepClock_ :: Step n -> Millisecond n-    sleepClock_ cl = RescaledClockS cl $ const $ do-      now <- getCurrentTime-      return-        ( arrM_ (threadDelay (fromInteger $ stepsize cl * 1000) >> getCurrentTime)-          *** arr (const False)-        , now-        )+instance Clock IO (Millisecond n) where+  type Time (Millisecond n) = UTCTime+  type Tag  (Millisecond n) = Bool+  initClock (Millisecond cl) = initClock cl  --- TODO Test whether realtime detection really works here,---  e.g. with a getLine signal--- | A more sophisticated implementation that measures the time after each tick,+-- | 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. waitClock :: KnownNat n => Millisecond n-waitClock = RescaledClockS Step $ \_ -> do+waitClock = Millisecond $ RescaledClockS FixedStep $ \_ -> do   initTime <- getCurrentTime   let-    runningClock = proc (n, ()) -> do-      beforeSleep <- arrM_ getCurrentTime -< ()+    runningClock = arrM $ \(n, ()) -> do+      beforeSleep <- getCurrentTime       let         diff :: Double         diff      = realToFrac $ beforeSleep `diffUTCTime` initTime         remaining = fromInteger $ n * 1000 - round (diff * 1000000)-      _           <- arrM  threadDelay    -< remaining-      now         <- arrM_ getCurrentTime -< () -- TODO Test whether this is a performance penalty-      returnA                             -< (now, diff > 0)+      threadDelay remaining+      now         <- getCurrentTime -- TODO Test whether this is a performance penalty+      return (now, remaining > 0)   return (runningClock, initTime)+++-- TODO It would be great if this could be directly implemented in terms of downsampleFixedStep+downsampleMillisecond+  :: (KnownNat n, Monad m)+  => ResamplingBuffer m (Millisecond k) (Millisecond (n * k)) a (Vector n a)+downsampleMillisecond = collect >>-^ arr (fromList >>> assumeSize)+  where+    assumeSize = fromMaybe $ error $ 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

@@ -1,6 +1,12 @@-{-# LANGUAGE FlexibleInstances     #-}+{- |+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          #-}+{-# LANGUAGE TypeFamilies #-} module FRP.Rhine.Clock.Realtime.Stdin where  -- base@@ -11,29 +17,28 @@ import Control.Monad.IO.Class  -- rhine-import FRP.Rhine+import FRP.Rhine.Clock+import Data.Semigroup  {- | A clock that ticks for every line entered on the console,-outputting the entered line as its |Tag|.+outputting the entered line as its 'Tag'. -} data StdinClock = StdinClock  instance MonadIO m => Clock m StdinClock where-  type TimeDomainOf StdinClock = UTCTime-  type Tag          StdinClock = String+  type Time StdinClock = UTCTime+  type Tag  StdinClock = String -  startClock _ = do+  initClock _ = do     initialTime <- liftIO getCurrentTime     return-      (     arrM_ (liftIO getCurrentTime)-        &&& arrM_ (liftIO getLine)+      ( arrM_ $ liftIO $ do+          line <- getLine+          time <- getCurrentTime+          return (time, line)       , initialTime       )  instance Semigroup StdinClock where   _ <> _ = StdinClock--instance Monoid StdinClock where-  mempty      = StdinClock-  mappend _ _ = StdinClock

@@ -1,22 +1,36 @@-{-# LANGUAGE Arrows                #-}-{-# LANGUAGE FlexibleInstances     #-}+{- |+In the Rhine philosophy, _event sources are clocks_.+Often, we want to extract certain subevents from event sources,+e.g. single out only left mouse button clicks from all input device events.+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          #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-} module FRP.Rhine.Clock.Select where  -- rhine-import FRP.Rhine+import FRP.Rhine.Clock+import FRP.Rhine.Schedule  -- dunai import Data.MonadicStreamFunction.Async (concatS)  -- base import Data.Maybe (catMaybes, maybeToList)+import Data.Semigroup  -- | 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   -- | Return 'Nothing' if no tick of the subclock is required,@@ -26,10 +40,10 @@   instance (Monad m, Clock m cl) => Clock m (SelectClock cl a) where-  type TimeDomainOf (SelectClock cl a) = TimeDomainOf cl-  type Tag          (SelectClock cl a) = a-  startClock SelectClock {..} = do-    (runningClock, initialTime) <- startClock mainClock+  type Time (SelectClock cl a) = Time cl+  type Tag  (SelectClock cl a) = a+  initClock SelectClock {..} = do+    (runningClock, initialTime) <- initClock mainClock     let       runningSelectClock = filterS $ proc _ -> do         (time, tag) <- runningClock -< ()@@ -38,15 +52,15 @@   -- | A universal schedule for two subclocks of the same main clock.---   The main clock must be a monoid (e.g. a singleton).+--   The main clock must be a 'Semigroup' (e.g. a singleton). schedSelectClocks-  :: (Monad m, Monoid cl, Clock m cl)+  :: (Monad m, Semigroup cl, Clock m cl)   => Schedule m (SelectClock cl a) (SelectClock cl b) schedSelectClocks = Schedule {..}   where-    startSchedule subClock1 subClock2 = do-      (runningClock, initialTime) <- startClock-        $ mainClock subClock1 `mappend` mainClock subClock2+    initSchedule subClock1 subClock2 = do+      (runningClock, initialTime) <- initClock+        $ mainClock subClock1 <> mainClock subClock2       let         runningSelectClocks = concatS $ proc _ -> do           (time, tag) <- runningClock -< ()@@ -54,6 +68,23 @@             [ (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 = Schedule {..}+  where+    initSchedule mainClock' SelectClock {..} = do+      (runningClock, initialTime) <- initClock+        $ mainClock' <> mainClock+      let+        runningSelectClock = concatS $ proc _ -> do+          (time, tag) <- runningClock -< ()+          returnA                     -< catMaybes+            [ Just (time, Left tag)+            , (time, ) . Right <$> select tag ]+      return (runningSelectClock, initialTime)   -- | Helper function that runs an 'MSF' with 'Maybe' output

@@ -1,53 +0,0 @@-{-# LANGUAGE Arrows                #-}-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE GADTs                 #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-}-module FRP.Rhine.Clock.Step where----- base-import GHC.TypeLits---- dunai-import Data.MonadicStreamFunction.Async (concatS)---- rhine-import FRP.Rhine----- | A pure (side effect free) clock ticking at multiples of 'n'.---   The tick rate is in the type signature,---   which prevents composition of signals at different rates.-data Step (n :: Nat) where-  Step :: KnownNat n => Step n -- TODO Does the constraint bring any benefit?---- | Extract the type-level natural number as an integer.-stepsize :: Step n -> Integer-stepsize step@Step = natVal step--instance Monad m => Clock m (Step n) where-  type TimeDomainOf (Step n) = Integer-  type Tag          (Step n) = ()-  startClock cl = return-    ( count >>> arr (* stepsize cl)-      &&& arr (const ())-    , 0-    )----- | Two 'Step' clocks can always be scheduled without side effects.-scheduleStep-  :: Monad m-  => Schedule m (Step n1) (Step n2)-scheduleStep = 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 ]

@@ -1,4 +1,9 @@-{-# LANGUAGE GADTs           #-}+{- |+Run closed 'Rhine's (which are signal functions together with matching clocks)+as main loops.+-}++{-# LANGUAGE GADTs #-} {-# LANGUAGE RecordWildCards #-} module FRP.Rhine.Reactimation where @@ -8,46 +13,37 @@  -- rhine import FRP.Rhine.Clock+import FRP.Rhine.ClSF.Core import FRP.Rhine.Reactimation.Tick+import FRP.Rhine.Reactimation.Combinators import FRP.Rhine.Schedule-import FRP.Rhine.SF+import FRP.Rhine.Type  -{- |-An 'SF' together with a clock of matching type 'cl',-A 'Rhine' is a reactive program, possibly with open inputs and outputs.-If the input and output types 'a' and 'b' are both '()',-that is, the 'Rhine' is "closed",-then it is a standalone reactive program-that can be run with the function 'flow'.--}-data Rhine m cl a b = Rhine-  { sf    :: SF m cl a b-  , clock :: cl-  } - -- * Running a Rhine  {- | Takes a closed 'Rhine' (with trivial input and output), and runs it indefinitely.-All input is created, and all output is consumed by means of side effects-in a monad 'm'.+This is typically the main loop. +All input has to be created, and all output has to be consumed+by means of side effects in a monad 'm'.+ Basic usage (synchronous case):  @-sensor :: SyncSF MyMonad MyClock () a-sensor = arrMSync_ produceData+sensor :: ClSF MyMonad MyClock () a+sensor = constMCl produceData -processing :: SyncSF MyMonad MyClock a b+processing :: ClSF MyMonad MyClock a b processing = ... -actuator :: SyncSF MyMonad MyClock b ()-actuator = arrMSync consumeData+actuator :: ClSF MyMonad MyClock b ()+actuator = arrMCl consumeData -mainSF :: SyncSF MyMonad MyClock () ()+mainSF :: ClSF MyMonad MyClock () () mainSF = sensor >-> processing >-> actuator  main :: MyMonad ()@@ -57,16 +53,16 @@ -- TODO Can we chuck the constraints into Clock m cl? flow   :: ( Monad m, Clock m cl-     , TimeDomainOf cl ~ TimeDomainOf (Leftmost  cl)-     , TimeDomainOf cl ~ TimeDomainOf (Rightmost cl)+     , Time cl ~ Time (In  cl)+     , Time cl ~ Time (Out cl)      )   => Rhine m cl () () -> m () flow Rhine {..} = do-  (runningClock, initTime) <- startClock clock+  (runningClock, initTime) <- initClock clock   -- Run the main loop   flow' runningClock $ createTickable     (trivialResamplingBuffer clock)-    sf+    sn     (trivialResamplingBuffer clock)     initTime     where@@ -77,3 +73,13 @@         tickable' <- tick tickable now tag         -- Loop         flow' runningClock' tickable'+++-- | 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+     , cl ~ In  cl, cl ~ Out cl+     )+  => cl -> ClSF m cl () () -> m ()+reactimateCl cl clsf = flow $ clsf @@ cl

@@ -0,0 +1,187 @@+{- |+Combinators to create 'Rhine's (main programs) from basic components+such as 'ClSF's, clocks, 'ResamplingBuffer's and 'Schedule's.++The combinator names are often mixed of the symbols @, @*@ and @>@,+and several other symbols.+The general mnemonic for combinator names is:++* @ annotates a data processing unit such as a signal function, network or buffer+  with temporal information like a clock or a schedule.+* @*@ composes parallely.+* @>@ composes sequentially.+-}++{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++module FRP.Rhine.Reactimation.Combinators where+++-- rhine+import FRP.Rhine.Clock+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.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+(@@) = 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)+-- TODO Make a record out of it?+-- TODO This is aesthetically displeasing.+--      For the buffer, the associativity doesn't matter, but for the Schedule,+--      we sometimes need to specify particular brackets in order for it to work.+--      This is confusing.+--      There would be a workaround if there were pullbacks of schedules...++-- | Syntactic sugar for 'ResamplingPoint'.+infix 8 -@-+(-@-) :: 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.+infix 2 >--+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+(>--) = RhineAndResamplingPoint++{- | The combinators for sequential composition allow for the following syntax:++@+rh1   :: Rhine            m      cl1           a b+rh1   =  ...++rh2   :: Rhine            m               cl2      c d+rh2   =  ...++rb    :: ResamplingBuffer m (Out cl1) (In cl2)   b c+rb    =  ...++sched :: Schedule         m      cl1      cl2+sched =  ...++rh    :: Rhine m (SequentialClock m cl1   cl2) a     d+rh    =  rh1 >-- rb -@- sched --> rh2+@+-}+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 (In  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)++-- | A purely syntactical convenience construction+--   allowing for ternary syntax for parallel composition, described below.+data RhineParallelAndSchedule m clL clR a b+  = RhineParallelAndSchedule (Rhine m clL a b) (Schedule m clL clR)++-- | Syntactic sugar for 'RhineParallelAndSchedule'.+infix 4 ++@+(++@)+  :: 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:++@+rh1   :: Rhine    m                clL      a         b+rh1   =  ...++rh2   :: Rhine    m                    clR  a           c+rh2   =  ...++sched :: Schedule m                clL clR+sched =  ...++rh    :: Rhine    m (ParallelClock clL clR) a (Either b c)+rh    =  rh1 ++\@ sched \@++ rh2+@+-}+infix 3 @+++(@++)+  :: ( Monad m, Clock m clL, Clock m 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+(||@) = RhineParallelAndSchedule++{- | The combinators for parallel composition allow for the following syntax:++@+rh1   :: Rhine    m                clL      a b+rh1   =  ...++rh2   :: Rhine    m                    clR  a b+rh2   =  ...++sched :: Schedule m                clL clR+sched =  ...++rh    :: Rhine    m (ParallelClock clL clR) a b+rh    =  rh1 ||\@ sched \@|| rh2+@+-}+infix 3 @||+(@||)+  :: ( Monad m, Clock m clL, Clock m 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)

@@ -1,5 +1,10 @@-{-# LANGUAGE GADTs           #-}-{-# LANGUAGE NamedFieldPuns  #-}+{- |+This module contains internals needed for the reactimation of signal functions.+None of it should be relevant for a typical user of this library.+-}++{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} module FRP.Rhine.Reactimation.Tick where @@ -13,196 +18,195 @@ import FRP.Rhine.Clock import FRP.Rhine.ResamplingBuffer import FRP.Rhine.Schedule-import FRP.Rhine.SF-import FRP.Rhine.TimeDomain+import FRP.Rhine.SN  -{- | A signal function ('SF') enclosed by matching 'ResamplingBuffer's and further auxiliary data,+{- | A signal network ('SN') enclosed by matching 'ResamplingBuffer's and further auxiliary data, such that it can be stepped with each arriving tick from a clock 'cl'. They play a similar role like 'ReactHandle's in dunai.  The type parameters: -* 'm': The monad in which the 'SF' and the 'ResamplingBuffer's produce side effects+* 'm': The monad in which the 'SN' and the 'ResamplingBuffer's produce side effects * 'cla': The (irrelevant) input clock of the left 'ResamplingBuffer' * 'clb': The clock at which the left 'ResamplingBuffer' produces output-* 'cl': The clock at which the 'SF' ticks+* 'cl': The clock at which the 'SN' ticks * 'clc': The clock at which the right 'ResamplingBuffer' accepts input * 'cld': The (irrelevant) output clock of the right 'ResamplingBuffer' * 'a': The (irrelevant) input type of the left 'ResamplingBuffer'-* 'b': The input type of the 'SF'-* 'c': The output type of the 'SF'+* 'b': The input type of the 'SN'+* 'c': The output type of the 'SN' * 'd': The (irrelevant) output type of the right 'ResamplingBuffer' -} data Tickable m cla clb cl clc cld a b c d = Tickable   { -- | The left buffer from which the input is taken.     buffer1     :: ResamplingBuffer m cla clb          a b-    -- | The signal function that will process the data.-  , ticksf      :: SF               m        cl          b c+    -- | The signal network that will process the data.+  , ticksn      :: SN               m        cl          b c     -- | The right buffer in which the output is stored.   , buffer2     :: ResamplingBuffer m          clc cld     c d-    -- | The leftmost clock of the signal function, 'cl',+    -- | The leftmost clock of the signal network, 'cl',     --   may be a parallel subclock of the buffer clock.-    --   'parClockInL' specifies in which position 'Leftmost cl'+    --   'parClockIn' specifies in which position 'In cl'     --   is a parallel subclock of 'clb'.-  , parClockInL :: ParClockInclusion (Leftmost  cl) clb+  , parClockIn  :: ParClockInclusion (In  cl) clb     -- | The same on the output side.-  , parClockInR :: ParClockInclusion (Rightmost cl) clc+  , parClockOut :: ParClockInclusion (Out cl) clc     -- | The last times when the different parts of the signal tree have ticked.   , lastTime    :: LastTime cl     -- | The time when the whole clock was initialised.-  , initTime    :: TimeDomainOf cl+  , initTime    :: Time cl   }   -- | Initialise the tree of last tick times.-initLastTime :: SF m cl a b -> TimeDomainOf cl -> LastTime cl+initLastTime :: SN m cl a b -> Time cl -> LastTime cl initLastTime (Synchronous _)        initTime = LeafLastTime initTime-initLastTime (Sequential sf1 _ sf2) initTime =+initLastTime (Sequential sn1 _ sn2) initTime =   SequentialLastTime-    (initLastTime sf1 initTime)-    (initLastTime sf2 initTime)-initLastTime (Parallel sf1 sf2)     initTime =+    (initLastTime sn1 initTime)+    (initLastTime sn2 initTime)+initLastTime (Parallel sn1 sn2)     initTime =   ParallelLastTime-    (initLastTime sf1 initTime)-    (initLastTime sf2 initTime)+    (initLastTime sn1 initTime)+    (initLastTime sn2 initTime) --- | Initialise a 'Tickable' from a signal function,+-- | Initialise a 'Tickable' from a signal network, --   two matching enclosing resampling buffers and an initial time. createTickable-  :: ResamplingBuffer m cla (Leftmost cl)                       a b-  -> SF               m                   cl                      b c-  -> ResamplingBuffer m                      (Rightmost cl) cld     c d-  -> TimeDomainOf cl-  -> Tickable         m cla (Leftmost cl) cl (Rightmost cl) cld a b c d-createTickable buffer1 ticksf buffer2 initTime = Tickable-  { parClockInL = ParClockRefl-  , parClockInR = ParClockRefl-  , lastTime    = initLastTime ticksf initTime+  :: ResamplingBuffer m cla (In cl)                 a b+  -> SN               m         cl                      b c+  -> ResamplingBuffer m                (Out cl) cld     c d+  -> Time cl+  -> Tickable         m cla (In cl) cl (Out cl) cld a b c d+createTickable buffer1 ticksn buffer2 initTime = Tickable+  { parClockIn  = ParClockRefl+  , parClockOut = ParClockRefl+  , lastTime    = initLastTime ticksn initTime   , ..   } -{- | In this function, one tick, or step of an asynchronous signal function happens.+{- | In this function, one tick, or step of an asynchronous signal network happens. The 'TimeInfo' holds the information which part of the signal tree will tick. This information is encoded in the 'Tag' of the 'TimeInfo', which is of type 'Either tag1 tag2' in case of a 'SequentialClock' or a 'ParallelClock', encoding either a tick for the left clock or the right clock. -} tick :: ( Monad m, Clock m cl-        , TimeDomainOf cla ~ TimeDomainOf cl-        , TimeDomainOf clb ~ TimeDomainOf cl-        , TimeDomainOf clc ~ TimeDomainOf cl-        , TimeDomainOf cld ~ TimeDomainOf cl-        , TimeDomainOf (Leftmost  cl) ~ TimeDomainOf cl-        , TimeDomainOf (Rightmost cl) ~ TimeDomainOf cl+        , Time cla ~ Time cl+        , Time clb ~ Time cl+        , Time clc ~ Time cl+        , Time cld ~ Time cl+        , Time (In  cl) ~ Time cl+        , Time (Out cl) ~ Time cl         )      => Tickable    m cla clb cl clc cld a b c d-     -> TimeDomainOf cl -- ^ Timestamp of the present tick+     -> Time cl -- ^ Timestamp of the present tick      -> Tag cl -- ^ 'Tag' of the overall clock; contains the information which subsystem will become active      -> m (Tickable m cla clb cl clc cld a b c d) -- Only if we have reached a leaf of the tree, data is actually processed. tick Tickable-  { ticksf   = Synchronous syncsf+  { ticksn   = Synchronous clsf   , lastTime = LeafLastTime lastTime   , .. } now tag = do     let       ti = TimeInfo-        { sinceTick  = diffTime now lastTime-        , sinceStart = diffTime now initTime-        , absolute   = now-        , tag        = tag+        { sinceLast = diffTime now lastTime+        , sinceInit = diffTime now initTime+        , absolute  = now+        , tag       = tag         }     -- Get an input value from the left buffer-    (b, buffer1') <- get buffer1 $ retag (parClockTagInclusion parClockInL) ti-    -- Run it through the synchronous signal function-    (c, syncsf')  <- unMSF syncsf b `runReaderT` ti+    (b, buffer1') <- get buffer1 $ retag (parClockTagInclusion parClockIn ) ti+    -- Run it through the signal function+    (c, clsf')  <- unMSF clsf b `runReaderT` ti     -- Put the output into the right buffer-    buffer2'      <- put buffer2 (retag (parClockTagInclusion parClockInR) ti) c+    buffer2'      <- put buffer2 (retag (parClockTagInclusion parClockOut) ti) c     return Tickable       { buffer1  = buffer1'-      , ticksf   = Synchronous syncsf'+      , ticksn   = Synchronous clsf'       , buffer2  = buffer2'       , lastTime = LeafLastTime now       , .. } -- The left part of a sequential composition is stepped. tick tickable@Tickable-  { ticksf   = Sequential sf1 bufferMiddle sf2+  { ticksn   = Sequential sn1 bufferMiddle sn2   , lastTime = SequentialLastTime lastTimeL lastTimeR   , initTime-  , parClockInL+  , parClockIn   } now (Left tag) = do     leftTickable <- tick Tickable       { buffer1     = buffer1 tickable-      , ticksf      = sf1+      , ticksn      = sn1       , buffer2     = bufferMiddle-      , parClockInL = parClockInL-      , parClockInR = ParClockRefl+      , parClockIn  = parClockIn+      , parClockOut = ParClockRefl       , lastTime    = lastTimeL       , initTime    = initTime       } now tag     return $ tickable       { buffer1  = buffer1 leftTickable-      , ticksf   = Sequential (ticksf leftTickable) (buffer2 leftTickable) sf2+      , ticksn   = Sequential (ticksn leftTickable) (buffer2 leftTickable) sn2       , lastTime = SequentialLastTime (lastTime leftTickable) lastTimeR       } -- The right part of a sequential composition is stepped. tick tickable@Tickable-  { ticksf   = Sequential sf1 bufferMiddle sf2+  { ticksn   = Sequential sn1 bufferMiddle sn2   , lastTime = SequentialLastTime lastTimeL lastTimeR   , initTime-  , parClockInR+  , parClockOut   } now (Right tag) = do     rightTickable <- tick Tickable       { buffer1     = bufferMiddle-      , ticksf      = sf2+      , ticksn      = sn2       , buffer2     = buffer2 tickable-      , parClockInL = ParClockRefl-      , parClockInR = parClockInR+      , parClockIn  = ParClockRefl+      , parClockOut = parClockOut       , lastTime    = lastTimeR       , initTime    = initTime       } now tag     return $ tickable       { buffer2  = buffer2 rightTickable-      , ticksf   = Sequential sf1 (buffer1 rightTickable) (ticksf rightTickable)+      , ticksn   = Sequential sn1 (buffer1 rightTickable) (ticksn rightTickable)       , lastTime = SequentialLastTime lastTimeL (lastTime rightTickable)       } -- A parallel composition is stepped. tick tickable@Tickable-  { ticksf   = Parallel sfA sfB+  { ticksn   = Parallel snA snB   , lastTime = ParallelLastTime lastTimeA lastTimeB   , initTime-  , parClockInL-  , parClockInR+  , parClockIn+  , parClockOut   } now tag = case tag of     Left tagL -> do       leftTickable <- tick Tickable         { buffer1     = buffer1 tickable-        , ticksf      = sfA+        , ticksn      = snA         , buffer2     = buffer2 tickable-        , parClockInL = ParClockInL parClockInL-        , parClockInR = ParClockInL parClockInR+        , parClockIn  = ParClockInL parClockIn+        , parClockOut = ParClockInL parClockOut         , lastTime    = lastTimeA         , initTime    = initTime         } now tagL       return $ tickable         { buffer1  = buffer1 leftTickable-        , ticksf   = Parallel (ticksf leftTickable) sfB+        , ticksn   = Parallel (ticksn leftTickable) snB         , buffer2  = buffer2 leftTickable         , lastTime = ParallelLastTime (lastTime leftTickable) lastTimeB         }     Right tagR -> do       rightTickable <- tick Tickable         { buffer1     = buffer1 tickable-        , ticksf      = sfB+        , ticksn      = snB         , buffer2     = buffer2 tickable-        , parClockInL = ParClockInR parClockInL-        , parClockInR = ParClockInR parClockInR+        , parClockIn  = ParClockInR parClockIn+        , parClockOut = ParClockInR parClockOut         , lastTime    = lastTimeB         , initTime    = initTime         } now tagR       return $ tickable         { buffer1  = buffer1 rightTickable-        , ticksf   = Parallel sfA (ticksf rightTickable)+        , ticksn   = Parallel snA (ticksn rightTickable)         , buffer2  = buffer2 rightTickable         , lastTime = ParallelLastTime lastTimeA (lastTime rightTickable)         }@@ -218,7 +222,7 @@ -} trivialResamplingBuffer   :: Monad m => cl-  -> ResamplingBuffer m (Rightmost cl) (Leftmost cl) () ()+  -> ResamplingBuffer m (Out cl) (In cl) () () trivialResamplingBuffer _ = go   where     go  = ResamplingBuffer {..}

@@ -1,7 +1,19 @@-{-# LANGUAGE RankNTypes      #-}+{- |+This module introduces 'ResamplingBuffer's,+which are primitives that consume and produce data at different rates.+Just as schedules form the boundaries between different clocks,+(resampling) buffers form the boundaries between+synchronous signal functions ticking at different speeds.+-}++{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies    #-}-module FRP.Rhine.ResamplingBuffer where+{-# LANGUAGE TypeFamilies #-}+module FRP.Rhine.ResamplingBuffer+  ( module FRP.Rhine.ResamplingBuffer+  , module FRP.Rhine.Clock+  )+  where  -- rhine import FRP.Rhine.Clock@@ -11,10 +23,10 @@ import Control.Arrow (second)  -- A quick note on naming conventions, to whoever cares:--- . Call a single clock cl.--- . Call several clocks cl1, cl2 etc. in most situations.--- . Call it cla, clb etc. when they are Leftmost or Rightmost clocks,--- i.e. associated to particular boundary types a, b etc.,+-- . Call a single clock @cl@.+-- . Call several clocks @cl1@, @cl2@ etc. in most situations.+-- . Call it @cla@, @clb@ etc. when they are 'In' or 'Out' clocks,+-- i.e. associated to particular boundary types @a@, @b@ etc.,  {- | A stateful buffer from which one may 'get' a value, or to which one may 'put' a value,@@ -41,6 +53,9 @@     -- ^ 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.

@@ -1,4 +1,9 @@-{-# LANGUAGE BangPatterns    #-}+{- |+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 

@@ -1,8 +1,12 @@+{- |+Different implementations of FIFO buffers.+-}+ {-# LANGUAGE RecordWildCards #-} module FRP.Rhine.ResamplingBuffer.FIFO where  -- base-import Prelude hiding (length)+import Prelude hiding (length, take)  -- containers import Data.Sequence@@ -15,14 +19,23 @@  -- | An unbounded FIFO buffer. --   If the buffer is empty, it will return 'Nothing'.-fifo :: Monad m => ResamplingBuffer m cl1 cl2 a (Maybe a)-fifo = timelessResamplingBuffer AsyncMealy {..} empty+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'  ) +-- |  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'  )  -- | An unbounded FIFO buffer that also returns its current size. fifoWatch :: Monad m => ResamplingBuffer m cl1 cl2 a (Maybe a, Int)

@@ -1,30 +1,102 @@-{-# LANGUAGE Arrows       #-}+{- |+Interpolation buffers.+-}++{-# LANGUAGE Arrows #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} module FRP.Rhine.ResamplingBuffer.Interpolation where +-- containers+import Data.Sequence  -- dunai import Data.VectorSpace+import Data.VectorSpace.Tuples  -- rhine-import FRP.Rhine-import FRP.Rhine.ResamplingBuffer.KeepLast+import FRP.Rhine.ClSF+import FRP.Rhine.ResamplingBuffer import FRP.Rhine.ResamplingBuffer.Util+import FRP.Rhine.ResamplingBuffer.KeepLast  -- | A simple linear interpolation based on the last calculated position and velocity. linear   :: ( Monad m, Clock m cl1, Clock m cl2      , VectorSpace v-     , Groundfield v ~ Diff (TimeDomainOf cl1)-     , Groundfield v ~ Diff (TimeDomainOf cl2)+     , Groundfield v ~ Diff (Time cl1)+     , Groundfield v ~ 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 &&& syncId) &&& timeInfoOf sinceStart+  =    (derivativeFrom initPosition &&& clId) &&& timeInfoOf sinceInit   ^->> keepLast ((initVelocity, initPosition), 0)-  >>-^ proc ((velocity, lastPosition), sinceStart1) -> do-    sinceStart2 <- timeInfoOf sinceStart -< ()-    let diff = sinceStart2 - sinceStart1+  >>-^ proc ((velocity, lastPosition), sinceInit1) -> do+    sinceInit2 <- timeInfoOf sinceInit -< ()+    let diff = sinceInit2 - sinceInit1     returnA -< lastPosition ^+^ velocity ^* diff++{- |+sinc-Interpolation, or Whittaker-Shannon-Interpolation.++The incoming signal is strictly bandlimited+by the frequency at which @cl1@ ticks.+Each incoming value is hulled in a sinc function,+these are added and sampled at @cl2@'s ticks.+In order not to produce a space leak,+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+     , Ord (Groundfield v)+     , Floating (Groundfield v)+     , Groundfield v ~ Diff (Time cl1)+     , Groundfield v ~ Diff (Time cl2)+     )+  => Groundfield v+  -- ^ 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+  where+    mkSinc sinceInit2 (TimeInfo {..}, as)+      = let t = pi * (sinceInit2 - sinceInit) / sinceLast+        in  as ^* (sin t / t)+    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+     , Groundfield v ~ Diff (Time cl1)+     , Groundfield v ~ Diff (Time cl2)+     )+  => ResamplingBuffer m cl1 cl2 v v+cubic = ((delay zeroVector &&& threePointDerivative) &&& (sinceInitS >-> delay 0))+    >-> (clId &&& delay (zeroVector, 0))+   ^->> keepLast ((zeroVector, 0), (zeroVector, 0))+   >>-^ proc (((dv, v), t1), ((dv', v'), t1')) -> do+     t2 <- sinceInitS -< ()+     let+       t        = (t1 - t1') / (t2 - t1')+       tsquared = t ^ 2+       tcubed   = t ^ 3+       vInter   = ( 2 * tcubed - 3 * tsquared     + 1) *^  v'+              ^+^ (     tcubed - 2 * tsquared + t    ) *^ dv'+              ^+^ (-2 * tcubed + 3 * tsquared        ) *^  v+              ^+^ (     tcubed -     tsquared        ) *^ dv+     returnA -< vInter

@@ -1,3 +1,7 @@+{- |+A buffer keeping the last value, or zero-order hold.+-}+ {-# LANGUAGE RecordWildCards #-} module FRP.Rhine.ResamplingBuffer.KeepLast where @@ -6,6 +10,8 @@  -- | 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

@@ -0,0 +1,47 @@+{- |+Different implementations of LIFO buffers.+-}++{-# LANGUAGE RecordWildCards #-}+module FRP.Rhine.ResamplingBuffer.LIFO where++-- base+import Prelude hiding (length, take)++-- containers+import Data.Sequence++-- rhine+import FRP.Rhine.ResamplingBuffer+import FRP.Rhine.ResamplingBuffer.Timeless++-- * LIFO (last-in-first-out) buffers++-- | 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'  )++-- |  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'  )++-- | 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'  )

@@ -1,13 +1,17 @@+{- |+Collect and process all incoming values statefully and with time stamps.+-}+ {-# LANGUAGE RecordWildCards #-} module FRP.Rhine.ResamplingBuffer.MSF where  -- rhine-import FRP.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+--   that collects all input in a timestamped list. msfBuffer   :: Monad m   => MSF m (TimeInfo cl2, [(TimeInfo cl1, a)]) b@@ -17,16 +21,16 @@   --   and outputs a single value.   --   The list will contain the /newest/ element in the head.   -> ResamplingBuffer m cl1 cl2 a b-msfBuffer msf = msfBuffer' msf []+msfBuffer = msfBuffer' []   where     msfBuffer'       :: Monad m-      => MSF m (TimeInfo cl2, [(TimeInfo cl1, a)]) b-      -> [(TimeInfo cl1, a)]+      => [(TimeInfo cl1, a)]+      -> MSF m (TimeInfo cl2, [(TimeInfo cl1, a)]) b       -> ResamplingBuffer m cl1 cl2 a b-    msfBuffer' msf as = ResamplingBuffer {..}+    msfBuffer' as msf = ResamplingBuffer {..}       where-        put ti1 a = return $ msfBuffer' msf $ (ti1, a) : as+        put ti1 a = return $ msfBuffer' ((ti1, a) : as) msf         get ti2   = do           (b, msf') <- unMSF msf (ti2, as)           return (b, msfBuffer msf')

@@ -1,7 +1,12 @@+{- |+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+import FRP.Rhine.ResamplingBuffer  -- | An asynchronous, effectful Mealy machine description. --   (Input and output do not happen simultaneously.)

@@ -1,3 +1,7 @@+{- |+Several utilities to create 'ResamplingBuffer's.+-}+ {-# LANGUAGE RankNTypes #-} module FRP.Rhine.ResamplingBuffer.Util where @@ -5,41 +9,43 @@ import Control.Monad.Trans.Reader (runReaderT)  -- rhine-import FRP.Rhine+import FRP.Rhine.Clock+import FRP.Rhine.ClSF+import FRP.Rhine.ResamplingBuffer  -- * Utilities to build 'ResamplingBuffer's from smaller components  infix 2 >>-^--- | Postcompose a 'ResamplingBuffer' with a matching 'SyncSF'.+-- | Postcompose a 'ResamplingBuffer' with a matching 'ClSF'. (>>-^) :: Monad m       => ResamplingBuffer m cl1 cl2 a b-      -> SyncSF           m     cl2   b c+      -> ClSF             m     cl2   b c       -> ResamplingBuffer m cl1 cl2 a   c-resBuf >>-^ syncSF = ResamplingBuffer put_ get_+resBuf >>-^ clsf = ResamplingBuffer put_ get_   where-    put_ theTimeInfo a = (>>-^ syncSF) <$> put resBuf theTimeInfo a+    put_ theTimeInfo a = (>>-^ clsf) <$> put resBuf theTimeInfo a     get_ theTimeInfo   = do       (b, resBuf') <- get resBuf theTimeInfo-      (c, syncSF') <- unMSF syncSF b `runReaderT` theTimeInfo-      return (c, resBuf' >>-^ syncSF')+      (c, clsf')   <- unMSF clsf b `runReaderT` theTimeInfo+      return (c, resBuf' >>-^ clsf')   infix 1 ^->>--- | Precompose a 'ResamplingBuffer' with a matching 'SyncSF'.+-- | Precompose a 'ResamplingBuffer' with a matching 'ClSF'. (^->>) :: Monad m-      => SyncSF           m cl1     a b+      => ClSF             m cl1     a b       -> ResamplingBuffer m cl1 cl2   b c       -> ResamplingBuffer m cl1 cl2 a   c-syncSF ^->> resBuf = ResamplingBuffer put_ get_+clsf ^->> resBuf = ResamplingBuffer put_ get_   where     put_ theTimeInfo a = do-      (b, syncSF') <- unMSF syncSF a `runReaderT` theTimeInfo-      resBuf'      <- put resBuf theTimeInfo b-      return $ syncSF' ^->> resBuf'-    get_ theTimeInfo   = second (syncSF ^->>) <$> get resBuf theTimeInfo+      (b, clsf') <- unMSF clsf a `runReaderT` theTimeInfo+      resBuf'    <- put resBuf theTimeInfo b+      return $ clsf' ^->> resBuf'+    get_ theTimeInfo   = second (clsf ^->>) <$> get resBuf theTimeInfo  -infix 4 *-*+infixl 4 *-* -- | Parallely compose two 'ResamplingBuffer's. (*-*) :: Monad m       => ResamplingBuffer m cl1 cl2  a      b@@ -56,6 +62,15 @@       (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)+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.@@ -63,4 +78,4 @@   :: Monad m   => (forall b. ResamplingBuffer m cl clf b (f b))   -> ResamplingBuffer m cl clf a (f (a, TimeInfo cl))-timestamped resBuf = (syncId &&& timeInfo) ^->> resBuf+timestamped resBuf = (clId &&& timeInfo) ^->> resBuf

@@ -1,55 +0,0 @@-{-# LANGUAGE GADTs      #-}-{-# LANGUAGE RankNTypes #-}-module FRP.Rhine.SF where----- rhine-import FRP.Rhine.Clock-import FRP.Rhine.ResamplingBuffer-import FRP.Rhine.Schedule-import FRP.Rhine.SyncSF---{- | 'SF' is an abbreviation for "signal function".-It represents a side-effectful asynchronous /__s__ignal __f__unction/, or signal network,-where input, data processing (including side effects) and output-need not happen at the same time.--The type parameters are:--* 'm': The monad in which side effects take place.-* 'cl': The clock of the whole signal network.-        It may be sequentially or parallely composed from other clocks.-* 'a': The input type. Input arrives at the rate @Leftmost cl@.-* 'b': The output type. Output arrives at the rate @Rightmost cl@.--}-data SF m cl a b where-  -- | A synchronous monadic stream function is the basic building block.-  --   For such an 'SF', data enters and leaves the system at the same rate as it is processed.-  Synchronous-    :: ( cl ~ Leftmost cl, cl ~ Rightmost cl)-    => SyncSF m cl a b-    -> SF     m cl a b-  -- | Two 'SF's may be sequentially composed if there is a matching 'ResamplingBuffer' between them.-  Sequential-    :: ( Clock m clab, Clock m clcd-       , TimeDomainOf clab ~ TimeDomainOf clcd-       , TimeDomainOf clab ~ TimeDomainOf (Rightmost clab)-       , TimeDomainOf clcd ~ TimeDomainOf (Leftmost  clcd)-       )-    => SF               m            clab                  a b-    -> ResamplingBuffer m (Rightmost clab) (Leftmost clcd)   b c-    -> SF               m                            clcd      c d-    -> SF m (SequentialClock m       clab            clcd) a     d-  -- | Two 'SF's with the same input and output data may be parallely composed.-  Parallel-    :: ( Clock m cl1, Clock m cl2-       , TimeDomainOf cl1 ~ TimeDomainOf (Rightmost cl1)-       , TimeDomainOf cl2 ~ TimeDomainOf (Rightmost cl2)-       , TimeDomainOf cl1 ~ TimeDomainOf cl2-       , TimeDomainOf cl1 ~ TimeDomainOf (Leftmost cl1)-       , TimeDomainOf cl2 ~ TimeDomainOf (Leftmost cl2)-       )-    => SF m cl1 a b-    -> SF m cl2 a b-    -> SF m (ParallelClock m cl1 cl2) a b

@@ -1,141 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts          #-}-{-# LANGUAGE TypeFamilies              #-}--{- | General mnemonic for combinators:--* @ annotates a data processing unit such as a signal function or a buffer-  with temporal information like a clock or a schedule.-* @*@ composes parallely.-* @>@ composes sequentially.--}-module FRP.Rhine.SF.Combinators where----- rhine-import FRP.Rhine.Clock-import FRP.Rhine.ResamplingBuffer-import FRP.Rhine.Reactimation-import FRP.Rhine.Schedule-import FRP.Rhine.SF-import FRP.Rhine.SyncSF----- * Combinators and syntactic sugar for high-level composition of signal functions.---infix 5 @@--- | Create a synchronous 'Rhine' by combining a synchronous SF with a matching clock.---   Synchronicity is ensured by requiring that data enters (@Leftmost cl@)---   and leaves (@Rightmost cl@) the system at the same as it is processed (@cl@).-(@@) :: ( cl ~ Leftmost cl-        , cl ~ Rightmost cl )-     => SyncSF m cl a b -> cl -> Rhine m cl a b-(@@) = Rhine . Synchronous----- | A point at which sequential asynchronous composition---   ("resampling") of signal functions can happen.-data ResamplingPoint m cla clb a b = ResamplingPoint-  (ResamplingBuffer m (Rightmost cla) (Leftmost 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,---      we sometimes need to specify particular brackets in order for it to work.---      This is confusing.---      There would be a workaround if there were pullbacks of schedules...---- | Syntactic sugar for 'ResamplingPoint'.-infix 8 -@--(-@-) :: ResamplingBuffer m (Rightmost cl1) (Leftmost 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.-infix 2 >---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-(>--) = RhineAndResamplingPoint--{- | The combinators for sequential composition allow for the following syntax:--@-rh1   :: Rhine            m            cl1                 a b-rh1   =  ...--rh2   :: Rhine            m                           cl2      c d-rh2   =  ...--rb    :: ResamplingBuffer m (Rightmost cl1) (Leftmost cl2)   b c-rb    =  ...--sched :: Schedule         m            cl1            cl2-sched =  ...--rh    :: Rhine            m (SequentialClock cl1 cl2)      a     d-rh    =  rh1 >-- rb -@- sched --> rh2-@--}-infixr 1 -->-(-->) :: ( Clock m cl1-         , Clock m cl2-         , TimeDomainOf cl1 ~ TimeDomainOf cl2-         , TimeDomainOf (Rightmost cl1) ~ TimeDomainOf cl1-         , TimeDomainOf (Leftmost  cl2) ~ TimeDomainOf cl2-         , Clock m (Rightmost cl1)-         , Clock m (Leftmost  cl2)-         )-      => RhineAndResamplingPoint   m cl1 cl2  a b-      -> Rhine m                         cl2    b c-      -> Rhine m  (SequentialClock m cl1 cl2) a   c-RhineAndResamplingPoint (Rhine sf1 cl1) (ResamplingPoint rb cc) --> (Rhine sf2 cl2)- = Rhine (Sequential sf1 rb sf2) (SequentialClock cl1 cl2 cc)---- | A purely syntactical convenience construction---   allowing for ternary syntax for parallel composition, described below.-data RhineParallelAndSchedule m cl1 cl2 a b = RhineParallelAndSchedule (Rhine m cl1 a b) (Schedule m cl1 cl2)---- | Syntactic sugar for 'RhineParallelAndSchedule'.-infix 4 **@-(**@)-  :: Rhine                    m cl1     a b-  -> Schedule                 m cl1 cl2-  -> RhineParallelAndSchedule m cl1 cl2 a b-(**@) = RhineParallelAndSchedule--{- | The combinators for parallel composition allow for the following syntax:--@-rh1   :: Rhine    m                cl1      a b-rh1   =  ...--rh2   :: Rhine    m                    cl2  a b-rh2   =  ...--sched :: Schedule m                cl1 cl2-sched =  ...--rh    :: Rhine    m (ParallelClock cl1 cl2) a b-rh    =  rh1 **\@ sched \@** rh2-@--}-infix 3 @**-(@**) :: ( Clock m cl1-          , Clock m cl2-          , TimeDomainOf cl1 ~ TimeDomainOf (Rightmost cl1)-          , TimeDomainOf cl2 ~ TimeDomainOf (Rightmost cl2)-          , TimeDomainOf cl1 ~ TimeDomainOf (Leftmost cl1)-          , TimeDomainOf cl2 ~ TimeDomainOf (Leftmost cl2)-          , TimeDomainOf cl1 ~ TimeDomainOf cl2-          )-       => RhineParallelAndSchedule m cl1 cl2 a b-       -> Rhine m cl2 a b-       -> Rhine m (ParallelClock m cl1 cl2) a b-RhineParallelAndSchedule (Rhine sf1 cl1) schedule @** (Rhine sf2 cl2)-  = Rhine (Parallel sf1 sf2) (ParallelClock cl1 cl2 schedule)

@@ -0,0 +1,63 @@+{- |+Asynchronous signal networks are combinations of clocked signal functions ('ClSF's)+and matching 'ResamplingBuffer's,+all satisfying the appropriate clock type constraints.++This module defines the 'SN' type,+combinators are found in a submodule.+-}++{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+module FRP.Rhine.SN where+++-- rhine+import FRP.Rhine.Clock+import FRP.Rhine.ClSF.Core+import FRP.Rhine.ResamplingBuffer+import FRP.Rhine.Schedule+++{- | An 'SN' is a side-effectful asynchronous /__s__ignal __n__etwork/,+where input, data processing (including side effects) and output+need not happen at the same time.++The type parameters are:++* 'm': The monad in which side effects take place.+* 'cl': The clock of the whole signal network.+        It may be sequentially or parallely composed from other clocks.+* 'a': The input type. Input arrives at the rate @In cl@.+* 'b': The output type. Output arrives at the rate @Out cl@.+-}+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+  -- | Two 'SN's may be sequentially composed if there is a matching 'ResamplingBuffer' between them.+  Sequential+    :: ( Clock m clab, Clock m 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+       , 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

@@ -0,0 +1,85 @@+{- |+Combinators for composing signal networks sequentially and parallely.+-}++{-# LANGUAGE GADTs #-}+module FRP.Rhine.SN.Combinators where+++-- rhine+import FRP.Rhine.ClSF.Core+import FRP.Rhine.ResamplingBuffer.Util+import FRP.Rhine.Schedule+import FRP.Rhine.SN+++-- | Postcompose a signal network with a pure function.+(>>>^)+  :: Monad m+  => SN m cl a b+  ->          (b -> c)+  -> SN m cl a      c+Synchronous clsf      >>>^ f = Synchronous $ clsf >>^ f+Sequential sn1 rb sn2 >>>^ f = Sequential sn1 rb     $ sn2 >>>^ f+Parallel   sn1    sn2 >>>^ f = Parallel  (sn1 >>>^ f) (sn2 >>>^ f)+++-- | Precompose a signal network with a pure function.+(^>>>)+  :: Monad m+  =>        (a -> b)+  -> SN m cl      b c+  -> SN m cl a      c+f ^>>> Synchronous clsf      = Synchronous $ f ^>> clsf+f ^>>> Sequential sn1 rb sn2 = Sequential (f ^>>> sn1) rb      sn2+f ^>>> Parallel   sn1    sn2 = Parallel   (f ^>>> sn1) (f ^>>> sn2)+++-- | Compose two signal networks on the same clock in data-parallel.+--   At one tick of @cl@, both networks are stepped.+(****)+  :: Monad m+  => SN m cl  a      b+  -> SN m cl     c      d+  -> SN m cl (a, c) (b, d)+Synchronous clsf1 **** Synchronous clsf2 = Synchronous $ clsf1 *** clsf2+Sequential sn11 rb1 sn12 **** Sequential sn21 rb2 sn22 = Sequential sn1 rb sn2+  where+    sn1 = sn11 **** sn21+    sn2 = sn12 **** sn22+    rb  = rb1 *-* rb2+Parallel sn11 sn12 **** Parallel sn21 sn22+  = Parallel (sn11 **** sn21) (sn12 **** sn22)+-- Note that the patterns above are the only ones that can occur.+-- This is ensured by the clock constraints in the SF constructors.+_ **** _ = error "Impossible pattern in ****"++-- | Compose two signal networks on different clocks in clock-parallel.+--   At one tick of @ParClock m cl1 cl2@, one of the networks is stepped,+--   dependent on which constituent clock has ticked.+--+--   Note: This is essentially an infix synonym of 'Parallel'+(||||)+  :: ( Monad m, Clock m clL, Clock m clR+     , Time clL ~ Time clR+     , Time clL ~ Time (Out clL), Time clL ~ Time (In clL)+     , Time clR ~ Time (Out clR), Time clR ~ Time (In clR)+     )+  => SN m             clL      a b+  -> SN m                 clR  a b+  -> SN m (ParClock m clL clR) a b+(||||) = Parallel++-- | Compose two signal networks on different clocks in clock-parallel.+--   At one tick of @ParClock m cl1 cl2@, one of the networks is stepped,+--   dependent on which constituent clock has ticked.+(++++)+  :: ( Monad m, Clock m clL, Clock m clR+     , Time clL ~ Time clR+     , Time clL ~ Time (Out clL), Time clL ~ Time (In clL)+     , Time clR ~ Time (Out clR), Time clR ~ Time (In clR)+     )+  => SN m             clL      a         b+  -> SN m                 clR  a           c+  -> SN m (ParClock m clL clR) a (Either b c)+snL ++++ snR = (snL >>>^ Left) |||| (snR >>>^ Right)

@@ -1,17 +1,38 @@-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE GADTs                 #-}+{- |+'Schedule's are the compatibility mechanism between two different clocks.+A schedule' implements the the universal clocks such that those two given clocks+are its subclocks.++This module defines the 'Schedule' type and certain general constructions of schedules,+such as lifting along monad morphisms or time domain morphisms.+It also supplies (sequential and parallel) compositions of clocks.++Specific implementations of schedules are found in submodules.+-}++{-# LANGUAGE Arrows #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes            #-}-{-# LANGUAGE RecordWildCards       #-}-{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}  module FRP.Rhine.Schedule where +-- base+import Data.Semigroup++-- transformers+import Control.Monad.Trans.Reader+ -- dunai import Data.MonadicStreamFunction  -- rhine import FRP.Rhine.Clock+import FRP.Rhine.Schedule.Util  -- * The schedule type @@ -19,11 +40,11 @@ --   It outputs a time stamp and an 'Either' value, --   which specifies which of the two subclocks has ticked. data Schedule m cl1 cl2-  = (TimeDomainOf cl1 ~ TimeDomainOf cl2)+  = (Time cl1 ~ Time cl2)   => Schedule-    { startSchedule+    { initSchedule         :: cl1 -> cl2-        -> m (MSF m () (TimeDomainOf cl1, Either (Tag cl1) (Tag cl2)), TimeDomainOf cl1)+        -> 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.@@ -39,10 +60,10 @@   => (forall a . m1 a -> m2 a)   -> Schedule m1 cl1 cl2   -> Schedule m2 cl1 cl2-hoistSchedule hoist Schedule {..} = Schedule startSchedule'+hoistSchedule hoist Schedule {..} = Schedule initSchedule'   where-    startSchedule' cl1 cl2 = hoist-      $ first (hoistMSF hoist) <$> startSchedule cl1 cl2+    initSchedule' cl1 cl2 = hoist+      $ first (hoistMSF hoist) <$> initSchedule cl1 cl2     hoistMSF = liftMSFPurer     -- TODO This should be a dunai issue @@ -51,66 +72,187 @@   :: Monad m   => Schedule m cl1 cl2   -> Schedule m cl2 cl1-flipSchedule Schedule {..} = Schedule startSchedule_+flipSchedule Schedule {..} = Schedule initSchedule_   where-    startSchedule_ cl2 cl1 = first (arr (second swapEither) <<<) <$> startSchedule cl1 cl2-    swapEither :: Either a b -> Either b a -- TODO Why is stuff like this not in base? Maybe send pull request...-    swapEither (Left  a) = Right a-    swapEither (Right b) = Left  b+    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)+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 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')+      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 liftMSFTrans+  <$> 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 functions.+--   for an asynchronous sequential composition of signal networks. data SequentialClock m cl1 cl2-  = TimeDomainOf cl1 ~ TimeDomainOf 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-  type TimeDomainOf (SequentialClock m cl1 cl2) = TimeDomainOf cl1-  type Tag          (SequentialClock m cl1 cl2) = Either (Tag cl1) (Tag cl2)-  startClock SequentialClock {..}-    = startSchedule sequentialSchedule sequentialCl1 sequentialCl2+  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 +-- | @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+  (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@.+schedSeq2 :: (Monad m, Semigroup cl2, Time cl1 ~ Time cl2) => Schedule m (SequentialClock m cl1 cl2) cl2+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+-- 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 functions.+--   for an asynchronous parallel composition of signal networks. data ParallelClock m cl1 cl2-  = TimeDomainOf cl1 ~ TimeDomainOf 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-  type TimeDomainOf (ParallelClock m cl1 cl2) = TimeDomainOf cl1-  type Tag          (ParallelClock m cl1 cl2) = Either (Tag cl1) (Tag cl2)-  startClock ParallelClock {..}-    = startSchedule parallelSchedule parallelCl1 parallelCl2+  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  +-- | 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+  (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@.+schedPar1' :: (Monad m, Semigroup cl1) => Schedule m cl1 (ParallelClock m cl1 cl2)+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++-- | 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+  (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++-- | 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+  (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++ -- * Navigating the clock tree  -- | The clock that represents the rate at which data enters the system.-type family Leftmost cl where-  Leftmost (SequentialClock m cl1 cl2) = Leftmost cl1-  Leftmost (ParallelClock   m cl1 cl2) = ParallelClock m (Leftmost cl1) (Leftmost cl2)-  Leftmost cl                          = cl+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  -- | The clock that represents the rate at which data leaves the system.-type family Rightmost cl where-  Rightmost (SequentialClock m cl1 cl2) = Rightmost cl2-  Rightmost (ParallelClock   m cl1 cl2) = ParallelClock m (Rightmost cl1) (Rightmost cl2)-  Rightmost cl                          = cl+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   -- | A tree representing possible last times to which@@ -122,7 +264,7 @@   ParallelLastTime     :: LastTime cl1 -> LastTime cl2     -> LastTime (ParallelClock   m cl1 cl2)-  LeafLastTime :: TimeDomainOf cl -> LastTime cl+  LeafLastTime :: Time cl -> LastTime cl   -- | An inclusion of a clock into a tree of parallel compositions of clocks.

@@ -1,33 +1,150 @@+{- |+Many clocks tick at nondeterministic times+(such as event sources),+and it is thus impossible to schedule them deterministically+with most other clocks.+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     #-}+{-# LANGUAGE TypeFamilies #-} module FRP.Rhine.Schedule.Concurrently where  -- base import Control.Concurrent+import Control.Monad (void)+import Data.IORef +-- transformers+import Control.Monad.Trans.Class++-- dunai+import Control.Monad.Trans.MSF.Except+import Control.Monad.Trans.MSF.Maybe+import Control.Monad.Trans.MSF.Writer+ -- rhine-import FRP.Rhine+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, TimeDomainOf cl1 ~ TimeDomainOf cl2) => Schedule IO cl1 cl2-concurrently =  Schedule $ \cl1 cl2 -> do+concurrently+  :: ( Clock IO cl1, Clock IO cl2+     , Time cl1 ~ Time cl2+     )+  => Schedule IO cl1 cl2+concurrently = Schedule $ \cl1 cl2 -> do   iMVar <- newEmptyMVar   mvar  <- newEmptyMVar-  _ <- forkIO $ do-    (runningClock, initTime) <- startClock cl1-    putMVar iMVar initTime-    reactimate $ runningClock >>> second (arr Left)  >>> arrM (putMVar mvar)-  _ <- forkIO $ do-    (runningClock, initTime) <- startClock cl2-    putMVar iMVar initTime-    reactimate $ runningClock >>> second (arr Right) >>> arrM (putMVar mvar)+  _ <- 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   return (arrM_ $ 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+concurrentlyWriter = Schedule $ \cl1 cl2 -> do+  iMVar <- lift newEmptyMVar+  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+  tell w1+  tell w2+  return (arrM_ (WriterT $ takeMVar mvar), initTime)+  where+    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')++-- | 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.+    errorref <- newIORef Nothing -- Used to broadcast the exception to both clocks+    _ <- 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+    let runningSchedule = arrM_ $ do+          eTick <- lift $ takeMVar mvar+          case eTick of+            Right tick -> return tick+            Left e     -> do+              lift $ writeIORef errorref $ Just e -- Broadcast the exception to both clocks+              throwE e+    return (runningSchedule, initTime)+  where+    launchSubThread cl leftright iMVar mvar errorref = forkIO $ do+      initialised <- runExceptT $ initClock cl+      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 <- arrM_ (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 $ (arrM_ $ 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)+    (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 ()

@@ -1,11 +1,17 @@+{- |+Clocks implemented in the 'ScheduleT' monad transformer+can always be scheduled (by construction).+-}+ {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RecordWildCards  #-}-{-# LANGUAGE TypeFamilies     #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-} module FRP.Rhine.Schedule.Trans where  -- rhine import Control.Monad.Schedule-import FRP.Rhine+import FRP.Rhine.Clock+import FRP.Rhine.Schedule   -- * Universal schedule for the 'ScheduleT' monad transformer@@ -15,18 +21,18 @@ --   Indeed, this is the purpose for which 'ScheduleT' was defined. schedule   :: ( Monad m-     , Clock (ScheduleT (Diff (TimeDomainOf cl1)) m) cl1-     , Clock (ScheduleT (Diff (TimeDomainOf cl1)) m) cl2-     , TimeDomainOf cl1 ~ TimeDomainOf cl2-     , Ord (Diff (TimeDomainOf cl1))-     , Num (Diff (TimeDomainOf cl1))+     , 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 (TimeDomainOf cl1)) m) cl1 cl2+  => Schedule (ScheduleT (Diff (Time cl1)) m) cl1 cl2 schedule = Schedule {..}   where-    startSchedule cl1 cl2 = do-      (runningClock1, initTime) <- startClock cl1-      (runningClock2, _)        <- startClock cl2+    initSchedule cl1 cl2 = do+      (runningClock1, initTime) <- initClock cl1+      (runningClock2, _)        <- initClock cl2       return         ( runningSchedule cl1 cl2 runningClock1 runningClock2         , initTime@@ -35,31 +41,31 @@     -- Combines the two individual running clocks to one running clock.     runningSchedule       :: ( Monad m-         , Clock (ScheduleT (Diff (TimeDomainOf cl1)) m) cl1-         , Clock (ScheduleT (Diff (TimeDomainOf cl2)) m) cl2-         , TimeDomainOf cl1 ~ TimeDomainOf cl2-         , Ord (Diff (TimeDomainOf cl1))-         , Num (Diff (TimeDomainOf cl1))+         , 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 (TimeDomainOf cl1)) m) () (TimeDomainOf cl1, Tag cl1)-      -> MSF (ScheduleT (Diff (TimeDomainOf cl1)) m) () (TimeDomainOf cl2, Tag cl2)-      -> MSF (ScheduleT (Diff (TimeDomainOf cl1)) m) () (TimeDomainOf cl1, Either (Tag cl1) (Tag 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  (((td, tag1), rc1'), cont2) -> return+        Left  (((time, tag1), rc1'), cont2) -> return           -- so we can emit its time stamp...-          ( (td, Left tag1)+          ( (time, Left tag1)           -- and continue.           , runningSchedule cl1 cl2 rc1' (MSF $ const cont2)           )         -- The second clock ticks first...-        Right (cont1, ((td, tag2), rc2')) -> return+        Right (cont1, ((time, tag2), rc2')) -> return           -- so we can emit its time stamp...-          ( (td, Right tag2)+          ( (time, Right tag2)           -- and continue.           , runningSchedule cl1 cl2 (MSF $ const cont1) rc2'           )

@@ -0,0 +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.+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, 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

@@ -1,240 +0,0 @@-{-# LANGUAGE Arrows           #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes       #-}-{-# LANGUAGE RecordWildCards  #-}-{-# LANGUAGE TypeFamilies     #-}--module FRP.Rhine.SyncSF where----- base-import Control.Arrow-import Control.Category (Category)-import qualified Control.Category (id)---- transformers-import Control.Monad.Trans.Reader-  (ReaderT, ask, asks, mapReaderT, withReaderT)---- dunai-import Data.MonadicStreamFunction-  (MSF, liftMSFPurer, liftMSFTrans, arrM, arrM_, sumFrom, delay, feedback)-import Data.VectorSpace---- rhine-import FRP.Rhine.Clock-import FRP.Rhine.TimeDomain----- * Synchronous signal functions and behaviours---- | A (synchronous) monadic stream function---   with the additional side effect of being time-aware,---   that is, reading the current 'TimeInfo' of the clock @cl@.-type SyncSF m cl a b = MSF (ReaderT (TimeInfo cl) m) a b---- | A synchronous signal is a 'SyncSF' with no input required.---   It produces its output on its own.-type SyncSignal m cl a = SyncSF m cl () a---- | A (side-effectful) behaviour is a time-aware stream---   that doesn't depend on a particular clock.---   @td@ denotes the 'TimeDomain'.-type Behaviour m td a = forall cl. td ~ TimeDomainOf cl => SyncSignal m cl a---- | Compatibility to U.S. american spelling.-type Behavior  m td a = Behaviour m td a---- | A (side-effectful) behaviour function is a time-aware synchronous stream---   function that doesn't depend on a particular clock.---   @td@ denotes the 'TimeDomain'.-type BehaviourF m td a b = forall cl. td ~ TimeDomainOf cl => SyncSF m cl a b---- | Compatibility to U.S. american spelling.-type BehaviorF  m td a b = BehaviourF m td a b----- * Utilities to create 'SyncSF's from simpler data---- TODO Test in which situations it makes sense not to change cl--- | Hoist a 'SyncSF' along a monad morphism.-hoistSyncSF-  :: (Monad m1, Monad m2)-  => (forall c. m1 c -> m2 c)-  -> SyncSF m1 cl a b-  -> SyncSF m2 (HoistClock m1 m2 cl) a b-hoistSyncSF hoist = liftMSFPurer $ withReaderT (retag id) . mapReaderT hoist---- | A monadic stream function without dependency on time---   is a 'SyncSF' for any clock.-timeless :: Monad m => MSF m a b -> SyncSF m cl a b-timeless = liftMSFTrans---- | Utility to lift Kleisli arrows directly to 'SyncSF's.-arrMSync :: Monad m => (a -> m b) -> SyncSF m cl a b-arrMSync = timeless . arrM---- | Version without input.-arrMSync_ :: Monad m => m b -> SyncSF m cl a b-arrMSync_ = timeless . arrM_---- | Read the environment variable, i.e. the 'TimeInfo'.-timeInfo :: Monad m => SyncSF m cl a (TimeInfo cl)-timeInfo = arrM_ ask--{- | Utility to apply functions to the current 'TimeInfo',-such as record selectors:-@-printAbsoluteTime :: SyncSF IO cl () ()-printAbsoluteTime = timeInfoOf absolute >>> arrMSync print-@--}-timeInfoOf :: Monad m => (TimeInfo cl -> b) -> SyncSF m cl a b-timeInfoOf f = arrM_ $ asks f---- * 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.:--> syncsf1 >-> syncsf2 @@ clA **@ sched @** syncsf3 >-> syncsf4 @@ clB--The type signature specialises e.g. to--> (>->) :: Monad m => SyncSF m cl a b -> SyncSF m cl b c -> SyncSF m cl a c--}-infixr 6 >->-(>->) :: 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-(<-<) = (<<<)--{- | Output a constant value.-Specialises e.g. to this type signature:--> arr_ :: Monad m => b -> SyncSF m cl a b--}-arr_ :: Arrow a => b -> a c b-arr_ = arr . const----- | The identity synchronous stream function.-syncId :: Monad m => SyncSF m cl a a-syncId = Control.Category.id----- * Basic signal processing components---- | The output of @integralFrom v0@ is the numerical Euler integral---   of the input, with initial offset @v0@.-integralFrom-  :: ( Monad m, VectorSpace v-     , Groundfield v ~ Diff td)-  => v -> BehaviorF m td v v-integralFrom v0 = proc v -> do-  _sinceTick <- timeInfoOf sinceTick -< ()-  sumFrom v0                         -< _sinceTick *^ v---- | Euler integration, with zero initial offset.-integral-  :: ( Monad m, VectorSpace v-     , Groundfield v ~ 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-     , Groundfield v ~ Diff td)-  => v -> BehaviorF m td v v-derivativeFrom v0 = proc v -> do-  vLast         <- delay v0 -< v-  TimeInfo {..} <- timeInfo -< ()-  returnA                   -< (v ^-^ vLast) ^/ sinceTick---- | Numerical derivative with input initialised to zero.-derivative-  :: ( Monad m, VectorSpace v-     , Groundfield v ~ Diff td)-  => BehaviorF m td v v-derivative = derivativeFrom zeroVector---- | 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-     , Groundfield v ~ Diff td)-  => v -- ^ The initial position-  -> BehaviorF m td (v, Groundfield v) 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 scale.-averageFrom-  :: ( Monad m, VectorSpace v-     , Floating (Groundfield v)-     , Groundfield v ~ Diff td)-  => v -- ^ The initial position-  -> Diff td -- ^ The time scale on which the signal is averaged-  -> BehaviorF m td v v-averageFrom v0 t = proc v -> do-  TimeInfo {..} <- timeInfo -< ()-  let-    weight = exp $ - (sinceTick / t)-  weightedAverageFrom v0    -< (v, weight)----- | An average, or low pass, initialised to zero.-average-  :: ( Monad m, VectorSpace v-     , Floating (Groundfield v)-     , Groundfield v ~ Diff td)-  => Diff td -- ^ The time scale on which the signal is averaged-  -> 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-     , Groundfield v ~ Diff td)-  => v -- ^ The initial position-  -> Diff td -- ^ The time scale on which the signal is averaged-  -> BehaviourF m td v v-averageLinFrom v0 t = proc v -> do-  TimeInfo {..} <- timeInfo -< ()-  let-    weight = t / (sinceTick + t)-  weightedAverageFrom v0    -< (v, weight)---- | Linearised version of 'average'.-averageLin-  :: ( Monad m, VectorSpace v-     , Groundfield v ~ Diff td)-  => Diff td -- ^ The time scale on which the signal is averaged-  -> BehaviourF m td v v-averageLin = averageLinFrom zeroVector

@@ -1,128 +0,0 @@-{-# LANGUAGE Arrows           #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes       #-}-{-# LANGUAGE TypeFamilies     #-}--module FRP.Rhine.SyncSF.Except-  ( module FRP.Rhine.SyncSF.Except-  , module X-  , safe, safely, Empty, exceptS, runMSFExcept-  )-  where---- transformers-import Control.Monad.Trans.Class (lift)-import Control.Monad.Trans.Except as X-import Control.Monad.Trans.Reader---- dunai-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-import FRP.Rhine.SyncSF.Except.Util---- * Types--{- | A synchronous exception-throwing signal function.-It is based on a @newtype@, 'MSFExcept',-to exhibit a monad interface /in the exception type/.-`return` then corresponds to throwing an exception,-and `(>>=)` is exception handling.-(For more information, see the documentation of 'MSFExcept'.)--* @m@:  The monad that the signal function may take side effects in-* @cl@: The clock on which the signal function ticks-* @a@:  The input type-* @b@:  The output type-* @e@:  The type of exceptions that can be thrown--}-type SyncExcept m cl a b e = MSFExcept (ReaderT (TimeInfo cl) m) a b e--{- | A clock polymorphic 'SyncExcept'.-Any clock with time domain @td@ may occur.--}-type BehaviourFExcept m td a b e-  = forall cl. td ~ TimeDomainOf cl => SyncExcept m cl a b e---- | Compatibility to U.S. american spelling.-type BehaviorFExcept m td a b e = BehaviourFExcept m td a b e----commuteExceptReader :: ExceptT e (ReaderT r m) a -> ReaderT r (ExceptT e m) a-commuteExceptReader a = ReaderT $ \r -> ExceptT $ runReaderT (runExceptT a) r--runSyncExcept :: Monad m => SyncExcept m cl a b e -> SyncSF (ExceptT e m) cl a b-runSyncExcept = liftMSFPurer commuteExceptReader . runMSFExcept---- | Enter the monad context in the exception---   for |SyncSF|s in the |ExceptT| monad.---   The 'SyncSF' will be run until it encounters an exception.-try :: Monad m => SyncSF (ExceptT e m) cl a b -> SyncExcept m cl a b e-try = MSFE.try . liftMSFPurer commuteReaderExcept---- | Within the same tick, perform a monadic action,---   and immediately throw the value as an exception.-once :: Monad m => (a -> m e) -> SyncExcept m cl a b e-once f = MSFE.once $ lift . f---- | A variant of |once| without input.-once_ :: Monad m => m e -> SyncExcept m cl a b e-once_ = once . const---- | Immediately throw the exception on the input.-throwS :: Monad m => SyncSF (ExceptT e m) cl e a-throwS = arrMSync throwE---- | Throw the given exception when the 'Bool' turns true.-throwOn :: Monad m => e -> SyncSF (ExceptT e m) cl Bool ()-throwOn e = proc b -> throwOn' -< (b, e)---- | Variant of 'throwOn', where the exception can vary every tick.-throwOn' :: Monad m => SyncSF (ExceptT e m) cl (Bool, e) ()-throwOn' = proc (b, e) -> if b-  then throwS  -< e-  else returnA -< ()----- | Advances a single tick with the given Kleisli arrow,---   and then throws an exception.-step :: Monad m => (a -> m (b, e)) -> SyncExcept m cl a b e-step f = MSFE.step $ lift . f---- | Remembers and indefinitely outputs the first input value.-keepFirst :: Monad m => SyncSF m cl a a-keepFirst = safely $ do-  a <- try throwS-  safe $ arr $ const a----- | Throws an exception after the specified time difference,---   outputting the remaining time difference.-timer-  :: ( Monad m-     , TimeDomain td-     , Ord (Diff td)-     )-  => Diff td-  -> BehaviorF (ExceptT () m) td a (Diff td)-timer diff = proc _ -> do-  time      <- timeInfoOf absolute -< ()-  startTime <- keepFirst           -< time-  let remainingTime = time `diffTime` startTime-  _         <- throwOn ()          -< remainingTime > diff-  returnA                          -< remainingTime---- | 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 diff = timer diff >>> arr (/ diff)

@@ -1,12 +0,0 @@-{-| Utilities for 'FRP.Rhine.SyncSF.Except' that need not be exported.--}-module FRP.Rhine.SyncSF.Except.Util where---- transformers-import Control.Monad.Trans.Except-import Control.Monad.Trans.Reader----- | Commute the effects of the |ReaderT| and the |ExceptT| monad.-commuteReaderExcept :: ReaderT r (ExceptT e m) a -> ExceptT e (ReaderT r m) a-commuteReaderExcept a = ExceptT $ ReaderT $ \r -> runExceptT $ runReaderT a r

@@ -1,6 +1,12 @@-{-# LANGUAGE FlexibleInstances          #-}+{- |+This module defines the 'TimeDomain' class.+Its instances model time.+Several instances such as 'UTCTime', 'Double' and 'Integer' are supplied here.+-}++{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeFamilies #-} module FRP.Rhine.TimeDomain   ( module FRP.Rhine.TimeDomain   , UTCTime@@ -16,9 +22,9 @@  -- | A time domain is an affine space representing a notion of time, --   such as real time, simulated time, steps, or a completely different notion.-class TimeDomain td where-  type Diff td-  diffTime :: td -> td -> Diff td+class TimeDomain time where+  type Diff time+  diffTime :: time -> time -> Diff time   instance TimeDomain UTCTime where

@@ -0,0 +1,21 @@+{- |+The type of a complete Rhine program:+A signal network together with a matching clock value.+-}++module FRP.Rhine.Type where++import FRP.Rhine.SN++{- |+A 'Rhine' consists of un 'SN' together with a clock of matching type 'cl'.+It is a reactive program, possibly with open inputs and outputs.+If the input and output types 'a' and 'b' are both '()',+that is, the 'Rhine' is "closed",+then it is a standalone reactive program+that can be run with the function 'flow'.+-}+data Rhine m cl a b = Rhine+  { sn    :: SN m cl a b+  , clock :: cl+  }