rhine 0.7.1 → 1.8
raw patch · 66 files changed
Files
- ChangeLog.md +70/−4
- Setup.hs +1/−0
- bench/Main.hs +9/−0
- bench/Sum.hs +66/−0
- bench/Test.hs +31/−0
- bench/WordCount.hs +146/−0
- bench/pg100.txt too large to diff
- rhine.cabal +164/−59
- src/Control/Monad/Schedule.hs +0/−109
- src/FRP/Rhine.hs +30/−31
- src/FRP/Rhine/ClSF.hs +4/−6
- src/FRP/Rhine/ClSF/Core.hs +69/−65
- src/FRP/Rhine/ClSF/Except.hs +70/−62
- src/FRP/Rhine/ClSF/Except/Util.hs +1/−2
- src/FRP/Rhine/ClSF/Random.hs +59/−60
- src/FRP/Rhine/ClSF/Random/Util.hs +0/−2
- src/FRP/Rhine/ClSF/Reader.hs +37/−28
- src/FRP/Rhine/ClSF/Upsample.hs +39/−36
- src/FRP/Rhine/ClSF/Util.hs +262/−203
- src/FRP/Rhine/Clock.hs +142/−116
- src/FRP/Rhine/Clock/Except.hs +214/−0
- src/FRP/Rhine/Clock/FixedStep.hs +41/−55
- src/FRP/Rhine/Clock/Periodic.hs +49/−46
- src/FRP/Rhine/Clock/Proxy.hs +42/−38
- src/FRP/Rhine/Clock/Realtime.hs +94/−0
- src/FRP/Rhine/Clock/Realtime/Audio.hs +59/−52
- src/FRP/Rhine/Clock/Realtime/Busy.hs +15/−7
- src/FRP/Rhine/Clock/Realtime/Event.hs +64/−83
- src/FRP/Rhine/Clock/Realtime/Millisecond.hs +37/−76
- src/FRP/Rhine/Clock/Realtime/Never.hs +38/−0
- src/FRP/Rhine/Clock/Realtime/Stdin.hs +16/−10
- src/FRP/Rhine/Clock/Select.hs +46/−65
- src/FRP/Rhine/Clock/Skip.hs +22/−0
- src/FRP/Rhine/Clock/Trivial.hs +19/−0
- src/FRP/Rhine/Clock/Util.hs +27/−13
- src/FRP/Rhine/Reactimation.hs +45/−32
- src/FRP/Rhine/Reactimation/ClockErasure.hs +58/−89
- src/FRP/Rhine/Reactimation/Combinators.hs +135/−127
- src/FRP/Rhine/ResamplingBuffer.hs +64/−34
- src/FRP/Rhine/ResamplingBuffer/ClSF.hs +45/−0
- src/FRP/Rhine/ResamplingBuffer/Collect.hs +35/−26
- src/FRP/Rhine/ResamplingBuffer/FIFO.hs +22/−17
- src/FRP/Rhine/ResamplingBuffer/Interpolation.hs +76/−56
- src/FRP/Rhine/ResamplingBuffer/KeepLast.hs +14/−9
- src/FRP/Rhine/ResamplingBuffer/LIFO.hs +22/−17
- src/FRP/Rhine/ResamplingBuffer/MSF.hs +0/−39
- src/FRP/Rhine/ResamplingBuffer/Timeless.hs +41/−32
- src/FRP/Rhine/ResamplingBuffer/Util.hs +152/−53
- src/FRP/Rhine/SN.hs +140/−52
- src/FRP/Rhine/SN/Combinators.hs +39/−29
- src/FRP/Rhine/SN/Type.hs +30/−0
- src/FRP/Rhine/Schedule.hs +120/−233
- src/FRP/Rhine/Schedule/Concurrently.hs +0/−150
- src/FRP/Rhine/Schedule/Trans.hs +0/−74
- src/FRP/Rhine/Schedule/Util.hs +0/−20
- src/FRP/Rhine/TimeDomain.hs +0/−52
- src/FRP/Rhine/Type.hs +43/−15
- test/Clock.hs +17/−0
- test/Clock/Except.hs +185/−0
- test/Clock/FixedStep.hs +69/−0
- test/Clock/Millisecond.hs +68/−0
- test/Except.hs +42/−0
- test/Main.hs +18/−0
- test/Schedule.hs +56/−0
- test/Util.hs +15/−0
- test/assets/testdata.txt +2/−0
ChangeLog.md view
@@ -1,13 +1,79 @@ # 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`.+## 1.8 -## 0.7.1+* Remove dependency on `monad-schedule` because of performance problems.+ See https://github.com/turion/rhine/issues/377.+* Added scheduling for automata in `Data.Automaton.Schedule`.+* Removed `SN` GADT in favour of semantic functions, for a > 100x speedup in some benchmarks+ (https://github.com/turion/rhine/pull/348) +## 1.6++* Support GHC 9.12+* Replace 'SN' GADT definition by newtype. Thanks to András Kovács for the suggestion.++## 1.5++* Added `forever` utility for recursion in `ClSFExcept`+* Support GHC 9.10++## 1.4++* Add `Profunctor` instance for `ResamplingBuffer`+* Fix imports of `FRP.Rhine` prelude+* Add `UTCClock` and `WaitUTCClock`, corresponding refactorings+* Remove unreliable `downsampleMillisecond` `ResamplingBuffer`++## 1.3++* Dropped `dunai` dependency in favour of state automata.+ See [the versions readme](./versions.md) for details.+* Moved the monad argument `m` in `ClSFExcept`:+ It is now `ClSFExcept cl a b m e` instead of `ClSFExcept m cl a b e`.+ The advantage is that now the type is an instance of `MonadTrans` and `MFunctor`.+ Analogous changes have been made to `BehaviourFExcept`.+* Support GHC 9.6 and 9.8++## 1.2.1++* Added `FRP.Rhine.Clock.Realtime.Never` (clock that never ticks)+* Changed Busy clock effect to `MonadIO`++## 1.2++* Changed Stdin clock Tag type to Text++## 1.1++* dunai-0.11 compatibility++## 1.0++* Removed schedules. See the [page about changes in version 1](/version1.md).++## 0.9++* dunai-0.9 compatibility++## 0.8.1.1++* Support for GHC 9.4.4++## 0.8.1++* Support for GHC 9.2.4+* Added `FirstResampling` and `Feedback` constructors to `SN`+* Added rhine-terminal++## 0.8.0.0+ * Documentation improvements * Support for GHC 9.0.2+* Updated to `dunai-0.8`+* Added functions to pre-/post-compose SNs and Rhines with ClSFs+* Added flake & stack support on CI.+ Thank you, Miguel Negrão and Jun Matsushita! ## 0.7.0
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
+ bench/Main.hs view
@@ -0,0 +1,9 @@+-- criterion+import Criterion.Main++-- rhine+import Sum+import WordCount++main :: IO ()+main = defaultMain [WordCount.benchmarks, Sum.benchmarks]
+ bench/Sum.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE PackageImports #-}++{- | Sums up natural numbers.++First create a lazy list [0, 1, 2, ...] and then sum over it.+Most of the implementations really benchmark 'embed', as the lazy list is created using it.+-}+module Sum where++import "base" Control.Monad (foldM)+import "base" Data.Functor.Identity+import "base" Data.Void (absurd)++import "criterion" Criterion.Main++import "automaton" Data.Stream as Stream (StreamT (..))+import "automaton" Data.Stream.Optimized (OptimizedStreamT (Stateful))+import "rhine" FRP.Rhine++nMax :: Int+nMax = 1_000_000++benchmarks :: Benchmark+benchmarks =+ bgroup+ "Sum"+ [ bench "rhine" $ nf rhine nMax+ , bench "rhine flow" $ nf rhineFlow nMax+ , bench "automaton" $ nf automaton nMax+ , bench "direct" $ nf direct nMax+ , bench "direct monad" $ nf directM nMax+ ]++rhine :: Int -> Int+rhine n = sum $ runIdentity $ embed count $ replicate n ()++-- FIXME separate ticket to improve performance of this+rhineFlow :: Int -> Int+rhineFlow n =+ either id absurd $+ flow $+ (@@ Trivial) $ proc () -> do+ k <- count -< ()+ s <- sumN -< k+ if k < n+ then returnA -< ()+ else arrMCl Left -< s++automaton :: Int -> Int+automaton n = sum $ runIdentity $ embed myCount $ replicate n ()+ where+ myCount :: Automaton Identity () Int+ myCount =+ Automaton $+ Stateful+ StreamT+ { state = 1+ , Stream.step = \s -> return $! Result (s + 1) s+ }++direct :: Int -> Int+direct n = sum [0 .. n]++directM :: Int -> Int+directM n = runIdentity $ foldM (\a b -> return $ a + b) 0 [0 .. n]
+ bench/Test.hs view
@@ -0,0 +1,31 @@+-- rhine++import Sum+import WordCount++-- tasty+import Test.Tasty++-- tasty-hunit+import Test.Tasty.HUnit (testCase, (@?=))++-- | The number of words in Project Gutenberg's edition of Shakespeare's complete works.+wordCount :: Int+wordCount = 966503++main :: IO ()+main =+ defaultMain $+ testGroup+ "Benchmark tests"+ [ testGroup+ "WordCount"+ [ testCase "rhine" $ rhineWordCount >>= (@?= wordCount)+ ]+ , testGroup+ "Sum"+ [ testCase "rhine" $ Sum.rhine Sum.nMax @?= Sum.direct Sum.nMax+ , testCase "automaton" $ Sum.automaton Sum.nMax @?= Sum.direct Sum.nMax+ , testCase "rhine flow" $ Sum.rhineFlow Sum.nMax @?= Sum.direct Sum.nMax+ ]+ ]
+ bench/WordCount.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Count the number of words in the complete works of Shakespeare.+module WordCount where++-- base+import Control.Exception+import Data.IORef (modifyIORef', newIORef, readIORef)+import Data.Monoid (Sum (..))+import GHC.IO.Handle hiding (hGetContents)+import System.IO (IOMode (ReadMode), openFile, stdin, withFile)+import System.IO.Error (isEOFError)+import Prelude hiding (getContents, getLine, words)++-- text+import Data.Text (words)+import Data.Text.IO (getLine)+import Data.Text.Lazy qualified as Lazy+import Data.Text.Lazy.IO (hGetContents)++-- criterion+import Criterion.Main++-- automaton+import Data.Automaton.Trans.Except qualified as Automaton++-- rhine+import FRP.Rhine+import FRP.Rhine.Clock.Except (+ DelayIOError,+ ExceptClock (..),+ delayIOError,+ )+import Paths_rhine++-- * Top level benchmarks++benchmarks :: Benchmark+benchmarks =+ bgroup+ "WordCount"+ [ bench "rhine" $ nfIO rhineWordCount+ , bench "automaton" $ nfIO automatonWordCount+ , bgroup+ "Text"+ [ bench "IORef" $ nfIO textWordCount+ , bench "no IORef" $ nfIO textWordCountNoIORef+ , bench "Lazy" $ nfIO textLazy+ ]+ ]++-- * Benchmark helpers++-- | The path to Shakespeare's complete works+testFile :: IO FilePath+testFile = getDataFileName "bench/pg100.txt"++-- | Provide Shakespeare's complete works on stdin+withInput :: IO b -> IO b+withInput action = do+ inputFileName <- testFile+ withFile inputFileName ReadMode $ \stdinFile -> do+ hDuplicateTo stdinFile stdin+ action++-- * Frameworks specific implementations of word count++-- | Idiomatic Rhine implementation with a single clock+rhineWordCount :: IO Int+rhineWordCount = do+ Left (Right nWords) <- withInput $ runExceptT $ flow $ wc @@ delayIOError (ExceptClock StdinClock) Left+ return nWords+ where+ wc :: ClSF (ExceptT (Either IOError Int) IO) (DelayIOError (ExceptClock StdinClock IOError) (Either IOError Int)) () ()+ wc = proc _ -> do+ lineOrStop <- tagS -< ()+ nWords <- mappendS -< either (const 0) (Sum . length . words) lineOrStop+ throwOn' -< (either isEOFError (const False) lineOrStop, Right $ getSum nWords)++{- | Implementation using automata.++Within the automata framework, this is what the Rhine implementation could optimize to at most,+if all the extra complexity introduced by clocks is optimized away completely.+-}+automatonWordCount :: IO Int+automatonWordCount = do+ Left (Right nWords) <- withInput $ runExceptT $ reactimate wc+ return nWords+ where+ wc = proc () -> do+ lineOrEOF <- constM $ liftIO $ Control.Exception.try getLine -< ()+ nWords <- mappendS -< either (const 0) (Sum . length . words) lineOrEOF+ case lineOrEOF of+ Right _ -> returnA -< ()+ Left e ->+ Automaton.throwS -< if isEOFError e then Right $ getSum nWords else Left e++-- ** Reference implementations in Haskell++{- | The fastest line-based word count implementation that I could think of.++Except for the way the IORef is handled,+this is what 'rhineWordCount' would reduce to roughly if all possible optimizations kick in,+and automata don't add any overhead.+-}+textWordCount :: IO Int+textWordCount = do+ wcOut <- newIORef (0 :: Int)+ catch (withInput $ go wcOut) $ \(e :: IOError) ->+ if isEOFError e+ then return ()+ else throwIO e+ readIORef wcOut+ where+ go wcOut = do+ line <- getLine+ modifyIORef' wcOut (+ length (words line))+ go wcOut++{- | The fastest line-based word count implementation that I could think of, not using IORefs.++This is what 'rhineWordCount' would reduce to roughly, if all possible optimizations kick in.+It is a bit slower than the version with IORef.+-}+textWordCountNoIORef :: IO Int+textWordCountNoIORef = do+ withInput $ go 0+ where+ processLine n = do+ line <- getLine+ return $ Right $ n + length (words line)+ go n = do+ n' <- catch (processLine n) $+ \(e :: IOError) ->+ if isEOFError e+ then return $ Left n+ else throwIO e+ either return go n'++-- | Just for fun the probably most readable but not the fastest way to count the number of words.+textLazy :: IO Int+textLazy = do+ inputFileName <- testFile+ h <- openFile inputFileName ReadMode+ length . Lazy.words <$> hGetContents h
+ bench/pg100.txt view
file too large to diff
rhine.cabal view
@@ -1,9 +1,7 @@-name: rhine--version: 0.7.1-+cabal-version: 2.2+name: rhine+version: 1.8 synopsis: Functional Reactive Programming with type-level clocks- description: Rhine is a library for synchronous and asynchronous Functional Reactive Programming (FRP). It separates the aspects of clocking, scheduling and resampling@@ -20,107 +18,214 @@ A (synchronous) program outputting "Hello World!" every tenth of a second looks like this: @flow $ constMCl (putStrLn "Hello World!") \@\@ (waitClock :: Millisecond 100)@ --license: BSD3--license-file: LICENSE--author: Manuel Bärenz+license: BSD-3-Clause+license-file: LICENSE+author: Manuel Bärenz+maintainer: maths@manuelbaerenz.de+category: FRP+build-type: Simple+extra-source-files: ChangeLog.md+extra-doc-files: README.md+data-files:+ bench/pg100.txt+ test/assets/*.txt -maintainer: maths@manuelbaerenz.de+tested-with:+ ghc ==9.6+ ghc ==9.8+ ghc ==9.10+ ghc ==9.12 -category: FRP+source-repository head+ type: git+ location: https://github.com/turion/rhine.git -build-type: Simple+source-repository this+ type: git+ location: https://github.com/turion/rhine.git+ tag: v1.6 -extra-source-files: ChangeLog.md+common opts+ build-depends:+ automaton ^>=1.8,+ base >=4.18 && <4.22,+ mtl >=2.2 && <2.4,+ selective ^>=0.7,+ text >=1.2 && <2.2,+ time >=1.8,+ time-domain ^>=1.8,+ transformers >=0.5,+ vector-sized >=1.4, -extra-doc-files: README.md+ if flag(dev)+ ghc-options: -Werror+ ghc-options:+ -W+ -Wno-unticked-promoted-constructors -cabal-version: 1.18+ default-extensions:+ Arrows+ DataKinds+ FlexibleContexts+ FlexibleInstances+ ImportQualifiedPost+ MultiParamTypeClasses+ NamedFieldPuns+ NoStarIsType+ TupleSections+ TypeApplications+ TypeFamilies+ TypeOperators -source-repository head- type: git- location: git@github.com:turion/rhine.git+ -- Base language which the package is written in.+ default-language: Haskell2010 -source-repository this- type: git- location: git@github.com:turion/rhine.git- tag: v0.7.1+common test-deps+ build-depends:+ QuickCheck >=2.14 && <2.16,+ tasty >=1.4 && <1.6,+ tasty-hunit ^>=0.10,+ tasty-quickcheck >=0.10 && <1.12, +common bench-deps+ build-depends:+ criterion ^>=1.6 library+ import: opts exposed-modules:- Control.Monad.Schedule FRP.Rhine+ FRP.Rhine.ClSF+ FRP.Rhine.ClSF.Core+ FRP.Rhine.ClSF.Except+ FRP.Rhine.ClSF.Random+ FRP.Rhine.ClSF.Reader+ FRP.Rhine.ClSF.Upsample+ FRP.Rhine.ClSF.Util FRP.Rhine.Clock+ FRP.Rhine.Clock.Except FRP.Rhine.Clock.FixedStep FRP.Rhine.Clock.Periodic FRP.Rhine.Clock.Proxy+ FRP.Rhine.Clock.Realtime FRP.Rhine.Clock.Realtime.Audio FRP.Rhine.Clock.Realtime.Busy FRP.Rhine.Clock.Realtime.Event FRP.Rhine.Clock.Realtime.Millisecond+ FRP.Rhine.Clock.Realtime.Never FRP.Rhine.Clock.Realtime.Stdin FRP.Rhine.Clock.Select+ FRP.Rhine.Clock.Skip+ FRP.Rhine.Clock.Trivial FRP.Rhine.Clock.Util- FRP.Rhine.ClSF- FRP.Rhine.ClSF.Core- FRP.Rhine.ClSF.Except- FRP.Rhine.ClSF.Random- FRP.Rhine.ClSF.Reader- FRP.Rhine.ClSF.Upsample- FRP.Rhine.ClSF.Util FRP.Rhine.Reactimation FRP.Rhine.Reactimation.ClockErasure FRP.Rhine.Reactimation.Combinators FRP.Rhine.ResamplingBuffer+ FRP.Rhine.ResamplingBuffer.ClSF 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.SN FRP.Rhine.SN.Combinators- FRP.Rhine.TimeDomain+ FRP.Rhine.SN.Type+ FRP.Rhine.Schedule FRP.Rhine.Type other-modules:- FRP.Rhine.ClSF.Random.Util FRP.Rhine.ClSF.Except.Util- FRP.Rhine.Schedule.Util+ FRP.Rhine.ClSF.Random.Util -- LANGUAGE extensions used by modules in this package. -- other-extensions:- -- Other library packages from which modules are imported.- build-depends: base >= 4.11 && < 4.16- , dunai >= 0.6- , transformers >= 0.5- , time >= 1.8- , free >= 5.1- , containers >= 0.5- , vector-sized >= 1.4- , deepseq >= 1.4- , random >= 1.1- , MonadRandom >= 0.5- , simple-affine-space+ build-depends:+ MonadRandom >=0.5,+ containers >=0.5,+ deepseq >=1.4,+ foldable1-classes-compat ^>=0.1,+ free >=5.1,+ mmorph ^>=1.2,+ profunctors ^>=5.6,+ random >=1.1,+ simple-affine-space ^>=0.2,+ text >=1.2 && <2.2,+ time >=1.8,+ transformers >=0.5, -- Directories containing source files.- hs-source-dirs: src+ hs-source-dirs: src - ghc-options: -Wall- -Wno-unticked-promoted-constructors- -Wno-type-defaults+test-suite test+ import: opts, test-deps+ hs-source-dirs: test+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ Clock+ Clock.Except+ Clock.FixedStep+ Clock.Millisecond+ Except+ Paths_rhine+ Schedule+ Util - if impl(ghc >= 8.6)- default-extensions: NoStarIsType+ autogen-modules: Paths_rhine+ build-depends:+ rhine - -- Base language which the package is written in.- default-language: Haskell2010+flag dev+ description: Enable warnings as errors. Active on ci.+ default: False+ manual: True++benchmark benchmark+ import: opts, bench-deps+ type: exitcode-stdio-1.0+ hs-source-dirs: bench+ autogen-modules: Paths_rhine+ other-modules:+ Paths_rhine+ Sum+ WordCount++ build-depends:+ rhine++ main-is: Main.hs+ ghc-options:+ -Wall++ if flag(core)+ ghc-options:+ -fforce-recomp+ -ddump-to-file+ -ddump-simpl+ -dsuppress-all+ -dno-suppress-type-signatures+ -dno-suppress-type-applications++test-suite benchmark-test+ import: opts, bench-deps, test-deps+ type: exitcode-stdio-1.0+ hs-source-dirs: bench+ autogen-modules: Paths_rhine+ other-modules:+ Paths_rhine+ Sum+ WordCount++ build-depends:+ rhine++ main-is: Test.hs++flag core+ description: Dump GHC core files for debugging.+ default: False+ manual: True
− src/Control/Monad/Schedule.hs
@@ -1,109 +0,0 @@-{- |-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----- base-import Control.Concurrent---- transformers-import Control.Monad.IO.Class---- free-import Control.Monad.Trans.Free----- TODO Implement Time via StateT--{- |-A functor implementing a syntactical "waiting" action.--* 'diff' represents the duration to wait.-* 'a' is the encapsulated value.--}-data Wait diff a = Wait diff a- deriving Functor--{- |-Values in @ScheduleT diff m@ are delayed computations with side effects in 'm'.-Delays can occur between any two side effects, with lengths specified by a 'diff' value.-These delays don't have any semantics, it can be given to them with 'runScheduleT'.--}-type ScheduleT diff = FreeT (Wait diff)----- | The side effect that waits for a specified amount.-wait :: Monad m => diff -> ScheduleT diff m ()-wait diff = FreeT $ return $ Free $ Wait diff $ return ()---- | Supply a semantic meaning to 'Wait'.--- For every occurrence of @Wait diff@ in the @ScheduleT diff m a@ value,--- a waiting action is executed, depending on 'diff'.-runScheduleT :: Monad m => (diff -> m ()) -> ScheduleT diff m a -> m a-runScheduleT waitAction = iterT $ \(Wait n ma) -> waitAction n >> ma---- | Run a 'ScheduleT' value in a 'MonadIO',--- interpreting the times as milliseconds.-runScheduleIO- :: (MonadIO m, Integral n)- => ScheduleT n m a -> m a-runScheduleIO = runScheduleT $ liftIO . threadDelay . (* 1000) . fromIntegral---- TODO The definition and type signature are both a mouthful. Is there a simpler concept?--- | Runs two values in 'ScheduleT' concurrently--- and returns the first one that yields a value--- (defaulting to the first argument),--- and a continuation for the other value.-race- :: (Ord diff, Num diff, Monad m)- => ScheduleT diff m a -> ScheduleT diff m b- -> ScheduleT diff m (Either- ( a, ScheduleT diff m b)- (ScheduleT diff m a, b)- )-race (FreeT ma) (FreeT mb) = FreeT $ do- -- Perform the side effects to find out how long each 'ScheduleT' values need to wait.- aWait <- ma- bWait <- mb- case aWait of- -- 'a' doesn't need to wait. Return immediately and leave the continuation for 'b'.- Pure a -> return $ Pure $ Left (a, FreeT $ return bWait)- -- 'a' needs to wait, so we need to inspect 'b' as well and see which one needs to wait longer.- Free (Wait aDiff aCont) -> case bWait of- -- 'b' doesn't need to wait. Return immediately and leave the continuation for 'a'.- Pure b -> return $ Pure $ Right (wait aDiff >> aCont, b)- -- Both need to wait. Which one needs to wait longer?- Free (Wait bDiff bCont) -> if aDiff <= bDiff- -- 'a' yields first, or both are done simultaneously.- then runFreeT $ do- -- Perform the wait action that we've deconstructed- wait aDiff- -- Recurse, since more wait actions might be hidden in 'a' and 'b'. 'b' doesn't need to wait as long, since we've already waited for 'aDiff'.- race aCont $ wait (bDiff - aDiff) >> bCont- -- 'b' yields first. Analogously.- else runFreeT $ do- wait bDiff- race (wait (aDiff - bDiff) >> aCont) bCont---- | Runs both schedules concurrently and returns their results at the end.-async- :: (Ord diff, Num diff, Monad m)- => ScheduleT diff m a -> ScheduleT diff m b- -> ScheduleT diff m (a, b)-async aSched bSched = do- ab <- race aSched bSched- case ab of- Left (a, bCont) -> do- b <- bCont- return (a, b)- Right (aCont, b) -> do- a <- aCont- return (a, b)
src/FRP/Rhine.hs view
@@ -1,55 +1,54 @@ {- | This module reexports most common names and combinators you will need to work with Rhine.-It does not export specific clocks, resampling buffers or schedules,-so you will have to import those yourself, e.g. like this:+It also exports most specific clocks and resampling buffers,+so you can import everything in one line: @-{-# LANGUAGE DataKinds #-} import FRP.Rhine-import FRP.Rhine.Clock.Realtime.Millisecond main :: IO ()-main = flow $ constMCl (putStrLn "Hello World!") @@ (waitClock :: Millisecond 100)+main = flow \$ constMCl (putStrLn \"Hello World!\") \@\@ (waitClock :: Millisecond 100) @ -} module FRP.Rhine (module X) where --- dunai-import Data.MonadicStreamFunction as X hiding ((>>>^), (^>>>))-import Data.VectorSpace as X+-- time-domain +-- automaton+import Data.Automaton as X+import Data.Stream.Result as X (Result (..))+import Data.TimeDomain as X+ -- rhine-import FRP.Rhine.Clock as X-import FRP.Rhine.Clock.Proxy as X-import FRP.Rhine.Clock.Util as X-import FRP.Rhine.ClSF as X-import FRP.Rhine.Reactimation as X-import FRP.Rhine.Reactimation.Combinators as X-import FRP.Rhine.ResamplingBuffer as X-import FRP.Rhine.ResamplingBuffer.Util as X-import FRP.Rhine.Schedule as X-import FRP.Rhine.SN as X-import FRP.Rhine.SN.Combinators as X-import FRP.Rhine.Type as X+import Data.VectorSpace as X+import FRP.Rhine.ClSF as X+import FRP.Rhine.Clock 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.Proxy as X import FRP.Rhine.Clock.Realtime.Audio as X import FRP.Rhine.Clock.Realtime.Busy as X+import FRP.Rhine.Clock.Realtime.Event as X import FRP.Rhine.Clock.Realtime.Millisecond as X+import FRP.Rhine.Clock.Realtime.Never as X+import FRP.Rhine.Clock.Realtime.Stdin as X import FRP.Rhine.Clock.Select as X--import FRP.Rhine.ResamplingBuffer.Interpolation as X-import FRP.Rhine.ResamplingBuffer.MSF as X+import FRP.Rhine.Clock.Trivial as X+import FRP.Rhine.Clock.Util as X+import FRP.Rhine.Reactimation as X+import FRP.Rhine.Reactimation.Combinators as X+import FRP.Rhine.ResamplingBuffer as X+import FRP.Rhine.ResamplingBuffer.ClSF as X+import FRP.Rhine.ResamplingBuffer.Collect as X import FRP.Rhine.ResamplingBuffer.FIFO as X+import FRP.Rhine.ResamplingBuffer.Interpolation as X+import FRP.Rhine.ResamplingBuffer.KeepLast as X import FRP.Rhine.ResamplingBuffer.LIFO as X-import FRP.Rhine.ResamplingBuffer.Collect as X import FRP.Rhine.ResamplingBuffer.Timeless as X-import FRP.Rhine.ResamplingBuffer.KeepLast as X--import FRP.Rhine.Schedule.Trans as X-import FRP.Rhine.Schedule.Concurrently as X-import FRP.Rhine.Schedule.Util as X+import FRP.Rhine.ResamplingBuffer.Util as X+import FRP.Rhine.SN as X+import FRP.Rhine.SN.Combinators as X+import FRP.Rhine.Schedule as X+import FRP.Rhine.Type as X
src/FRP/Rhine/ClSF.hs view
@@ -1,5 +1,5 @@ {- |-Clocked signal functions, i.e. monadic stream functions ('MSF's)+Clocked signal functions, i.e. monadic stream functions ('Automaton's) that are aware of time. This module reexports core functionality (such as time effects and 'Behaviour's),@@ -7,13 +7,11 @@ and a wealth of utilities such as digital signal processing units. Documentation can be found in the individual modules. -}--module FRP.Rhine.ClSF ( module X ) where-+module FRP.Rhine.ClSF (module X) where -- rhine-import FRP.Rhine.ClSF.Core as X+import FRP.Rhine.ClSF.Core as X import FRP.Rhine.ClSF.Except as X import FRP.Rhine.ClSF.Random as X import FRP.Rhine.ClSF.Reader as X-import FRP.Rhine.ClSF.Util as X+import FRP.Rhine.ClSF.Util as X
src/FRP/Rhine/ClSF/Core.hs view
@@ -1,19 +1,19 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+ {- | The core functionality of clocked signal functions, supplying the type of clocked signal functions itself ('ClSF'), behaviours (clock-independent/polymorphic signal functions), and basic constructions of 'ClSF's that may use awareness of time as an effect. -}--{-# LANGUAGE Arrows #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-module FRP.Rhine.ClSF.Core- ( module FRP.Rhine.ClSF.Core- , module Control.Arrow- , module X- )- where+module FRP.Rhine.ClSF.Core (+ module FRP.Rhine.ClSF.Core,+ module Control.Arrow,+ module X,+)+where -- base import Control.Arrow@@ -22,85 +22,88 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Reader (ReaderT, mapReaderT, withReaderT) --- dunai-import Data.MonadicStreamFunction (MSF, arrM, constM, morphS, liftTransS)-import Data.MonadicStreamFunction as X hiding ((>>>^), (^>>>))+-- automaton+import Data.Automaton as X -- rhine-import FRP.Rhine.Clock as X-+import FRP.Rhine.Clock -- * Clocked signal functions and behaviours --- | A (synchronous, clocked) monadic stream function--- with the additional side effect of being time-aware,--- that is, reading the current 'TimeInfo' of the clock @cl@.-type ClSF m cl a b = MSF (ReaderT (TimeInfo cl) m) a b+{- | A (synchronous, clocked) automaton+ 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 = Automaton (ReaderT (TimeInfo cl) m) a b --- | A clocked signal is a 'ClSF' with no input required.--- It produces its output on its own.-type ClSignal m cl a = forall arbitrary . ClSF m cl arbitrary a+{- | A clocked signal is a 'ClSF' with no input required.+ It produces its output on its own.+-}+type ClSignal m cl a = forall arbitrary. ClSF m cl arbitrary a --- | A (side-effectful) behaviour is a time-aware stream--- that doesn't depend on a particular clock.--- @time@ denotes the 'TimeDomain'.-type Behaviour m time a = forall cl. time ~ Time cl => ClSignal m cl 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+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+{- | A (side-effectful) behaviour function is a time-aware synchronous stream+ function that doesn't depend on a particular clock.+ @time@ denotes the 'TimeDomain'.+-}+type BehaviourF m time a b = forall cl. (time ~ Time cl) => ClSF m cl a b -- | Compatibility to U.S. american spelling.-type BehaviorF m time a b = BehaviourF m time a b+type BehaviorF m time a b = BehaviourF m time a b -- * Utilities to create 'ClSF's from simpler data -- | Hoist a 'ClSF' along a monad morphism.-hoistClSF- :: (Monad m1, Monad m2)- => (forall c. m1 c -> m2 c)- -> ClSF m1 cl a b- -> ClSF m2 cl a b-hoistClSF hoist = morphS $ mapReaderT hoist+hoistClSF ::+ (Monad m1, Monad m2) =>+ (forall c. m1 c -> m2 c) ->+ ClSF m1 cl a b ->+ ClSF m2 cl a b+hoistClSF hoist = hoistS $ mapReaderT hoist -- | Hoist a 'ClSF' and its clock along a monad morphism.-hoistClSFAndClock- :: (Monad m1, Monad m2)- => (forall c. m1 c -> m2 c)- -> ClSF m1 cl a b- -> ClSF m2 (HoistClock m1 m2 cl) a b-hoistClSFAndClock hoist- = morphS $ withReaderT (retag id) . mapReaderT hoist+hoistClSFAndClock ::+ (Monad m1, Monad m2) =>+ (forall c. m1 c -> m2 c) ->+ ClSF m1 cl a b ->+ ClSF m2 (HoistClock m1 m2 cl) a b+hoistClSFAndClock hoist =+ hoistS $ withReaderT (retag id) . mapReaderT hoist -- | Lift a 'ClSF' into a monad transformer.-liftClSF- :: (Monad m, MonadTrans t, Monad (t m))- => ClSF m cl a b- -> ClSF (t m) cl a b+liftClSF ::+ (Monad m, MonadTrans t, Monad (t m)) =>+ ClSF m cl a b ->+ ClSF (t m) cl a b liftClSF = hoistClSF lift -- | Lift a 'ClSF' and its clock into a monad transformer.-liftClSFAndClock- :: (Monad m, MonadTrans t, Monad (t m))- => ClSF m cl a b- -> ClSF (t m) (LiftClock m t cl) a b+liftClSFAndClock ::+ (Monad m, MonadTrans t, Monad (t m)) =>+ ClSF m cl a b ->+ ClSF (t m) (LiftClock m t cl) a b liftClSFAndClock = hoistClSFAndClock lift --- | A monadic stream function without dependency on time--- is a 'ClSF' for any clock.-timeless :: Monad m => MSF m a b -> ClSF m cl a b-timeless = liftTransS+{- | An automaton without dependency on time+ is a 'ClSF' for any clock.+-}+timeless :: (Monad m) => Automaton m a b -> ClSF m cl a b+timeless = liftS -- | Utility to lift Kleisli arrows directly to 'ClSF's.-arrMCl :: Monad m => (a -> m b) -> ClSF m cl a b+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 :: (Monad m) => m b -> ClSF m cl a b constMCl = timeless . constM {- | Call a 'ClSF' every time the input is 'Just a'.@@ -113,11 +116,12 @@ The former only integrates when the input is @Just 1@, whereas the latter always returns the correct time since initialisation. -}-mapMaybe- :: Monad m- => ClSF m cl a b- -> ClSF m cl (Maybe a) (Maybe b)+mapMaybe ::+ (Monad m) =>+ ClSF m cl a b ->+ ClSF m cl (Maybe a) (Maybe b) mapMaybe behaviour = proc ma -> case ma of- Nothing -> returnA -< Nothing- Just a -> arr Just <<< behaviour -< a+ Nothing -> returnA -< Nothing+ Just a -> arr Just <<< behaviour -< a+ -- TODO Consider integrating up the time deltas
src/FRP/Rhine/ClSF/Except.hs view
@@ -1,134 +1,142 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+ {- | This module provides exception handling, and thus control flow, to synchronous signal functions. -The API presented here closely follows dunai's 'Control.Monad.Trans.MSF.Except',+The API presented here closely follows @automaton@'s "Data.Automaton.Trans.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+module FRP.Rhine.ClSF.Except (+ module FRP.Rhine.ClSF.Except,+ module X,+ safe,+ safely,+ exceptS,+ runAutomatonExcept,+ currentInput,+ forever,+)+where -- base-import qualified Control.Category as Category+import Control.Category qualified 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+-- automaton+import Data.Automaton.Trans.Except hiding (once, once_, throwOn, throwOn', throwS, try)+import Data.Automaton.Trans.Except qualified as AutomatonE -- rhine import FRP.Rhine.ClSF.Core import FRP.Rhine.ClSF.Except.Util+import FRP.Rhine.Clock -- * Throwing exceptions - -- | Immediately throw the incoming exception.-throwS :: Monad m => ClSF (ExceptT e m) cl e a+throwS :: (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 :: (Monad m) => e -> Automaton (ExceptT e m) a b throw = constM . throwE -- | Do not throw an exception.-pass :: Monad m => MSF (ExceptT e m) a a+pass :: (Monad m) => Automaton (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 :: (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 -< ()+throwOn' :: (Monad m) => ClSF (ExceptT e m) cl (Bool, e) ()+throwOn' = proc (b, e) ->+ if b+ then throwS -< e+ else returnA -< ()+{-# INLINEABLE throwOn' #-} -- | Throw the exception 'e' whenever the function evaluates to 'True'.-throwOnCond :: Monad m => (a -> Bool) -> e -> ClSF (ExceptT e m) cl a a-throwOnCond cond e = proc a -> if cond a- then throwS -< e- else returnA -< a+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+{- | Variant of 'throwOnCond' for Kleisli arrows.+ Throws the exception when the input is 'True'.+-}+throwOnCondM :: (Monad m) => (a -> m Bool) -> e -> ClSF (ExceptT e m) cl a a throwOnCondM cond e = proc a -> do b <- arrMCl (lift . cond) -< a if b- then throwS -< e+ then throwS -< e else returnA -< a -- | When the input is @Just e@, throw the exception @e@.-throwMaybe :: Monad m => ClSF (ExceptT e m) cl (Maybe e) (Maybe a)+throwMaybe :: (Monad m) => ClSF (ExceptT e m) cl (Maybe e) (Maybe a) throwMaybe = proc me -> case me of Nothing -> returnA -< Nothing- Just e -> throwS -< e+ Just e -> throwS -< e -- * Monad interface {- | A synchronous exception-throwing signal function.-It is based on a @newtype@ from Dunai, 'MSFExcept',++It is based on a @newtype@ from @automaton@, 'AutomatonExcept', 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'.)+(For more information, see the documentation of 'AutomatonExcept'.) -* @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+* @m@: The monad that the signal function may take side effects in * @e@: The type of exceptions that can be thrown -}-type ClSFExcept m cl a b e = MSFExcept (ReaderT (TimeInfo cl) m) a b e+type ClSFExcept cl a b m e = AutomatonExcept a b (ReaderT (TimeInfo cl) m) 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+type BehaviourFExcept time a b m e =+ forall cl. (time ~ Time cl) => ClSFExcept cl a b m e -- | Compatibility to U.S. american spelling.-type BehaviorFExcept m time a b e = BehaviourFExcept m time a b e-+type BehaviorFExcept time a b m e = BehaviourFExcept time a b m e -- | Leave the monad context, to use the 'ClSFExcept' as an 'Arrow'.-runClSFExcept :: Monad m => ClSFExcept m cl a b e -> ClSF (ExceptT e m) cl a b-runClSFExcept = morphS commuteExceptReader . runMSFExcept+runClSFExcept :: (Monad m) => ClSFExcept cl a b m e -> ClSF (ExceptT e m) cl a b+runClSFExcept = hoistS commuteExceptReader . runAutomatonExcept --- | Enter the monad context in the exception--- for 'ClSF's in the 'ExceptT' monad.--- The 'ClSF' will be run until it encounters an exception.-try :: Monad m => ClSF (ExceptT e m) cl a b -> ClSFExcept m cl a b e-try = MSFE.try . morphS commuteReaderExcept+{- | 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 cl a b m e+try = AutomatonE.try . hoistS 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+{- | Within the same tick, perform a monadic action,+ and immediately throw the value as an exception.+-}+once :: (Monad m) => (a -> m e) -> ClSFExcept cl a b m e+once f = AutomatonE.once $ lift . f -- | A variant of 'once' without input.-once_ :: Monad m => m e -> ClSFExcept m cl a b e+once_ :: (Monad m) => m e -> ClSFExcept cl a b m 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+{- | Advances a single tick with the given Kleisli arrow,+ and then throws an exception.+-}+step :: (Monad m) => (a -> m (b, e)) -> ClSFExcept cl a b m e+step f = AutomatonE.step $ lift . f
src/FRP/Rhine/ClSF/Except/Util.hs view
@@ -1,7 +1,6 @@-{-|+{- | Utilities for 'FRP.Rhine.ClSF.Except' that need not be exported. -}- module FRP.Rhine.ClSF.Except.Util where -- transformers
src/FRP/Rhine/ClSF/Random.hs view
@@ -1,30 +1,27 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-}--- | Create 'ClSF's with randomness without 'IO'.--- Uses the @MonadRandom@ package.--- This module copies the API from @dunai@'s--- 'Control.Monad.Trans.MSF.Random'. -module FRP.Rhine.ClSF.Random- ( module FRP.Rhine.ClSF.Random- , module X- )- where-+{- | Create 'ClSF's with randomness without 'IO'.+ Uses the @MonadRandom@ package.+ This module copies the API from @automaton@'s+ 'Data.Automaton.Trans.Random'.+-}+module FRP.Rhine.ClSF.Random (+ module FRP.Rhine.ClSF.Random,+ module X,+)+where -- transformers import Control.Monad.IO.Class --- random-import System.Random (newStdGen)- -- MonadRandom import Control.Monad.Random --- dunai-import Control.Monad.Trans.MSF.Except (performOnFirstSample)-import qualified Control.Monad.Trans.MSF.Random as MSF-import Control.Monad.Trans.MSF.Random as X hiding (runRandS, evalRandS, getRandomS, getRandomRS, getRandomRS_)+-- automaton+import Data.Automaton.Trans.Except (performOnFirstSample)+import Data.Automaton.Trans.Random as X hiding (evalRandS, getRandomRS, getRandomRS_, getRandomS, runRandS)+import Data.Automaton.Trans.Random qualified as Automaton -- rhine import FRP.Rhine.ClSF.Core@@ -33,65 +30,67 @@ -- * Generating random values from the 'RandT' transformer -- | Generates random values, updating the generator on every step.-runRandS- :: (RandomGen g, Monad m)- => ClSF (RandT g m) cl a b- -> g -- ^ The initial random seed- -> ClSF m cl a (g, b)-runRandS clsf g = MSF.runRandS (morphS commuteReaderRand clsf) g+runRandS ::+ (RandomGen g, Monad m) =>+ ClSF (RandT g m) cl a b ->+ -- | The initial random seed+ g ->+ ClSF m cl a (g, b)+runRandS clsf = Automaton.runRandS (hoistS commuteReaderRand clsf) -- | Updates the generator every step but discards the generator.-evalRandS- :: (RandomGen g, Monad m)- => ClSF (RandT g m) cl a b- -> g- -> ClSF m cl a b+evalRandS ::+ (RandomGen g, Monad m) =>+ ClSF (RandT g m) cl a b ->+ g ->+ ClSF m cl a b evalRandS clsf g = runRandS clsf g >>> arr snd --- | Updates the generator every step but discards the value,--- only outputting the generator.-execRandS- :: (RandomGen g, Monad m)- => ClSF (RandT g m) cl a b- -> g- -> ClSF m cl a g+{- | Updates the generator every step but discards the value,+ only outputting the generator.+-}+execRandS ::+ (RandomGen g, Monad m) =>+ ClSF (RandT g m) cl a b ->+ g ->+ ClSF m cl a g execRandS clsf g = runRandS clsf g >>> arr fst -- | Evaluates the random computation by using the global random generator.-evalRandIOS- :: Monad m- => ClSF (RandT StdGen m) cl a b- -> IO (ClSF m cl a b)-evalRandIOS clsf = do- g <- newStdGen- return $ evalRandS clsf g+evalRandIOS ::+ (Monad m) =>+ ClSF (RandT StdGen m) cl a b ->+ IO (ClSF m cl a b)+evalRandIOS clsf = evalRandS clsf <$> newStdGen -- | Evaluates the random computation by using the global random generator on the first tick.-evalRandIOS'- :: MonadIO m- => ClSF (RandT StdGen m) cl a b- -> ClSF m cl a b+evalRandIOS' ::+ (MonadIO m) =>+ ClSF (RandT StdGen m) cl a b ->+ ClSF m cl a b evalRandIOS' = performOnFirstSample . liftIO . evalRandIOS -- * Creating random behaviours -- | Produce a random value at every tick.-getRandomS- :: (MonadRandom m, Random a)- => Behaviour m time a+getRandomS ::+ (MonadRandom m, Random a) =>+ Behaviour m time a getRandomS = constMCl getRandom --- | Produce a random value at every tick,--- within a range given per tick.-getRandomRS- :: (MonadRandom m, Random a)- => BehaviourF m time (a, a) a+{- | Produce a random value at every tick,+ within a range given per tick.+-}+getRandomRS ::+ (MonadRandom m, Random a) =>+ BehaviourF m time (a, a) a getRandomRS = arrMCl getRandomR --- | Produce a random value at every tick,--- within a range given once.-getRandomRS_- :: (MonadRandom m, Random a)- => (a, a)- -> Behaviour m time a+{- | Produce a random value at every tick,+ within a range given once.+-}+getRandomRS_ ::+ (MonadRandom m, Random a) =>+ (a, a) ->+ Behaviour m time a getRandomRS_ range = constMCl $ getRandomR range
src/FRP/Rhine/ClSF/Random/Util.hs view
@@ -1,6 +1,5 @@ module FRP.Rhine.ClSF.Random.Util where - -- transformers import Control.Monad.Trans.Reader @@ -10,4 +9,3 @@ -- | Commute one 'ReaderT' layer past a 'RandT' layer. commuteReaderRand :: ReaderT r (RandT g m) a -> RandT g (ReaderT r m) a commuteReaderRand (ReaderT f) = liftRandT $ \g -> ReaderT $ \r -> runRandT (f r) g-
src/FRP/Rhine/ClSF/Reader.hs view
@@ -1,10 +1,10 @@-{- |-Create and remove 'ReaderT' layers in 'ClSF's.--}- {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-}++{- |+Create and remove 'ReaderT' layers in 'ClSF's.+-} module FRP.Rhine.ClSF.Reader where -- base@@ -13,37 +13,46 @@ -- transformers import Control.Monad.Trans.Reader --- dunai-import qualified Control.Monad.Trans.MSF.Reader as MSF+-- automaton+import Data.Automaton.Trans.Reader qualified as Automaton -- rhine import FRP.Rhine.ClSF.Core - -- | Commute two 'ReaderT' transformer layers past each other commuteReaders :: ReaderT r1 (ReaderT r2 m) a -> ReaderT r2 (ReaderT r1 m) a-commuteReaders a- = ReaderT $ \r1 -> ReaderT $ \r2 -> runReaderT (runReaderT a r2) r1+commuteReaders a =+ ReaderT $ \r1 -> ReaderT $ \r2 -> runReaderT (runReaderT a r2) r1+{-# INLINE commuteReaders #-} --- | Create ("wrap") a 'ReaderT' layer in the monad stack of a behaviour.--- Each tick, the 'ReaderT' side effect is performed--- by passing the original behaviour the extra @r@ input.-readerS- :: Monad m- => ClSF m cl (a, r) b -> ClSF (ReaderT r m) cl a b-readerS behaviour- = morphS commuteReaders $ MSF.readerS $ arr swap >>> behaviour+{- | Create ("wrap") a 'ReaderT' layer in the monad stack of a behaviour.+ Each tick, the 'ReaderT' side effect is performed+ by passing the original behaviour the extra @r@ input.+-}+readerS ::+ (Monad m) =>+ ClSF m cl (a, r) b ->+ ClSF (ReaderT r m) cl a b+readerS behaviour =+ hoistS commuteReaders $ Automaton.readerS $ arr swap >>> behaviour+{-# INLINE readerS #-} --- | Remove ("run") a 'ReaderT' layer from the monad stack--- by making it an explicit input to the behaviour.-runReaderS- :: Monad m- => ClSF (ReaderT r m) cl a b -> ClSF m cl (a, r) b-runReaderS behaviour- = arr swap >>> (MSF.runReaderS $ morphS commuteReaders behaviour)+{- | Remove ("run") a 'ReaderT' layer from the monad stack+ by making it an explicit input to the behaviour.+-}+runReaderS ::+ (Monad m) =>+ ClSF (ReaderT r m) cl a b ->+ ClSF m cl (a, r) b+runReaderS behaviour =+ arr swap >>> Automaton.runReaderS (hoistS commuteReaders behaviour)+{-# INLINE runReaderS #-} -- | Remove a 'ReaderT' layer by passing the readonly environment explicitly.-runReaderS_- :: Monad m- => ClSF (ReaderT r m) cl a b -> r -> ClSF m cl a b-runReaderS_ behaviour r = arr (, r) >>> runReaderS behaviour+runReaderS_ ::+ (Monad m) =>+ ClSF (ReaderT r m) cl a b ->+ r ->+ ClSF m cl a b+runReaderS_ behaviour r = arr (,r) >>> runReaderS behaviour+{-# INLINE runReaderS_ #-}
src/FRP/Rhine/ClSF/Upsample.hs view
@@ -1,55 +1,58 @@--- | Utilities to run 'ClSF's at the speed of combined clocks--- when they are defined only for a constituent clock.- {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} +{- | Utilities to run 'ClSF's at the speed of combined clocks+ when they are defined only for a constituent clock.+-} module FRP.Rhine.ClSF.Upsample where --- base-import Data.Semigroup- -- dunai-import Control.Monad.Trans.MSF.Reader---import Data.MonadicStreamFunction+import Data.Automaton.Trans.Reader -- rhine import FRP.Rhine.ClSF.Core+import FRP.Rhine.Clock import FRP.Rhine.Schedule --- | An 'MSF' can be given arbitrary other arguments--- that cause it to tick without doing anything--- and replicating the last output.-upsampleMSF :: Monad m => b -> MSF m a b -> MSF m (Either arbitrary a) b-upsampleMSF b msf = right msf >>> accumulateWith (<>) (Right b) >>> arr fromRight+{- | An 'Automaton' can be given arbitrary other arguments+ that cause it to tick without doing anything+ and replicating the last output.+-}+upsampleAutomaton :: (Monad m) => b -> Automaton m a b -> Automaton m (Either arbitrary a) b+upsampleAutomaton b automaton = right automaton >>> accumulateWith (<>) (Right b) >>> arr fromRight where fromRight (Right b') = b'- fromRight (Left _ ) = error "fromRight: This case never occurs in upsampleMSF."+ fromRight (Left _) = error "fromRight: This case never occurs in upsampleAutomaton."+ -- 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)+{- | 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 clL clR) a b+upsampleR b clsf = readerS $ arr remap >>> upsampleAutomaton b (runReaderS clsf) where- remap (TimeInfo { tag = Left tag }, _) = Left tag- remap (TimeInfo { tag = Right tag, .. }, a) = Right (TimeInfo { .. }, a)-+ remap (TimeInfo {tag = Left tag}, _) = Left tag+ remap (TimeInfo {tag = Right tag, ..}, a) = Right (TimeInfo {..}, a) --- | Upsample a 'ClSF' to a parallel clock.--- The given 'ClSF' is only called when @clL@ ticks,--- otherwise the last output is replicated--- (with the given @b@ as initialisation).-upsampleL- :: (Monad m, Time clL ~ Time clR)- => b -> ClSF m clL a b -> ClSF m (ParallelClock m clL clR) a b-upsampleL b clsf = readerS $ arr remap >>> upsampleMSF b (runReaderS clsf)+{- | 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 clL clR) a b+upsampleL b clsf = readerS $ arr remap >>> upsampleAutomaton b (runReaderS clsf) where- remap (TimeInfo { tag = Right tag }, _) = Left tag- remap (TimeInfo { tag = Left tag, .. }, a) = Right (TimeInfo { .. }, a)+ remap (TimeInfo {tag = Right tag}, _) = Left tag+ remap (TimeInfo {tag = Left tag, ..}, a) = Right (TimeInfo {..}, a)
src/FRP/Rhine/ClSF/Util.hs view
@@ -1,25 +1,21 @@-{- |-Utilities to create 'ClSF's.-The fundamental effect that 'ClSF's have is-reading the time information of the clock.-It can be used for many purposes, for example digital signal processing.--}- {-# LANGUAGE Arrows #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} +{- |+Utilities to create 'ClSF's.+The fundamental effect that 'ClSF's have is+reading the time information of the clock.+It can be used for many purposes, for example digital signal processing.+-} module FRP.Rhine.ClSF.Util where - -- base import Control.Arrow import Control.Category (Category)-import qualified Control.Category (id)-import Data.Maybe (fromJust)-import Data.Monoid (Last (Last), getLast)+import Control.Category qualified (id) -- containers import Data.Sequence@@ -28,52 +24,56 @@ import Control.Monad.Trans.Reader (ask, asks) -- dunai-import Control.Monad.Trans.MSF.Reader (readerS)-import Data.MonadicStreamFunction (constM, sumFrom, iPre, feedback)-import Data.MonadicStreamFunction.Instances.VectorSpace ()+import Data.Automaton.Trans.Reader (readerS) -- simple-affine-space import Data.VectorSpace +-- time-domain+import Data.TimeDomain+ -- rhine import FRP.Rhine.ClSF.Core import FRP.Rhine.ClSF.Except-+import FRP.Rhine.Clock -- * Read time information -- | Read the environment variable, i.e. the 'TimeInfo'.-timeInfo :: Monad m => ClSF m cl a (TimeInfo cl)+timeInfo :: (Monad m) => ClSF m cl a (TimeInfo cl) timeInfo = constM 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 :: (Monad m) => (TimeInfo cl -> b) -> ClSF m cl a b timeInfoOf f = constM $ asks f -- | Continuously return the time difference since the last tick.-sinceLastS :: Monad m => ClSF m cl a (Diff (Time cl))+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 :: (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 :: (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 :: (Monad m) => ClSF m cl a (Tag cl) tagS = timeInfoOf tag {- |-Calculate the time passed since this 'ClSF' was instantiated.+Calculate the time passed since this 'ClSF' was instantiated,+i.e. since the first tick on which this 'ClSF' was run.+ This is _not_ the same as 'sinceInitS', which measures the time since clock initialisation. @@ -90,38 +90,48 @@ If you replace 'sinceStart' by 'sinceInitS', it will usually hang after one second, since it doesn't reset after restarting the sawtooth.++Even in the absence of conditional activation of 'ClSF's,+there is a difference:+For a clock that doesn't tick at its initialisation time,+'sinceStart' and 'sinceInitS' will have a constant offset of the duration between initialisation time and first tick. -} sinceStart :: (Monad m, TimeDomain time) => BehaviourF m time a (Diff time)-sinceStart = absoluteS >>> proc time -> do- startTime <- keepFirst -< time- returnA -< time `diffTime` startTime-+sinceStart =+ absoluteS >>> proc time -> do+ startTime <- keepFirst -< time+ returnA -< time `diffTime` startTime -- * Useful aliases -- TODO Is it cleverer to generalise to Arrow?+ {- | Alias for 'Control.Category.>>>' (sequential composition) with higher operator precedence, designed to work with the other operators, e.g.: -> clsf1 >-> clsf2 @@ clA ||@ sched @|| clsf3 >-> clsf4 @@ clB+> clsf1 >-> clsf2 @@ clA |@| 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++(>->) ::+ (Category cat) =>+ cat a b ->+ cat b c ->+ cat a c (>->) = (>>>) -- | Alias for 'Control.Category.<<<'. infixl 6 <-<-(<-<) :: Category cat- => cat b c- -> cat a b- -> cat a c++(<-<) ::+ (Category cat) =>+ cat b c ->+ cat a b ->+ cat a c (<-<) = (<<<) {- | Output a constant value.@@ -129,257 +139,306 @@ > arr_ :: Monad m => b -> ClSF m cl a b -}-arr_ :: Arrow a => b -> a c 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 :: (Monad m) => ClSF m cl a a clId = Control.Category.id - -- * Basic signal processing components -- ** Integration and differentiation --- | The output of @integralFrom v0@ is the numerical Euler integral--- of the input, with initial offset @v0@.-integralFrom- :: ( Monad m, VectorSpace v s- , s ~ Diff td)- => v -> BehaviorF m td v v+{- | The output of @integralFrom v0@ is the numerical Euler integral+ of the input, with initial offset @v0@.+-}+integralFrom ::+ ( Monad m+ , VectorSpace v s+ , s ~ Diff td+ ) =>+ v ->+ BehaviorF m td v v integralFrom v0 = proc v -> do _sinceLast <- timeInfoOf sinceLast -< ()- sumFrom v0 -< _sinceLast *^ v+ sumFrom v0 -< _sinceLast *^ v -- | Euler integration, with zero initial offset.-integral- :: ( Monad m, VectorSpace v s- , s ~ Diff td)- => BehaviorF m td v v+integral ::+ ( Monad m+ , VectorSpace v s+ , s ~ Diff td+ ) =>+ BehaviorF m td v v integral = integralFrom zeroVector ---- | The output of @derivativeFrom v0@ is the numerical derivative of the input,--- with a Newton difference quotient.--- The input is initialised with @v0@.-derivativeFrom- :: ( Monad m, VectorSpace v s- , s ~ Diff td)- => v -> BehaviorF m td v v+{- | The output of @derivativeFrom v0@ is the numerical derivative of the input,+ with a Newton difference quotient.+ The input is initialised with @v0@.+-}+derivativeFrom ::+ ( Monad m+ , VectorSpace v s+ , s ~ Diff td+ ) =>+ v ->+ BehaviorF m td v v derivativeFrom v0 = proc v -> do- vLast <- iPre v0 -< v+ vLast <- delay v0 -< v TimeInfo {..} <- timeInfo -< ()- returnA -< (v ^-^ vLast) ^/ sinceLast+ returnA -< (v ^-^ vLast) ^/ sinceLast -- | Numerical derivative with input initialised to zero.-derivative- :: ( Monad m, VectorSpace v s- , s ~ Diff td)- => BehaviorF m td v v+derivative ::+ ( Monad m+ , VectorSpace v s+ , s ~ Diff td+ ) =>+ BehaviorF m td v v derivative = derivativeFrom zeroVector --- | Like 'derivativeFrom', but uses three samples to compute the derivative.--- Consequently, it is delayed by one sample.-threePointDerivativeFrom- :: ( Monad m, VectorSpace v s- , s ~ Diff td)- => v -- ^ The initial position- -> BehaviorF m td v v+{- | Like 'derivativeFrom', but uses three samples to compute the derivative.+ Consequently, it is delayed by one sample.+-}+threePointDerivativeFrom ::+ ( Monad m+ , VectorSpace v s+ , s ~ Diff td+ , Num s+ ) =>+ -- | The initial position+ v ->+ BehaviorF m td v v threePointDerivativeFrom v0 = proc v -> do- dv <- derivativeFrom v0 -< v- dv' <- iPre zeroVector -< dv- returnA -< (dv ^+^ dv') ^/ 2+ dv <- derivativeFrom v0 -< v+ dv' <- delay zeroVector -< dv+ returnA -< (dv ^+^ dv') ^/ 2 --- | Like 'threePointDerivativeFrom',--- but with the initial position initialised to 'zeroVector'.-threePointDerivative- :: ( Monad m, VectorSpace v s- , s ~ Diff td)- => BehaviorF m td v v+{- | Like 'threePointDerivativeFrom',+ but with the initial position initialised to 'zeroVector'.+-}+threePointDerivative ::+ ( Monad m+ , VectorSpace v s+ , s ~ Diff td+ , Num s+ ) =>+ BehaviorF m td v v threePointDerivative = threePointDerivativeFrom zeroVector -- ** Averaging and filters --- | A weighted moving average signal function.--- The output is the average of the first input,--- weighted by the second input--- (which is assumed to be always between 0 and 1).--- The weight is applied to the average of the last tick,--- so a weight of 1 simply repeats the past value unchanged,--- whereas a weight of 0 outputs the current value.-weightedAverageFrom- :: ( Monad m, VectorSpace v s- , s ~ Diff td)- => v -- ^ The initial position- -> BehaviorF m td (v, s) v+{- | A weighted moving average signal function.+ The output is the average of the first input,+ weighted by the second input+ (which is assumed to be always between 0 and 1).+ The weight is applied to the average of the last tick,+ so a weight of 1 simply repeats the past value unchanged,+ whereas a weight of 0 outputs the current value.+-}+weightedAverageFrom ::+ ( Monad m+ , VectorSpace v s+ , s ~ Diff td+ , Num s+ ) =>+ -- | The initial position+ v ->+ BehaviorF m td (v, s) v weightedAverageFrom v0 = feedback v0 $ proc ((v, weight), vAvg) -> do let vAvg' = weight *^ vAvg ^+^ (1 - weight) *^ v returnA -< (vAvg', vAvg') --- | An exponential moving average, or low pass.--- It will average out, or filter,--- all features below a given time constant @t@.--- (Equivalently, it filters out frequencies above @1 / (2 * pi * t)@.)-averageFrom- :: ( Monad m, VectorSpace v s- , Floating s- , s ~ Diff td)- => v -- ^ The initial position- -> Diff td -- ^ The time scale on which the signal is averaged- -> BehaviorF m td v v+{- | An exponential moving average, or low pass.+ It will average out, or filter,+ all features below a given time constant @t@.+ (Equivalently, it filters out frequencies above @1 / (2 * pi * t)@.)+-}+averageFrom ::+ ( Monad m+ , VectorSpace v s+ , Floating s+ , s ~ Diff td+ ) =>+ -- | The initial position+ v ->+ -- | The time scale on which the signal is averaged+ Diff td ->+ BehaviorF m td v v averageFrom v0 t = proc v -> do TimeInfo {..} <- timeInfo -< () let- weight = exp $ - (sinceLast / t)- weightedAverageFrom v0 -< (v, weight)-+ weight = exp $ -(sinceLast / t)+ weightedAverageFrom v0 -< (v, weight) -- | An average, or low pass, initialised to zero.-average- :: ( Monad m, VectorSpace v s- , Floating s- , s ~ Diff td)- => Diff td -- ^ The time scale on which the signal is averaged- -> BehaviourF m td v v+average ::+ ( Monad m+ , VectorSpace v s+ , Floating s+ , s ~ Diff td+ ) =>+ -- | The time scale on which the signal is averaged+ Diff td ->+ BehaviourF m td v v average = averageFrom zeroVector --- | A linearised version of 'averageFrom'.--- It is more efficient, but only accurate--- if the supplied time scale is much bigger--- than the average time difference between two ticks.-averageLinFrom- :: ( Monad m, VectorSpace v s- , s ~ Diff td)- => v -- ^ The initial position- -> Diff td -- ^ The time scale on which the signal is averaged- -> BehaviourF m td v v+{- | A linearised version of 'averageFrom'.+ It is more efficient, but only accurate+ if the supplied time scale is much bigger+ than the average time difference between two ticks.+-}+averageLinFrom ::+ ( Monad m+ , VectorSpace v s+ , Floating s+ , s ~ Diff td+ ) =>+ -- | The initial position+ v ->+ -- | The time scale on which the signal is averaged+ Diff td ->+ BehaviourF m td v v averageLinFrom v0 t = proc v -> do TimeInfo {..} <- timeInfo -< () let weight = t / (sinceLast + t)- weightedAverageFrom v0 -< (v, weight)+ weightedAverageFrom v0 -< (v, weight) -- | Linearised version of 'average'.-averageLin- :: ( Monad m, VectorSpace v s- , s ~ Diff td)- => Diff td -- ^ The time scale on which the signal is averaged- -> BehaviourF m td v v+averageLin ::+ ( Monad m+ , VectorSpace v s+ , Floating s+ , s ~ Diff td+ ) =>+ -- | The time scale on which the signal is averaged+ Diff td ->+ BehaviourF m td v v averageLin = averageLinFrom zeroVector -- *** First-order filters -- | Alias for 'average'.-lowPass- :: ( Monad m, VectorSpace v s- , Floating s- , s ~ Diff td)- => Diff td- -> BehaviourF m td v v+lowPass ::+ ( Monad m+ , VectorSpace v s+ , Floating s+ , s ~ Diff td+ ) =>+ Diff td ->+ BehaviourF m td v v lowPass = average -- | Filters out frequencies below @1 / (2 * pi * t)@.-highPass- :: ( Monad m, VectorSpace v s- , Floating s- , s ~ Diff td)- => Diff td -- ^ The time constant @t@- -> BehaviourF m td v v+highPass ::+ ( Monad m+ , VectorSpace v s+ , Floating s+ , Eq s+ , s ~ Diff td+ ) =>+ -- | The time constant @t@+ Diff td ->+ BehaviourF m td v v highPass t = clId ^-^ lowPass t -- | Filters out frequencies other than @1 / (2 * pi * t)@.-bandPass- :: ( Monad m, VectorSpace v s- , Floating s- , s ~ Diff td)- => Diff td -- ^ The time constant @t@- -> BehaviourF m td v v+bandPass ::+ ( Monad m+ , VectorSpace v s+ , Floating s+ , Eq s+ , s ~ Diff td+ ) =>+ -- | The time constant @t@+ Diff td ->+ BehaviourF m td v v bandPass t = lowPass t >>> highPass t -- | Filters out the frequency @1 / (2 * pi * t)@.-bandStop- :: ( Monad m, VectorSpace v s- , Floating s- , s ~ Diff td)- => Diff td -- ^ The time constant @t@- -> BehaviourF m td v v+bandStop ::+ ( Monad m+ , VectorSpace v s+ , Floating s+ , Eq s+ , s ~ Diff td+ ) =>+ -- | The time constant @t@+ Diff td ->+ BehaviourF m td v v bandStop t = clId ^-^ bandPass t -- -- * Delays -- | Remembers and indefinitely outputs ("holds") the first input value.-keepFirst :: Monad m => ClSF m cl a a+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))+{- | Remembers all input values that arrived within a given time window.+ New values are appended left.+-}+historySince ::+ (Monad m, Ord (Diff (Time cl)), TimeDomain (Time cl)) =>+ -- | The size of the time window+ Diff (Time cl) ->+ ClSF m cl a (Seq (TimeInfo cl, a)) historySince dTime = readerS $ accumulateWith appendValue empty where- appendValue (ti, a) tias = takeWhileL (recentlySince ti) $ (ti, a) <| tias+ appendValue (ti, a) tias = takeWhileL (recentlySince ti) $ (ti, a) <| tias recentlySince ti (ti', _) = diffTime (absolute ti) (absolute ti') < dTime --- | Delay a signal by certain time span,--- initialising with the first input.-delayBy- :: (Monad m, Ord (Diff td), TimeDomain td)- => Diff td -- ^ The time span to delay the signal- -> BehaviorF m td a a+{- | Delay a signal by certain time span,+ initialising with the first input.+-}+delayBy ::+ (Monad m, Ord (Diff td), TimeDomain td) =>+ -- | The time span to delay the signal+ Diff td ->+ BehaviorF m td a a delayBy dTime = historySince dTime >>> arr (viewr >>> safeHead) >>> lastS undefined >>> arr snd where- safeHead EmptyR = Nothing+ safeHead EmptyR = Nothing safeHead (_ :> a) = Just a -- * Timers --- | Throws an exception after the specified time difference,--- outputting the time passed since the 'timer' was instantiated.-timer- :: ( Monad m- , TimeDomain td- , Ord (Diff td)- )- => Diff td- -> BehaviorF (ExceptT () m) td a (Diff td)+{- | Throws an exception after the specified time difference,+ outputting the time passed since the 'timer' was instantiated.+-}+timer ::+ ( Monad m+ , TimeDomain td+ , Ord (Diff td)+ ) =>+ Diff td ->+ BehaviorF (ExceptT () m) td a (Diff td) timer diff = proc _ -> do time <- sinceStart -< ()- _ <- throwOn () -< time > diff- returnA -< time+ _ <- throwOn () -< time > diff+ returnA -< time -- | Like 'timer_', but doesn't output the remaining time at all.-timer_- :: ( Monad m- , TimeDomain td- , Ord (Diff td)- )- => Diff td- -> BehaviorF (ExceptT () m) td a ()+timer_ ::+ ( Monad m+ , TimeDomain td+ , Ord (Diff td)+ ) =>+ Diff td ->+ BehaviorF (ExceptT () m) td a () timer_ diff = timer diff >>> arr (const ()) -- | Like 'timer', but divides the remaining time by the total time.-scaledTimer- :: ( Monad m- , TimeDomain td- , Fractional (Diff td)- , Ord (Diff td)- )- => Diff td- -> BehaviorF (ExceptT () m) td a (Diff td)+scaledTimer ::+ ( Monad m+ , TimeDomain td+ , Fractional (Diff td)+ , Ord (Diff td)+ ) =>+ Diff td ->+ BehaviorF (ExceptT () m) td a (Diff td) scaledTimer diff = timer diff >>> arr (/ diff)----- * To be ported to Dunai---- | Remembers the last 'Just' value,--- defaulting to the given initialisation value.-lastS :: Monad m => a -> MSF m (Maybe a) a-lastS a = arr Last >>> mappendFrom (Last (Just a)) >>> arr (getLast >>> fromJust)
src/FRP/Rhine/Clock.hs view
@@ -1,3 +1,11 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+ {- | 'Clock's are the central new notion in Rhine. There are clock types (instances of the 'Clock' type class)@@ -7,32 +15,21 @@ 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 TupleSections #-}-{-# LANGUAGE TypeFamilies #-}-module FRP.Rhine.Clock- ( module FRP.Rhine.Clock- , module X- )-where+module FRP.Rhine.Clock where -- base-import qualified Control.Category as Category+import Control.Arrow+import Control.Category qualified as Category -- transformers-import Control.Monad.IO.Class (liftIO, MonadIO)-import Control.Monad.Trans.Class (lift, MonadTrans)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Class (MonadTrans, lift) --- dunai-import Data.MonadicStreamFunction as X hiding ((>>>^), (^>>>))+-- automaton+import Data.Automaton (Automaton, arrM, hoistS) --- rhine-import FRP.Rhine.TimeDomain as X+-- time-domain+import Data.TimeDomain -- * The 'Clock' type class @@ -41,7 +38,7 @@ 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)+type RunningClock m time tag = Automaton m () (time, tag) {- | When initialising a clock, the initial time is measured@@ -57,39 +54,46 @@ and only differ in implementation details. Often, clocks are singletons. -}-class TimeDomain (Time 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 Time cl- -- | Additional information that the clock may output at each tick,- -- e.g. if a realtime promise was met, if an event occurred,- -- if one of its subclocks (if any) ticked.++ {- | Additional information that the clock may output at each tick,+ e.g. if a realtime promise was met, if an event occurred,+ if one of its subclocks (if any) ticked.+ -} type Tag cl- -- | The method that produces to a clock value a running clock,- -- i.e. an effectful stream of tagged time stamps together with an initialisation time.- initClock- :: cl -- ^ The clock value, containing e.g. settings or device parameters- -> RunningClockInit m (Time cl) (Tag cl) -- ^ The stream of time stamps, and the initial time + {- | The method that produces to a clock value a running clock,+ i.e. an effectful stream of tagged time stamps together with an initialisation time.+ -}+ initClock ::+ -- | The clock value, containing e.g. settings or device parameters+ cl ->+ -- | The stream of time stamps, and the initial time+ RunningClockInit m (Time cl) (Tag cl)+ -- * Auxiliary definitions and utilities -- | An annotated, rich time stamp. data TimeInfo cl = TimeInfo- { -- | Time passed since the last tick- sinceLast :: Diff (Time cl)- -- | Time passed since the initialisation of the clock+ { sinceLast :: Diff (Time cl)+ -- ^ Time passed since the last tick , sinceInit :: Diff (Time cl)- -- | The absolute time of the current tick- , absolute :: Time cl- -- | The tag annotation of the current tick- , tag :: Tag cl+ -- ^ Time passed since the initialisation of the clock+ , absolute :: Time cl+ -- ^ The absolute time of the current tick+ , tag :: Tag cl+ -- ^ The tag annotation of the current tick } -- | A utility that changes the tag of a 'TimeInfo'.-retag- :: (Time cl1 ~ Time cl2)- => (Tag cl1 -> Tag cl2)- -> TimeInfo cl1 -> TimeInfo cl2-retag f TimeInfo {..} = TimeInfo { tag = f tag, .. }+retag ::+ (Time cl1 ~ Time cl2) =>+ (Tag cl1 -> Tag cl2) ->+ TimeInfo cl1 ->+ TimeInfo cl2+retag f TimeInfo {..} = TimeInfo {tag = f tag, ..} -- * Certain universal building blocks to produce new clocks from given ones @@ -98,150 +102,172 @@ -- | A pure morphism of time domains is just a function. type Rescaling cl time = Time cl -> time --- | An effectful morphism of time domains is a Kleisli arrow.--- It can use a side effect to rescale a point in one time domain--- into another one.+{- | An effectful morphism of time domains is a Kleisli arrow.+ It can use a side effect to rescale a point in one time domain+ into another one.+-} type RescalingM m cl time = Time cl -> m time --- | An effectful, stateful morphism of time domains is an 'MSF'--- that uses side effects to rescale a point in one time domain--- into another one.-type RescalingS m cl time tag = MSF m (Time cl, Tag cl) (time, tag)+{- | An effectful, stateful morphism of time domains is an 'Automaton'+ that uses side effects to rescale a point in one time domain+ into another one.+-}+type RescalingS m cl time tag = Automaton m (Time cl, Tag cl) (time, tag) --- | Like 'RescalingS', but allows for an initialisation--- of the rescaling morphism, together with the initial time.+{- | Like 'RescalingS', but allows for an initialisation+ of the rescaling morphism, together with the initial time.+-} type RescalingSInit m cl time tag = Time cl -> m (RescalingS m cl time tag, time) --- | Convert an effectful morphism of time domains into a stateful one with initialisation.--- Think of its type as @RescalingM m cl time -> RescalingSInit m cl time tag@,--- although this type is ambiguous.-rescaleMToSInit- :: Monad m- => (time1 -> m time2) -> time1 -> m (MSF m (time1, tag) (time2, tag), time2)-rescaleMToSInit rescaling time1 = (arrM rescaling *** Category.id, ) <$> rescaling time1+{- | Convert an effectful morphism of time domains into a stateful one with initialisation.+ Think of its type as @RescalingM m cl time -> RescalingSInit m cl time tag@,+ although this type is ambiguous.+-}+rescaleMToSInit ::+ (Monad m) =>+ (time1 -> m time2) ->+ time1 ->+ m (Automaton m (time1, tag) (time2, tag), time2)+rescaleMToSInit rescaling time1 = (arrM rescaling *** Category.id,) <$> rescaling time1 -- ** Applying rescalings to clocks -- | Applying a morphism of time domains yields a new clock. data RescaledClock cl time = RescaledClock { unscaledClock :: cl- , rescale :: Rescaling cl time+ , rescale :: Rescaling cl time } --instance (Monad m, TimeDomain time, Clock m cl)- => Clock m (RescaledClock cl time) where+instance+ (Monad m, TimeDomain time, Clock m cl) =>+ Clock m (RescaledClock cl time)+ where type Time (RescaledClock cl time) = time- type Tag (RescaledClock cl time) = Tag cl+ type Tag (RescaledClock cl time) = Tag cl initClock (RescaledClock cl f) = do (runningClock, initTime) <- initClock cl- return+ pure ( runningClock >>> first (arr f) , f initTime )+ {-# INLINE initClock #-} --- | Instead of a mere function as morphism of time domains,--- we can transform one time domain into the other with an effectful morphism.+{- | Instead of a mere function as morphism of time domains,+ we can transform one time domain into the other with an effectful morphism.+-} data RescaledClockM m cl time = RescaledClockM { unscaledClockM :: cl -- ^ The clock before the rescaling- , rescaleM :: RescalingM m cl time+ , rescaleM :: RescalingM m cl time -- ^ Computing the new time effectfully from the old time } -instance (Monad m, TimeDomain time, Clock m cl)- => Clock m (RescaledClockM m cl time) where+instance+ (Monad m, TimeDomain time, Clock m cl) =>+ Clock m (RescaledClockM m cl time)+ where type Time (RescaledClockM m cl time) = time- type Tag (RescaledClockM m cl time) = Tag cl+ type Tag (RescaledClockM m cl time) = Tag cl initClock RescaledClockM {..} = do (runningClock, initTime) <- initClock unscaledClockM- rescaledInitTime <- rescaleM initTime- return+ rescaledInitTime <- rescaleM initTime+ pure ( runningClock >>> first (arrM rescaleM) , rescaledInitTime )+ {-# INLINE initClock #-} -- | A 'RescaledClock' is trivially a 'RescaledClockM'.-rescaledClockToM :: Monad m => RescaledClock cl time -> RescaledClockM m cl time-rescaledClockToM RescaledClock {..} = RescaledClockM- { unscaledClockM = unscaledClock- , rescaleM = return . rescale- }-+rescaledClockToM :: (Monad m) => RescaledClock cl time -> RescaledClockM m cl time+rescaledClockToM RescaledClock {..} =+ RescaledClockM+ { unscaledClockM = unscaledClock+ , rescaleM = pure . rescale+ } --- | Instead of a mere function as morphism of time domains,--- we can transform one time domain into the other with a monadic stream function.+{- | Instead of a mere function as morphism of time domains,+ we can transform one time domain into the other with an automaton.+-} data RescaledClockS m cl time tag = RescaledClockS { unscaledClockS :: cl -- ^ The clock before the rescaling- , rescaleS :: RescalingSInit m cl time tag- -- ^ The rescaling stream function, and rescaled initial time,- -- depending on the initial time before rescaling+ , rescaleS :: RescalingSInit m cl time tag+ {- ^ The rescaling stream function, and rescaled initial time,+ depending on the initial time before rescaling+ -} } -instance (Monad m, TimeDomain time, Clock m cl)- => Clock m (RescaledClockS m cl time tag) where+instance+ (Monad m, TimeDomain time, Clock m cl) =>+ Clock m (RescaledClockS m cl time tag)+ where type Time (RescaledClockS m cl time tag) = time- type Tag (RescaledClockS m cl time tag) = tag+ type Tag (RescaledClockS m cl time tag) = tag initClock RescaledClockS {..} = do (runningClock, initTime) <- initClock unscaledClockS (rescaling, rescaledInitTime) <- rescaleS initTime- return+ pure ( runningClock >>> rescaling , rescaledInitTime )+ {-# INLINE initClock #-} -- | A 'RescaledClockM' is trivially a 'RescaledClockS'.-rescaledClockMToS- :: Monad m- => RescaledClockM m cl time -> RescaledClockS m cl time (Tag cl)-rescaledClockMToS RescaledClockM {..} = RescaledClockS- { unscaledClockS = unscaledClockM- , rescaleS = rescaleMToSInit rescaleM- }+rescaledClockMToS ::+ (Monad m) =>+ RescaledClockM m cl time ->+ RescaledClockS m cl time (Tag cl)+rescaledClockMToS RescaledClockM {..} =+ RescaledClockS+ { unscaledClockS = unscaledClockM+ , rescaleS = rescaleMToSInit rescaleM+ } -- | A 'RescaledClock' is trivially a 'RescaledClockS'.-rescaledClockToS- :: Monad m- => RescaledClock cl time -> RescaledClockS m cl time (Tag cl)+rescaledClockToS ::+ (Monad m) =>+ RescaledClock cl time ->+ RescaledClockS m cl time (Tag cl) rescaledClockToS = rescaledClockMToS . rescaledClockToM -- | Applying a monad morphism yields a new clock. data HoistClock m1 m2 cl = HoistClock { unhoistedClock :: cl- , monadMorphism :: forall a . m1 a -> m2 a+ , monadMorphism :: forall a. m1 a -> m2 a } -instance (Monad m1, Monad m2, Clock m1 cl)- => Clock m2 (HoistClock m1 m2 cl) where+instance+ (Monad m1, Monad m2, Clock m1 cl) =>+ Clock m2 (HoistClock m1 m2 cl)+ where type Time (HoistClock m1 m2 cl) = Time cl- type Tag (HoistClock m1 m2 cl) = Tag cl+ type Tag (HoistClock m1 m2 cl) = Tag cl initClock HoistClock {..} = do (runningClock, initialTime) <- monadMorphism $ initClock unhoistedClock- let hoistMSF = morphS- -- TODO Look out for API changes in dunai here- return- ( hoistMSF monadMorphism runningClock+ pure+ ( hoistS monadMorphism runningClock , initialTime )-+ {-# INLINE initClock #-} -- | Lift a clock type into a monad transformer.-type LiftClock m t cl = HoistClock m (t m) cl+type LiftClock m t = HoistClock m (t m) -- | Lift a clock value into a monad transformer. liftClock :: (Monad m, MonadTrans t) => cl -> LiftClock m t cl-liftClock unhoistedClock = HoistClock- { monadMorphism = lift- , ..- }+liftClock unhoistedClock =+ HoistClock+ { monadMorphism = lift+ , ..+ } -- | Lift a clock type into 'MonadIO'. type IOClock m cl = HoistClock IO m cl -- | Lift a clock value into 'MonadIO'.-ioClock :: MonadIO m => cl -> IOClock m cl-ioClock unhoistedClock = HoistClock- { monadMorphism = liftIO- , ..- }+ioClock :: (MonadIO m) => cl -> IOClock m cl+ioClock unhoistedClock =+ HoistClock+ { monadMorphism = liftIO+ , ..+ }
+ src/FRP/Rhine/Clock/Except.hs view
@@ -0,0 +1,214 @@+module FRP.Rhine.Clock.Except where++-- base+import Control.Arrow+import Control.Exception+import Control.Exception qualified as Exception+import Control.Monad ((<=<))+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Functor ((<&>))+import Data.Void++-- time+import Data.Time (UTCTime, getCurrentTime)++-- mtl+import Control.Monad.Error.Class++-- time-domain+import Data.TimeDomain (TimeDomain)++-- automaton+import Data.Automaton (hoistS)+import Data.Automaton.Trans.Except+import Data.Automaton.Trans.Except qualified as AutomatonExcept+import Data.Automaton.Trans.Reader (readerS, runReaderS)++-- rhine+import FRP.Rhine.ClSF.Core (ClSF)+import FRP.Rhine.Clock (+ Clock (..),+ HoistClock (..),+ TimeInfo (..),+ retag,+ )+import FRP.Rhine.Clock.Proxy (GetClockProxy)++-- * 'ExceptClock'++{- | Handle 'IO' exceptions purely in 'ExceptT'.++The clock @cl@ may throw 'Exception's of type @e@ while running.+These exceptions are automatically caught, and raised as an error in 'ExceptT'+(or more generally in 'MonadError', which implies the presence of 'ExceptT' in the monad transformer stack)++It can then be caught and handled with 'CatchClock'.+-}+newtype ExceptClock cl e = ExceptClock {getExceptClock :: cl}++instance (Exception e, Clock IO cl, MonadIO eio, MonadError e eio) => Clock eio (ExceptClock cl e) where+ type Time (ExceptClock cl e) = Time cl+ type Tag (ExceptClock cl e) = Tag cl++ initClock ExceptClock {getExceptClock} = do+ ioerror $+ Exception.try $+ initClock getExceptClock+ <&> first (hoistS (ioerror . Exception.try))+ where+ ioerror :: (MonadError e eio, MonadIO eio) => IO (Either e a) -> eio a+ ioerror = liftEither <=< liftIO+ {-# INLINE initClock #-}++instance GetClockProxy (ExceptClock cl e)++-- * 'CatchClock'++{- | Catch an exception in one clock and proceed with another.++When @cl1@ throws an exception @e@ (in @'ExceptT' e@) while running,+this exception is caught, and a clock @cl2@ is started from the exception value.++For this to be possible, @cl1@ must run in the monad @'ExceptT' e m@, while @cl2@ must run in @m@.+To give @cl2@ the ability to throw another exception, you need to add a further 'ExceptT' layer to the stack in @m@.+-}+data CatchClock cl1 e cl2 = CatchClock cl1 (e -> cl2)++instance (Time cl1 ~ Time cl2, Clock (ExceptT e m) cl1, Clock m cl2, Monad m) => Clock m (CatchClock cl1 e cl2) where+ type Time (CatchClock cl1 e cl2) = Time cl1+ type Tag (CatchClock cl1 e cl2) = Either (Tag cl2) (Tag cl1)+ initClock (CatchClock cl1 handler) = do+ tryToInit <- runExceptT $ first (>>> arr (second Right)) <$> initClock cl1+ case tryToInit of+ Right (runningClock, initTime) -> do+ let catchingClock = safely $ do+ e <- AutomatonExcept.try runningClock+ let cl2 = handler e+ (runningClock', _) <- once_ $ initClock cl2+ safe $ runningClock' >>> arr (second Left)+ return (catchingClock, initTime)+ Left e -> (fmap (first (>>> arr (second Left))) . initClock) $ handler e+ {-# INLINE initClock #-}++instance (GetClockProxy (CatchClock cl1 e cl2))++-- | Combine two 'ClSF's under two different clocks.+catchClSF ::+ (Time cl1 ~ Time cl2, Monad m) =>+ -- | Executed until @cl1@ throws an exception+ ClSF m cl1 a b ->+ -- | Executed after @cl1@ threw an exception, when @cl2@ is started+ ClSF m cl2 a b ->+ ClSF m (CatchClock cl1 e cl2) a b+catchClSF clsf1 clsf2 = readerS $ proc (timeInfo, a) -> do+ case tag timeInfo of+ Right tag1 -> runReaderS clsf1 -< (retag (const tag1) timeInfo, a)+ Left tag2 -> runReaderS clsf2 -< (retag (const tag2) timeInfo, a)++-- * 'SafeClock'++-- | A clock that throws no exceptions.+type SafeClock m = HoistClock (ExceptT Void m) m++-- | Remove 'ExceptT' from the monad of a clock, proving that no exception can be thrown.+safeClock :: (Functor m) => cl -> SafeClock m cl+safeClock unhoistedClock =+ HoistClock+ { unhoistedClock+ , monadMorphism = fmap (either absurd id) . runExceptT+ }++-- * 'Single' clock++{- | A clock that emits a single tick, and then throws an exception.++The tag, time measurement and exception have to be supplied as clock value.+-}+data Single m time tag e = Single+ { singleTag :: tag+ -- ^ The tag that will be emitted on the tick.+ , getTime :: m time+ -- ^ A method to measure the current time.+ , exception :: e+ -- ^ The exception to throw after the single tick.+ }++instance (TimeDomain time, MonadError e m) => Clock m (Single m time tag e) where+ type Time (Single m time tag e) = time+ type Tag (Single m time tag e) = tag+ initClock Single {singleTag, getTime, exception} = do+ initTime <- getTime+ let runningClock = hoistS (errorT . runExceptT) $ runAutomatonExcept $ do+ step_ (initTime, singleTag)+ return exception+ errorT :: (MonadError e m) => m (Either e a) -> m a+ errorT = (>>= liftEither)+ return (runningClock, initTime)+ {-# INLINE initClock #-}++-- * 'DelayException'++{- | Catch an exception in clock @cl@ and throw it after one time step.++This is particularly useful if you want to give your signal network a chance to save its current state in some way.+-}+type DelayException m time cl e1 e2 = CatchClock cl e1 (Single m time e1 e2)++-- | Construct a 'DelayException' clock.+delayException ::+ (Monad m, Clock (ExceptT e1 m) cl, MonadError e2 m) =>+ -- | The clock that will throw an exception @e@+ cl ->+ -- | How to transform the exception into the new exception that will be thrown later+ (e1 -> e2) ->+ -- | How to measure the current time+ m (Time cl) ->+ DelayException m (Time cl) cl e1 e2+delayException cl handler mTime = CatchClock cl $ \e -> Single e mTime $ handler e++-- | Like 'delayException', but the exception thrown by @cl@ and by the @DelayException@ clock are the same.+delayException' :: (Monad m, MonadError e m, Clock (ExceptT e m) cl) => cl -> m (Time cl) -> DelayException m (Time cl) cl e e+delayException' cl = delayException cl id++-- | Catch an 'IO' 'Exception', and throw it after one time step.+type DelayMonadIOException m cl e1 e2 = DelayException m UTCTime (ExceptClock cl e1) e1 e2++-- | Build a 'DelayMonadIOException'. The time will be measured using the system time.+delayMonadIOException :: (Exception e1, MonadIO m, MonadError e2 m, Clock IO cl, Time cl ~ UTCTime) => cl -> (e1 -> e2) -> DelayMonadIOException m cl e1 e2+delayMonadIOException cl handler = delayException (ExceptClock cl) handler $ liftIO getCurrentTime++-- | 'DelayMonadIOException' specialised to 'IOError'.+type DelayMonadIOError m cl e = DelayMonadIOException m cl IOError e++-- | 'delayMonadIOException' specialised to 'IOError'.+delayMonadIOError :: (Exception e, MonadError e m, MonadIO m, Clock IO cl, Time cl ~ UTCTime) => cl -> (IOError -> e) -> DelayMonadIOError m cl e+delayMonadIOError = delayMonadIOException++-- | Like 'delayMonadIOError', but throw the error without transforming it.+delayMonadIOError' :: (MonadError IOError m, MonadIO m, Clock IO cl, Time cl ~ UTCTime) => cl -> DelayMonadIOError m cl IOError+delayMonadIOError' cl = delayMonadIOError cl id++{- | 'DelayMonadIOException' specialised to the monad @'ExceptT' e2 'IO'@.++This is sometimes helpful when the type checker complains about an ambigous monad type variable.+-}+type DelayIOException cl e1 e2 = DelayException (ExceptT e2 IO) UTCTime (ExceptClock cl e1) e1 e2++-- | 'delayMonadIOException' specialised to the monad @'ExceptT' e2 'IO'@.+delayIOException :: (Exception e1, Clock IO cl, Time cl ~ UTCTime) => cl -> (e1 -> e2) -> DelayIOException cl e1 e2+delayIOException = delayMonadIOException++-- | 'delayIOException'', but throw the error without transforming it.+delayIOException' :: (Exception e, Clock IO cl, Time cl ~ UTCTime) => cl -> DelayIOException cl e e+delayIOException' cl = delayIOException cl id++-- | 'DelayIOException' specialised to 'IOError'.+type DelayIOError cl e = DelayIOException cl IOError e++-- | 'delayIOException' specialised to 'IOError'.+delayIOError :: (Time cl ~ UTCTime, Clock IO cl) => cl -> (IOError -> e) -> DelayIOError cl e+delayIOError = delayIOException++-- | 'delayIOError', but throw the error without transforming it.+delayIOError' :: (Time cl ~ UTCTime, Clock IO cl) => cl -> DelayIOError cl IOError+delayIOError' cl = delayIOException cl id
src/FRP/Rhine/Clock/FixedStep.hs view
@@ -1,28 +1,28 @@-{- |-Implements pure clocks ticking at-every multiple of a fixed number of steps,-and a deterministic schedule for such clocks.--}--{-# LANGUAGE Arrows #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-module FRP.Rhine.Clock.FixedStep where +{- |+Implements pure clocks ticking at+every multiple of a fixed number of steps,+and a deterministic schedule for such clocks.+-}+module FRP.Rhine.Clock.FixedStep where -- base-import Data.Maybe (fromMaybe)+import Control.Arrow import GHC.TypeLits --- vector-sized+-- automaton+import Data.Automaton (accumulateWith, constM)+import Data.Automaton.Schedule.Trans (ScheduleT, wait)+import Data.Maybe (fromMaybe) import Data.Vector.Sized (Vector, fromList) --- dunai-import Data.MonadicStreamFunction.Async (concatS)+-- time-domain+import Data.TimeDomain (Seconds (..)) -- rhine import FRP.Rhine.Clock@@ -30,58 +30,44 @@ 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.+{- | 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?+ FixedStep :: (KnownNat n) => FixedStep n -- TODO Does the constraint bring any benefit? -- | Extract the type-level natural number as an integer.-stepsize :: FixedStep n -> Integer-stepsize fixedStep@FixedStep = natVal fixedStep+stepsize :: FixedStep n -> Seconds Integer+stepsize fixedStep@FixedStep = Seconds $ natVal fixedStep -instance 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- )+instance (Monad m) => Clock (ScheduleT (Seconds Integer) m) (FixedStep n) where+ type Time (FixedStep n) = Seconds Integer+ type Tag (FixedStep n) = ()+ initClock cl =+ let step = stepsize cl+ in pure+ ( constM (wait (fromIntegral step))+ >>> arr (const step)+ >>> accumulateWith (+) 0+ >>> arr (,())+ , 0+ )+ {-# INLINE initClock #-} instance GetClockProxy (FixedStep n) -- | 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)+{- | Resample into a 'FixedStep' clock that ticks @n@ times slower,+ by collecting all values into a vector.+-}+downsampleFixedStep ::+ (KnownNat n, Monad m) =>+ ResamplingBuffer m (FixedStep k) (FixedStep (n * k)) a (Vector n a) downsampleFixedStep = collect >>-^ arr (fromList >>> assumeSize) where- assumeSize = fromMaybe $ error $ unwords- [ "You are using an incorrectly implemented schedule"- , "for two FixedStep clocks."- , "Use a correct schedule like downsampleFixedStep."- ]+ assumeSize = fromMaybe $ error "downsampleFixedStep: Internal error. Please report this as a bug: https://github.com/turion/rhine/issues"
src/FRP/Rhine/Clock/Periodic.hs view
@@ -1,54 +1,64 @@-{- |-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 #-}++{- |+Periodic clocks are defined by a stream of ticks with periodic time differences.+They model subclocks of a fixed reference clock.+The time differences are supplied at the type level.+-} module FRP.Rhine.Clock.Periodic (Periodic (Periodic)) where -- base-import Control.Monad (forever)+import Control.Arrow++-- automaton+import Data.Automaton (+ Automaton (..),+ accumulateWith,+ arrM,+ concatS,+ )+import Data.Automaton.Schedule.Trans (ScheduleT, wait) import Data.List.NonEmpty hiding (unfold)-import Data.Maybe (fromMaybe)-import GHC.TypeLits (Nat, KnownNat, natVal) --- dunai-import Data.MonadicStreamFunction+-- time-domain+import Data.TimeDomain (Seconds (..)) -- rhine import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy-import Control.Monad.Schedule+import GHC.TypeLits (KnownNat, Nat, natVal) -- * The 'Periodic' clock --- | A clock whose tick lengths cycle through--- a (nonempty) list of type-level natural numbers.--- E.g. @Periodic '[1, 2]@ ticks at times 1, 3, 4, 5, 7, 8, etc.------ The waiting side effect is formal, in 'ScheduleT'.--- You can use e.g. 'runScheduleIO' to produce an actual delay.+{- | A clock whose tick lengths cycle through+ a (nonempty) list of type-level natural numbers.+ E.g. @Periodic '[1, 2]@ ticks at times 1, 3, 4, 5, 7, 8, etc.++ The waiting side effect is formal, in 'ScheduleT'.+ You can use e.g. 'runScheduleIO' to produce an actual delay.+-} data Periodic (v :: [Nat]) where Periodic :: Periodic (n : ns) -instance (Monad m, NonemptyNatList v)- => Clock (ScheduleT Integer m) (Periodic v) where- type Time (Periodic v) = Integer- type Tag (Periodic v) = ()- initClock cl = return- ( cycleS (theList cl) >>> withSideEffect wait >>> (accumulateWith (+) 0) &&& arr (const ())- , 0- )+instance+ (Monad m, NonemptyNatList v) =>+ Clock (ScheduleT (Seconds Integer) m) (Periodic v)+ where+ type Time (Periodic v) = Seconds Integer+ type Tag (Periodic v) = ()+ initClock cl =+ pure+ ( cycleS (theList cl) >>> accumulateWith (+) 0 &&& arrM (wait . fromIntegral)+ , 0+ )+ {-# INLINE initClock #-} instance GetClockProxy (Periodic v) @@ -57,33 +67,26 @@ data HeadClProxy (n :: Nat) where HeadClProxy :: Periodic (n : ns) -> HeadClProxy n -headCl :: KnownNat n => Periodic (n : ns) -> Integer+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 :| []+ theList :: Periodic v -> NonEmpty (Seconds Integer) -instance (KnownNat n1, KnownNat n2, NonemptyNatList (n2 : ns))- => NonemptyNatList (n1 : n2 : ns) where- theList cl = headCl cl <| theList (tailCl cl)+instance (KnownNat n) => NonemptyNatList '[n] where+ theList cl = Seconds (headCl cl) :| [] +instance+ (KnownNat n1, KnownNat n2, NonemptyNatList (n2 : ns)) =>+ NonemptyNatList (n1 : n2 : ns)+ where+ theList cl = Seconds (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--}+cycleS :: (Monad m) => NonEmpty a -> Automaton m () a+cycleS as = concatS $ arr $ const $ toList as
src/FRP/Rhine/Clock/Proxy.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE TypeFamilies #-}+ module FRP.Rhine.Clock.Proxy where -- base@@ -11,78 +12,81 @@ import FRP.Rhine.Clock import FRP.Rhine.Schedule --- | Witnesses the structure of a clock type,--- in particular whether 'SequentialClock's or 'ParallelClock's are involved.+{- | Witnesses the structure of a clock type,+ in particular whether 'SequentialClock's or 'ParallelClock's are involved.+-} data ClockProxy cl where- LeafProxy- :: (cl ~ In cl, cl ~ Out cl)- => ClockProxy cl- SequentialProxy- :: ClockProxy cl1- -> ClockProxy cl2- -> ClockProxy (SequentialClock m cl1 cl2)- ParallelProxy- :: ClockProxy clL- -> ClockProxy clR- -> ClockProxy (ParallelClock m clL clR)+ LeafProxy ::+ (cl ~ In cl, cl ~ Out cl) =>+ ClockProxy cl+ SequentialProxy ::+ ClockProxy cl1 ->+ ClockProxy cl2 ->+ ClockProxy (SequentialClock cl1 cl2)+ ParallelProxy ::+ ClockProxy clL ->+ ClockProxy clR ->+ ClockProxy (ParallelClock clL clR) inProxy :: ClockProxy cl -> ClockProxy (In cl) inProxy LeafProxy = LeafProxy-inProxy (SequentialProxy p1 p2) = inProxy p1+inProxy (SequentialProxy p1 _) = inProxy p1 inProxy (ParallelProxy pL pR) = ParallelProxy (inProxy pL) (inProxy pR) outProxy :: ClockProxy cl -> ClockProxy (Out cl) outProxy LeafProxy = LeafProxy-outProxy (SequentialProxy p1 p2) = outProxy p2+outProxy (SequentialProxy _ p2) = outProxy p2 outProxy (ParallelProxy pL pR) = ParallelProxy (outProxy pL) (outProxy pR) --- | Return the incoming tag, assuming that the incoming clock is ticked,--- and 'Nothing' otherwise.+{- | Return the incoming tag, assuming that the incoming clock is ticked,+ and 'Nothing' otherwise.+-} inTag :: ClockProxy cl -> Tag cl -> Maybe (Tag (In cl))-inTag (SequentialProxy p1 _) (Left tag1) = inTag p1 tag1-inTag (SequentialProxy _ _) (Right _) = Nothing-inTag (ParallelProxy pL _) (Left tagL) = Left <$> inTag pL tagL+inTag (SequentialProxy p1 _) (Left tag1) = inTag p1 tag1+inTag (SequentialProxy _ _) (Right _) = Nothing+inTag (ParallelProxy pL _) (Left tagL) = Left <$> inTag pL tagL inTag (ParallelProxy _ pR) (Right tagR) = Right <$> inTag pR tagR inTag LeafProxy tag = Just tag --- | Return the incoming tag, assuming that the outgoing clock is ticked,--- and 'Nothing' otherwise.+{- | Return the incoming tag, assuming that the outgoing clock is ticked,+ and 'Nothing' otherwise.+-} outTag :: ClockProxy cl -> Tag cl -> Maybe (Tag (Out cl))-outTag (SequentialProxy _ _ ) (Left _) = Nothing+outTag (SequentialProxy _ _) (Left _) = Nothing outTag (SequentialProxy _ p2) (Right tag2) = outTag p2 tag2-outTag (ParallelProxy pL _) (Left tagL) = Left <$> outTag pL tagL+outTag (ParallelProxy pL _) (Left tagL) = Left <$> outTag pL tagL outTag (ParallelProxy _ pR) (Right tagR) = Right <$> outTag pR tagR outTag LeafProxy tag = Just tag -- TODO Should this be a superclass with default implementation of clocks? But then we have a circular dependency... -- No we don't, Schedule should not depend on clock (the type).+ -- | Clocks should be able to automatically generate a proxy for themselves. class GetClockProxy cl where getClockProxy :: ClockProxy cl-- default getClockProxy- :: (cl ~ In cl, cl ~ Out cl)- => ClockProxy cl+ default getClockProxy ::+ (cl ~ In cl, cl ~ Out cl) =>+ ClockProxy cl getClockProxy = LeafProxy -instance (GetClockProxy cl1, GetClockProxy cl2) => GetClockProxy (SequentialClock m cl1 cl2) where+instance (GetClockProxy cl1, GetClockProxy cl2) => GetClockProxy (SequentialClock cl1 cl2) where getClockProxy = SequentialProxy getClockProxy getClockProxy -instance (GetClockProxy cl1, GetClockProxy cl2) => GetClockProxy (ParallelClock m cl1 cl2) where+instance (GetClockProxy cl1, GetClockProxy cl2) => GetClockProxy (ParallelClock cl1 cl2) where getClockProxy = ParallelProxy getClockProxy getClockProxy -instance GetClockProxy cl => GetClockProxy (HoistClock m1 m2 cl)-instance GetClockProxy cl => GetClockProxy (RescaledClock cl time)-instance GetClockProxy cl => GetClockProxy (RescaledClockM m cl time)-instance GetClockProxy cl => GetClockProxy (RescaledClockS m cl time tag)+instance (GetClockProxy cl) => GetClockProxy (HoistClock m1 m2 cl)+instance (GetClockProxy cl) => GetClockProxy (RescaledClock cl time)+instance (GetClockProxy cl) => GetClockProxy (RescaledClockM m cl time)+instance (GetClockProxy cl) => GetClockProxy (RescaledClockS m cl time tag) -- | Extract a clock proxy from a type. class ToClockProxy a where type Cl a :: Type toClockProxy :: a -> ClockProxy (Cl a)-- default toClockProxy- :: GetClockProxy (Cl a)- => a -> ClockProxy (Cl a)+ default toClockProxy ::+ (GetClockProxy (Cl a)) =>+ a ->+ ClockProxy (Cl a) toClockProxy _ = getClockProxy
+ src/FRP/Rhine/Clock/Realtime.hs view
@@ -0,0 +1,94 @@+module FRP.Rhine.Clock.Realtime where++-- base+import Control.Arrow (arr)+import Control.Concurrent (threadDelay)+import Control.Monad (guard)+import Control.Monad.IO.Class++-- time+import Data.Time (addUTCTime, diffUTCTime, getCurrentTime)++-- automaton+import Data.Automaton++-- rhine+import FRP.Rhine.Clock++-- time-domain+import Data.TimeDomain (Diff, UTCTime)++{- | A clock rescaled to the 'UTCTime' time domain.++There are different strategies how a clock may be rescaled, see below.+-}+type UTCClock m cl = RescaledClockS m cl UTCTime (Tag cl)++-- | Rescale an 'IO' clock to the UTC time domain, overwriting its timestamps.+overwriteUTC :: (MonadIO m) => cl -> UTCClock m cl+overwriteUTC cl =+ RescaledClockS+ { unscaledClockS = cl+ , rescaleS = const $ do+ now <- liftIO getCurrentTime+ return (arrM $ \(_timePassed, tag) -> (,tag) <$> liftIO getCurrentTime, now)+ }++{- | Rescale a clock to the UTC time domain.++The initial time stamp is measured as system time,+and the increments (durations between ticks) are taken from the original clock.+No attempt at waiting until the specified time is made,+the timestamps of the original clock are trusted unconditionally.+-}+addUTC :: (Real (Time cl), MonadIO m) => cl -> UTCClock m cl+addUTC cl =+ RescaledClockS+ { unscaledClockS = cl+ , rescaleS = const $ do+ now <- liftIO getCurrentTime+ return (arr $ \(timePassed, tag) -> (addUTCTime (realToFrac timePassed) now, tag), now)+ }++{- | Like 'UTCClock', but also output in the tag whether and by how much the target realtime was missed.++The original clock specifies with its time stamps when, relative to the initialisation time,+the UTC clock should tick.+A tag of @(tag, 'Nothing')@ means that the tick was in time.+@(tag, 'Just' dt)@ means that the tick was too late by @dt@.+-}+type WaitUTCClock m cl = RescaledClockS m cl UTCTime (Tag cl, Maybe (Diff (Time cl)))++{- | Measure the time after each tick, and wait for the remaining time until the next tick.++If the next tick should already have occurred @dt@ seconds ago,+the tag is set to @'Just' dt@, representing a failed real time attempt.++Note that this clock internally uses 'threadDelay' which can block+for quite a lot longer than the requested time, which can cause+'waitUTC' to miss one or more ticks when using a fast original clock.+When using 'threadDelay', the difference between the real wait time+and the requested wait time will be larger when using+the @-threaded@ ghc option (around 800 microseconds) than when not using+this option (around 100 microseconds). For fast clocks it is recommended+that @-threaded@ not be used in order to miss less ticks. The clock will adjust+the wait time, up to no wait time at all, to catch up when a tick is missed.+-}+waitUTC :: (Real (Time cl), MonadIO m, Fractional (Diff (Time cl))) => cl -> WaitUTCClock m cl+waitUTC unscaledClockS =+ RescaledClockS+ { unscaledClockS+ , rescaleS = \_ -> do+ initTime <- liftIO getCurrentTime+ let+ runningClock = arrM $ \(sinceInitTarget, tag) -> liftIO $ do+ beforeSleep <- getCurrentTime+ let+ diff :: Rational+ diff = toRational $ beforeSleep `diffUTCTime` initTime+ remaining = toRational sinceInitTarget - diff+ threadDelay $ round $ 1000000 * remaining+ now <- getCurrentTime+ return (now, (tag, guard (remaining > 0) >> return (fromRational remaining)))+ return (runningClock, initTime)+ }
src/FRP/Rhine/Clock/Realtime/Audio.hs view
@@ -1,38 +1,40 @@-{- |-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 #-} -- {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -- TODO Find out exact version of cabal? GHC? that have a problem with this -module FRP.Rhine.Clock.Realtime.Audio- ( AudioClock (..)- , AudioRate (..)- , PureAudioClock (..)- , PureAudioClockF- , pureAudioClockF- )- where+{- |+Provides several clocks to use for audio processing,+for realtime as well as for batch/file processing.+-}+module FRP.Rhine.Clock.Realtime.Audio (+ AudioClock (..),+ AudioRate (..),+ PureAudioClock (..),+ PureAudioClockF,+ pureAudioClockF,+)+where -- base-import GHC.Float (double2Float)-import GHC.TypeLits (Nat, natVal, KnownNat)+import Control.Arrow import Data.Time.Clock+import GHC.Float (double2Float)+import GHC.TypeLits (KnownNat, Nat, natVal) -- transformers import Control.Monad.IO.Class +-- automaton+import Data.Automaton+import Data.Automaton.Trans.Except hiding (step) --- dunai-import Control.Monad.Trans.MSF.Except hiding (step)+-- time-domain+import Data.TimeDomain (Seconds (..), diffTime) -- rhine import FRP.Rhine.Clock@@ -45,13 +47,13 @@ | Hz96000 -- | Converts an 'AudioRate' to its corresponding rate as an 'Integral'.-rateToIntegral :: Integral a => AudioRate -> a+rateToIntegral :: (Integral a) => AudioRate -> a rateToIntegral Hz44100 = 44100 rateToIntegral Hz48000 = 48000 rateToIntegral Hz96000 = 96000 - -- TODO Test extensively+ {- | A clock for audio analysis and synthesis. It internally processes samples in buffers of size 'bufferSize',@@ -73,9 +75,9 @@ class AudioClockRate (rate :: AudioRate) where theRate :: AudioClock rate bufferSize -> AudioRate- theRateIntegral :: Integral a => AudioClock rate bufferSize -> a+ theRateIntegral :: (Integral a) => AudioClock rate bufferSize -> a theRateIntegral = rateToIntegral . theRate- theRateNum :: Num a => AudioClock rate bufferSize -> a+ theRateNum :: (Num a) => AudioClock rate bufferSize -> a theRateNum = fromInteger . theRateIntegral instance AudioClockRate Hz44100 where@@ -87,41 +89,44 @@ instance AudioClockRate Hz96000 where theRate _ = Hz96000 --theBufferSize- :: (KnownNat bufferSize, Integral a)- => AudioClock rate bufferSize -> a+theBufferSize ::+ (KnownNat bufferSize, Integral a) =>+ AudioClock rate bufferSize ->+ a theBufferSize = fromInteger . natVal --instance (MonadIO m, KnownNat bufferSize, AudioClockRate rate)- => Clock m (AudioClock rate bufferSize) where+instance+ (MonadIO m, KnownNat bufferSize, AudioClockRate rate) =>+ Clock m (AudioClock rate bufferSize)+ where type Time (AudioClock rate bufferSize) = UTCTime- type Tag (AudioClock rate bufferSize) = Maybe Double+ type Tag (AudioClock rate bufferSize) = Maybe Double initClock audioClock = do let- step = picosecondsToDiffTime -- The only sufficiently precise conversion function- $ round (10 ^ (12 :: Integer) / theRateNum audioClock :: Double)+ step =+ picosecondsToDiffTime $+ round (10 ^ (12 :: Integer) / theRateNum audioClock :: Double) -- The only sufficiently precise conversion function bufferSize = theBufferSize audioClock - runningClock :: MonadIO m => UTCTime -> Maybe Double -> MSF m () (UTCTime, Maybe Double)+ runningClock :: (MonadIO m) => UTCTime -> Maybe Double -> Automaton m () (UTCTime, Maybe Double) runningClock initialTime maybeWasLate = safely $ do bufferFullTime <- try $ proc () -> do- n <- count -< ()+ n <- count -< () let nextTime = (realToFrac step * fromIntegral (n :: Int)) `addUTCTime` initialTime _ <- throwOn' -< (n >= bufferSize, nextTime)- returnA -< (nextTime, if n == 0 then maybeWasLate else Nothing)+ returnA -< (nextTime, if n == 0 then maybeWasLate else Nothing) currentTime <- once_ $ liftIO getCurrentTime let lateDiff = currentTime `diffTime` bufferFullTime- late = if lateDiff > 0 then Just lateDiff else Nothing+ late = if lateDiff > 0 then Just $ getSeconds lateDiff else Nothing safe $ runningClock bufferFullTime late initialTime <- liftIO getCurrentTime return ( runningClock initialTime Nothing , initialTime )+ {-# INLINE initClock #-} instance GetClockProxy (AudioClock rate bufferSize) @@ -137,31 +142,33 @@ class PureAudioClockRate (rate :: AudioRate) where thePureRate :: PureAudioClock rate -> AudioRate- thePureRateIntegral :: Integral a => PureAudioClock rate -> a+ thePureRateIntegral :: (Integral a) => PureAudioClock rate -> a thePureRateIntegral = rateToIntegral . thePureRate- thePureRateNum :: Num a => PureAudioClock rate -> a+ thePureRateNum :: (Num a) => PureAudioClock rate -> a thePureRateNum = fromInteger . thePureRateIntegral - instance (Monad m, PureAudioClockRate rate) => Clock m (PureAudioClock rate) where- type Time (PureAudioClock rate) = Double- type Tag (PureAudioClock rate) = ()+ type Time (PureAudioClock rate) = Seconds Double+ type Tag (PureAudioClock rate) = () - initClock audioClock = return- ( arr (const (1 / thePureRateNum audioClock)) >>> sumS &&& arr (const ())- , 0- )+ initClock audioClock =+ return+ ( arr (const (1 / thePureRateNum audioClock)) >>> sumN &&& arr (const ())+ , 0+ )+ {-# INLINE initClock #-} instance GetClockProxy (PureAudioClock rate) -- | A rescaled version of 'PureAudioClock' with 'TimeDomain' 'Float'. type PureAudioClockF (rate :: AudioRate) = RescaledClock (PureAudioClock rate) Float ---- | A rescaled version of 'PureAudioClock' with 'TimeDomain' 'Float',--- using 'double2Float' to rescale.+{- | A rescaled version of 'PureAudioClock' with 'TimeDomain' 'Float',+ using 'double2Float' to rescale.+-} pureAudioClockF :: PureAudioClockF rate-pureAudioClockF = RescaledClock- { unscaledClock = PureAudioClock- , rescale = double2Float- }+pureAudioClockF =+ RescaledClock+ { unscaledClock = PureAudioClock+ , rescale = double2Float . getSeconds+ }
src/FRP/Rhine/Clock/Realtime/Busy.hs view
@@ -1,12 +1,19 @@-{- | A "'Busy'" clock that ticks without waiting. -}- {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-}++-- | A "'Busy'" clock that ticks without waiting. module FRP.Rhine.Clock.Realtime.Busy where -- base+import Control.Arrow+import Control.Monad.IO.Class++-- time import Data.Time.Clock +-- automaton+import Data.Automaton (constM)+ -- rhine import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy@@ -18,16 +25,17 @@ -} data Busy = Busy -instance Clock IO Busy where+instance (MonadIO m) => Clock m Busy where type Time Busy = UTCTime- type Tag Busy = ()+ type Tag Busy = () initClock _ = do- initialTime <- getCurrentTime+ initialTime <- liftIO getCurrentTime return- ( constM getCurrentTime- &&& arr (const ())+ ( constM (liftIO getCurrentTime)+ &&& arr (const ()) , initialTime )+ {-# INLINE initClock #-} instance GetClockProxy Busy
src/FRP/Rhine/Clock/Realtime/Event.hs view
@@ -1,3 +1,10 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+ {- | This module provides two things: @@ -15,25 +22,18 @@ 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+module FRP.Rhine.Clock.Realtime.Event (+ module FRP.Rhine.Clock.Realtime.Event,+ module Control.Monad.IO.Class,+ newChan,+)+where -- base import Control.Concurrent.Chan++-- time import Data.Time.Clock-import Data.Semigroup -- deepseq import Control.DeepSeq@@ -43,21 +43,19 @@ import Control.Monad.Trans.Reader -- rhine-import FRP.Rhine.Clock.Proxy import FRP.Rhine.ClSF-import FRP.Rhine.Schedule-import FRP.Rhine.Schedule.Concurrently--+import FRP.Rhine.Clock+import FRP.Rhine.Clock.Proxy -- * Monads allowing for event emission and handling -- | A monad transformer in which events can be emitted onto a 'Chan'. type EventChanT event m = ReaderT (Chan event) m --- | Escape the 'EventChanT' layer by explicitly providing a channel--- over which events are sent.--- Often this is not needed, and 'runEventChanT' can be used instead.+{- | Escape the 'EventChanT' layer by explicitly providing a channel+ over which events are sent.+ Often this is not needed, and 'runEventChanT' can be used instead.+-} withChan :: Chan event -> EventChanT event m a -> m a withChan = flip runReaderT @@ -68,14 +66,14 @@ e.g. @runEventChanT $ flow myRhine@. This way, exactly one channel is created. -Caution: Don't use this with 'morphS',+Caution: Don't use this with 'hoistS', 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 :: (MonadIO m) => EventChanT event m a -> m a runEventChanT a = do- chan <- liftIO $ newChan+ chan <- liftIO newChan runReaderT a chan {- | Remove ("run") an 'EventChanT' layer from the monad stack@@ -89,11 +87,11 @@ pass the channel to every behaviour or 'ClSF' that wants to emit events, and, by using 'eventClockOn', to every clock that should tick on the event. -}-withChanS- :: Monad m- => Chan event- -> ClSF (EventChanT event m) cl a b- -> ClSF m cl a b+withChanS ::+ (Monad m) =>+ Chan event ->+ ClSF (EventChanT event m) cl a b ->+ ClSF m cl a b withChanS = flip runReaderS_ -- * Event emission@@ -105,94 +103,77 @@ 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 :: (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 :: (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 :: (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+emit' event =+ event `deepseq` do+ chan <- ask+ liftIO $ writeChan chan event -- | Like 'emitS', but completely evaluates the event before emitting it. emitS' :: (NFData event, MonadIO m) => ClSF (EventChanT event m) cl event () emitS' = arrMCl emit' -- | Like 'emitSMaybe', but completely evaluates the event before emitting it.-emitSMaybe'- :: (NFData event, MonadIO m)- => ClSF (EventChanT event m) cl (Maybe event) ()+emitSMaybe' ::+ (NFData event, MonadIO m) =>+ ClSF (EventChanT event m) cl (Maybe event) () emitSMaybe' = mapMaybe emitS' >>> arr (const ()) ---- * Event clocks and schedules+-- * Event clocks --- | A clock that ticks whenever an @event@ is emitted.--- It is not yet bound to a specific channel,--- since ideally, the correct channel is created automatically--- by 'runEventChanT'.--- If you want to create the channel manually and bind the clock to it,--- use 'eventClockOn'.+{- | A clock that ticks whenever an @event@ is emitted.+ It is not yet bound to a specific channel,+ since ideally, the correct channel is created automatically+ by 'runEventChanT'.+ If you want to create the channel manually and bind the clock to it,+ use 'eventClockOn'.+-} data EventClock event = EventClock instance Semigroup (EventClock event) where (<>) _ _ = EventClock -instance MonadIO m => Clock (EventChanT event m) (EventClock event) where+instance (MonadIO m) => Clock (EventChanT event m) (EventClock event) where type Time (EventClock event) = UTCTime- type Tag (EventClock event) = event+ type Tag (EventClock event) = event initClock _ = do initialTime <- liftIO getCurrentTime return ( constM $ do- chan <- ask+ chan <- ask event <- liftIO $ readChan chan- time <- liftIO $ getCurrentTime+ time <- liftIO getCurrentTime return (time, event) , initialTime )+ {-# INLINE initClock #-} instance GetClockProxy (EventClock event) --- | Create an event clock that is bound to a specific event channel.--- This is usually only useful if you can't apply 'runEventChanT'--- to the main loop (see 'withChanS').-eventClockOn- :: MonadIO m- => Chan event- -> HoistClock (EventChanT event m) m (EventClock event)-eventClockOn chan = HoistClock- { unhoistedClock = EventClock- , monadMorphism = withChan chan- }--{- |-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'.+{- | 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'). -}-concurrentlyWithEvents- :: ( Time cl1 ~ Time cl2- , Clock (EventChanT event IO) cl1- , Clock (EventChanT event IO) cl2- )- => Schedule (EventChanT event IO) cl1 cl2-concurrentlyWithEvents = readerSchedule concurrently+eventClockOn ::+ (MonadIO m) =>+ Chan event ->+ HoistClock (EventChanT event m) m (EventClock event)+eventClockOn chan =+ HoistClock+ { unhoistedClock = EventClock+ , monadMorphism = withChan chan+ }
src/FRP/Rhine/Clock/Realtime/Millisecond.hs view
@@ -1,100 +1,61 @@-{- |-Provides a clock that ticks at every multiple of a fixed number of milliseconds.--}--{-# LANGUAGE Arrows #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}++{- |+Provides a clock that ticks at every multiple of a fixed number of milliseconds.+-} module FRP.Rhine.Clock.Realtime.Millisecond where -- base-import Data.Maybe (fromMaybe)-import Data.Time.Clock-import Control.Concurrent (threadDelay)-import GHC.TypeLits+import Control.Arrow (arr, first, second, (>>>)) --- fixed-vector-import Data.Vector.Sized (Vector, fromList)+-- time -- rhine++import Data.Automaton (count)+import Data.Functor ((<&>))+import Data.Time.Clock++-- rhine++import Data.TimeDomain (Seconds (..)) import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy-import FRP.Rhine.Clock.FixedStep-import FRP.Rhine.Schedule-import FRP.Rhine.ResamplingBuffer-import FRP.Rhine.ResamplingBuffer.Util-import FRP.Rhine.ResamplingBuffer.Collect+import FRP.Rhine.Clock.Realtime (WaitUTCClock, waitUTC)+import GHC.TypeLits -{- |-A clock ticking every 'n' milliseconds,-in real time.+{- | A clock ticking every 'n' milliseconds, in real time.+ Since 'n' is in the type signature, it is ensured that when composing two signals on a 'Millisecond' clock, they will be driven at the same rate. -The tag of this clock is 'Bool',-where 'True' represents successful realtime,-and 'False' a lag.+For example, @'Millisecond' 100@ ticks every 0.1 seconds, so 10 times per seconds.++The tag of this clock is 'Maybe Double',+where 'Nothing' represents successful realtime,+and @'Just' lag@ a lag (in seconds). -}-newtype Millisecond (n :: Nat) = Millisecond (RescaledClockS IO (FixedStep n) UTCTime Bool)--- TODO Consider changing the tag to Maybe Double+newtype Millisecond (n :: Nat) = Millisecond (WaitUTCClock IO (RescaledClock (CountClock n) (Seconds Double))) -instance Clock IO (Millisecond n) where+instance (KnownNat n) => Clock IO (Millisecond n) where type Time (Millisecond n) = UTCTime- type Tag (Millisecond n) = Bool- initClock (Millisecond cl) = initClock cl+ type Tag (Millisecond n) = Maybe Double+ initClock (Millisecond cl) = initClock cl <&> first (>>> arr (second (fmap getSeconds . snd)))+ {-# INLINE initClock #-} instance GetClockProxy (Millisecond n) --- | This implementation measures the time after each tick,--- and waits for the remaining time until the next tick.--- If the next tick should already have occurred,--- the tag is set to 'False', representing a failed real time attempt.---- Note that this clock internally uses 'threadDelay' which can block--- for quite a lot longer than the requested time, which can cause--- the clock to miss one or more ticks when using low values of 'n'. --- When using 'threadDelay', the difference between the real wait time --- and the requested wait time will be larger when using --- the '-threaded' ghc option (around 800 microseconds) than when not using--- this option (around 100 microseconds). For low values of @n@ it is recommended--- that '-threaded' not be used in order to miss less ticks. The clock will adjust --- the wait time, up to no wait time at all, to catch up when a tick is missed.--waitClock :: KnownNat n => Millisecond n-waitClock = Millisecond $ RescaledClockS FixedStep $ \_ -> do- initTime <- getCurrentTime- let- runningClock = arrM $ \(n, ()) -> do- beforeSleep <- getCurrentTime- let- diff :: Double- diff = realToFrac $ beforeSleep `diffUTCTime` initTime- remaining = fromInteger $ n * 1000 - round (diff * 1000000)- threadDelay remaining- now <- getCurrentTime -- TODO Test whether this is a performance penalty- return (now, remaining > 0)- return (runningClock, initTime)-+-- | Tries to achieve real time by using 'waitUTC', see its docs.+waitClock :: (KnownNat n) => Millisecond n+waitClock = Millisecond $ waitUTC $ RescaledClock CountClock ((/ 1000) . fromInteger . getSeconds) --- 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."- ]+data CountClock (n :: Nat) = CountClock --- | 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+instance (Monad m, KnownNat n) => Clock m (CountClock n) where+ type Time (CountClock n) = Seconds Integer+ type Tag (CountClock n) = ()+ initClock cl = pure (count >>> arr ((* natVal cl) >>> Seconds >>> (,())), 0)
+ src/FRP/Rhine/Clock/Realtime/Never.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}++-- | A clock that never ticks.+module FRP.Rhine.Clock.Realtime.Never where++-- base+import Control.Concurrent (threadDelay)+import Control.Monad (forever)+import Control.Monad.IO.Class+import Data.Void (Void)++-- time+import Data.Time.Clock++-- automaton+import Data.Automaton (constM)++-- rhine+import FRP.Rhine.Clock+import FRP.Rhine.Clock.Proxy++-- | A clock that never ticks.+data Never = Never++instance (MonadIO m) => Clock m Never where+ type Time Never = UTCTime+ type Tag Never = Void++ initClock _ = do+ initialTime <- liftIO getCurrentTime+ return+ ( constM (liftIO . forever . threadDelay $ 10 ^ 9)+ , initialTime+ )+ {-# INLINE initClock #-}++instance GetClockProxy Never
src/FRP/Rhine/Clock/Realtime/Stdin.hs view
@@ -1,25 +1,30 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+ {- | In Rhine, event sources are clocks, and so is the console. If this clock is used, every input line on the console triggers one tick of the 'StdinClock'. -}--{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-} module FRP.Rhine.Clock.Realtime.Stdin where --- base+-- time import Data.Time.Clock-import Data.Semigroup -- transformers import Control.Monad.IO.Class +-- text+import Data.Text qualified as Text+import Data.Text.IO qualified as Text++-- automaton+import Data.Automaton (constM)+ -- rhine import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy-import Data.Semigroup {- | A clock that ticks for every line entered on the console,@@ -27,19 +32,20 @@ -} data StdinClock = StdinClock -instance MonadIO m => Clock m StdinClock where+instance (MonadIO m) => Clock m StdinClock where type Time StdinClock = UTCTime- type Tag StdinClock = String+ type Tag StdinClock = Text.Text initClock _ = do initialTime <- liftIO getCurrentTime return ( constM $ liftIO $ do- line <- getLine+ line <- Text.getLine time <- getCurrentTime return (time, line) , initialTime )+ {-# INLINE initClock #-} instance GetClockProxy StdinClock
src/FRP/Rhine/Clock/Select.hs view
@@ -1,3 +1,10 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+ {- | In the Rhine philosophy, _event sources are clocks_. Often, we want to extract certain subevents from event sources,@@ -5,91 +12,65 @@ This module provides a general purpose selection clock that ticks only on certain subevents. -}--{-# LANGUAGE Arrows #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeFamilies #-} module FRP.Rhine.Clock.Select where +-- base+import Control.Arrow+import Data.Maybe (maybeToList)++-- automaton+import Data.Automaton (Automaton, concatS)+ -- rhine import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy-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. --- | 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.+ 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,- -- or 'Just a' if the subclock should tick, with tag 'a'.- , select :: Tag cl -> Maybe a+ { mainClock :: cl+ {- ^ The main clock+ | Return 'Nothing' if no tick of the subclock is required,+ or 'Just a' if the subclock should tick, with tag 'a'.+ -}+ , select :: Tag cl -> Maybe a } +instance (Semigroup a, Semigroup cl) => Semigroup (SelectClock cl a) where+ cl1 <> cl2 =+ SelectClock+ { mainClock = mainClock cl1 <> mainClock cl2+ , select = \tag -> select cl1 tag <> select cl2 tag+ } +instance (Monoid cl, Semigroup a) => Monoid (SelectClock cl a) where+ mempty =+ SelectClock+ { mainClock = mempty+ , select = const mempty+ }+ instance (Monad m, Clock m cl) => Clock m (SelectClock cl a) where type Time (SelectClock cl a) = Time cl- type Tag (SelectClock cl a) = a+ type Tag (SelectClock cl a) = a initClock SelectClock {..} = do (runningClock, initialTime) <- initClock mainClock let runningSelectClock = filterS $ proc _ -> do (time, tag) <- runningClock -< ()- returnA -< (time, ) <$> select tag+ returnA -< (time,) <$> select tag return (runningSelectClock, initialTime)+ {-# INLINE initClock #-} instance GetClockProxy (SelectClock cl a) --- | A universal schedule for two subclocks of the same main clock.--- The main clock must be a 'Semigroup' (e.g. a singleton).-schedSelectClocks- :: (Monad m, Semigroup cl, Clock m cl)- => Schedule m (SelectClock cl a) (SelectClock cl b)-schedSelectClocks = Schedule {..}- where- initSchedule subClock1 subClock2 = do- (runningClock, initialTime) <- initClock- $ mainClock subClock1 <> mainClock subClock2- let- runningSelectClocks = concatS $ proc _ -> do- (time, tag) <- runningClock -< ()- returnA -< catMaybes- [ (time, ) . Left <$> select subClock1 tag- , (time, ) . Right <$> select subClock2 tag ]- 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--- until it returns a value.-filterS :: Monad m => MSF m () (Maybe b) -> MSF m () b+{- | Helper function that runs an 'Automaton' with 'Maybe' output+ until it returns a value.+-}+filterS :: (Monad m) => Automaton m () (Maybe b) -> Automaton m () b filterS = concatS . (>>> arr maybeToList)
+ src/FRP/Rhine/Clock/Skip.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE UndecidableInstances #-}++module FRP.Rhine.Clock.Skip where++import Data.Automaton (hoistS)+import Data.Automaton.Schedule.Trans (SkipT, runSkipT)+import Data.TimeDomain (TimeDomain)+import FRP.Rhine.Clock (Clock (..))++newtype SkipClock cl = SkipClock {getSkipClock :: cl}++instance (TimeDomain (Time cl), Clock (SkipT m) cl, Monad m) => Clock m (SkipClock cl) where+ type Time (SkipClock cl) = Time cl+ type Tag (SkipClock cl) = Tag cl++ initClock SkipClock {getSkipClock} = do+ (runningClock, initialTime) <- runSkipT $ initClock getSkipClock+ pure+ ( hoistS runSkipT runningClock+ , initialTime+ )+ {-# INLINE initClock #-}
+ src/FRP/Rhine/Clock/Trivial.hs view
@@ -0,0 +1,19 @@+module FRP.Rhine.Clock.Trivial where++-- base+import Control.Arrow++-- rhine+import FRP.Rhine.Clock+import FRP.Rhine.Clock.Proxy (GetClockProxy)++-- | A clock that always returns the tick '()'.+data Trivial = Trivial++instance (Monad m) => Clock m Trivial where+ type Time Trivial = ()+ type Tag Trivial = ()+ initClock _ = return (arr $ const ((), ()), ())+ {-# INLINE initClock #-}++instance GetClockProxy Trivial
src/FRP/Rhine/Clock/Util.hs view
@@ -1,24 +1,38 @@ {-# LANGUAGE Arrows #-} {-# LANGUAGE RecordWildCards #-}+ module FRP.Rhine.Clock.Util where +-- base+import Control.Arrow++-- time-domain+import Data.TimeDomain++-- automaton+import Data.Automaton (Automaton, delay)+ -- rhine import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy-import FRP.Rhine.TimeDomain -- * Auxiliary definitions and utilities --- | Given a clock value and an initial time,--- generate a stream of time stamps.-genTimeInfo- :: (Monad m, Clock m cl)- => ClockProxy cl -> Time cl- -> MSF m (Time cl, Tag cl) (TimeInfo cl)+{- | Given a clock value and an initial time,+ generate a stream of time stamps.+-}+genTimeInfo ::+ (Monad m, Clock m cl) =>+ ClockProxy cl ->+ Time cl ->+ Automaton m (Time cl, Tag cl) (TimeInfo cl) genTimeInfo _ initialTime = proc (absolute, tag) -> do- lastTime <- iPre initialTime -< absolute- returnA -< TimeInfo- { sinceLast = absolute `diffTime` lastTime- , sinceInit = absolute `diffTime` initialTime- , ..- }+ lastTime <- delay initialTime -< absolute+ returnA+ -<+ TimeInfo+ { sinceLast = absolute `diffTime` lastTime+ , sinceInit = absolute `diffTime` initialTime+ , ..+ }+{-# INLINE genTimeInfo #-}
src/FRP/Rhine/Reactimation.hs view
@@ -1,31 +1,19 @@+{-# LANGUAGE GADTs #-}+ {- | Run closed 'Rhine's (which are signal functions together with matching clocks) as main loops. -}--{-# LANGUAGE Arrows #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RecordWildCards #-} module FRP.Rhine.Reactimation where --- base-import Control.Monad ((>=>))-import Data.Functor (void)---- dunai-import Data.MonadicStreamFunction.InternalCore- -- rhine+import FRP.Rhine.ClSF.Core import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy-import FRP.Rhine.ClSF.Core-import FRP.Rhine.Reactimation.ClockErasure import FRP.Rhine.Reactimation.Combinators import FRP.Rhine.Schedule import FRP.Rhine.Type -- -- * Running a Rhine {- |@@ -55,24 +43,49 @@ main = flow $ mainSF @@ clock @ -}+ -- TODO Can we chuck the constraints into Clock m cl?-flow- :: ( Monad m, Clock m cl- , GetClockProxy cl- , Time cl ~ Time (In cl)- , Time cl ~ Time (Out cl)- )- => Rhine m cl () () -> m ()+flow ::+ ( Monad m+ , Clock m cl+ , GetClockProxy cl+ , Time cl ~ Time (In cl)+ , Time cl ~ Time (Out cl)+ ) =>+ Rhine m cl () () ->+ m void flow rhine = do- msf <- eraseClock rhine- reactimate $ msf >>> arr (const ())+ automaton <- eraseClock rhine+ reactimate $ automaton >>> arr (const ())+{-# INLINE flow #-} --- | Run a synchronous 'ClSF' with its clock as a main loop,--- similar to Yampa's, or Dunai's, 'reactimate'.-reactimateCl- :: ( Monad m, Clock m cl- , GetClockProxy cl- , cl ~ In cl, cl ~ Out cl- )- => cl -> ClSF m cl () () -> m ()+{- | Like 'flow', but with the type signature specialized to @m ()@.++This is sometimes useful when dealing with ambiguous types.+-}+flow_ ::+ ( Monad m+ , Clock m cl+ , GetClockProxy cl+ , Time cl ~ Time (In cl)+ , Time cl ~ Time (Out cl)+ ) =>+ Rhine m cl () () ->+ m ()+flow_ = flow++{- | Run a synchronous 'ClSF' with its clock as a main loop,+ similar to Yampa's, or Dunai's, 'reactimate'.+-}+reactimateCl ::+ ( Monad m+ , Clock m cl+ , GetClockProxy cl+ , cl ~ In cl+ , cl ~ Out cl+ ) =>+ cl ->+ ClSF m cl () () ->+ m () reactimateCl cl clsf = flow $ clsf @@ cl+{-# INLINE reactimateCl #-}
src/FRP/Rhine/Reactimation/ClockErasure.hs view
@@ -1,111 +1,80 @@-{- |-Translate clocked signal processing components to stream functions without explicit clock types.+{-# LANGUAGE Arrows #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} +{- | Translate clocked signal processing components to stream functions without explicit clock types.+ This module is not meant to be used externally, and is thus not exported from 'FRP.Rhine'. -}-{-# LANGUAGE Arrows #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-} module FRP.Rhine.Reactimation.ClockErasure where --- base-import Control.Monad (join)-import Data.Maybe (fromJust, fromMaybe)---- dunai-import Control.Monad.Trans.MSF.Reader-import Data.MonadicStreamFunction-import Data.MonadicStreamFunction.InternalCore+-- automaton+import Data.Automaton.Trans.Reader+import Data.Stream.Result (Result (..)) -- rhine+import FRP.Rhine.ClSF hiding (runReaderS) import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy import FRP.Rhine.Clock.Util-import FRP.Rhine.ClSF hiding (runReaderS) import FRP.Rhine.ResamplingBuffer-import FRP.Rhine.Schedule-import FRP.Rhine.SN+import FRP.Rhine.SN.Type (SN (..)) --- | Run a clocked signal function as a monadic stream function,--- accepting the timestamps and tags as explicit inputs.-eraseClockClSF- :: (Monad m, Clock m cl)- => ClockProxy cl -> Time cl- -> ClSF m cl a b- -> MSF m (Time cl, Tag cl, a) b+{- | Run a clocked signal function as an automaton,+ accepting the timestamps and tags as explicit inputs.+-}+eraseClockClSF ::+ (Monad m, Clock m cl) =>+ ClockProxy cl ->+ Time cl ->+ ClSF m cl a b ->+ Automaton m (Time cl, Tag cl, a) b eraseClockClSF proxy initialTime clsf = proc (time, tag, a) -> do timeInfo <- genTimeInfo proxy initialTime -< (time, tag)- runReaderS clsf -< (timeInfo, a)---- | Run a signal network as a monadic stream function.------ Depending on the incoming clock,--- input data may need to be provided,--- and depending on the outgoing clock,--- output data may be generated.--- There are thus possible invalid inputs,--- which 'eraseClockSN' does not gracefully handle.-eraseClockSN- :: (Monad m, Clock m cl, GetClockProxy cl)- => Time cl- -> SN m cl a b- -> MSF m (Time cl, Tag cl, Maybe a) (Maybe b)+ runReaderS clsf -< (timeInfo, a)+{-# INLINE eraseClockClSF #-} --- A synchronous signal network is run by erasing the clock from the clocked signal function.-eraseClockSN initialTime sn@(Synchronous clsf) = proc (time, tag, Just a) -> do- b <- eraseClockClSF (toClockProxy sn) initialTime clsf -< (time, tag, a)- returnA -< Just b+{- | Remove the signal network type abstraction and reveal the underlying automaton. --- A sequentially composed signal network may either be triggered in its first component,--- or its second component. In either case,--- the resampling buffer (which connects the two components) may be triggered,--- but only if the outgoing clock of the first component ticks,--- or the incoming clock of the second component ticks.-eraseClockSN initialTime (Sequential sn1 resBuf sn2) =- let- proxy1 = toClockProxy sn1- proxy2 = toClockProxy sn2- in proc (time, tag, maybeA) -> do- resBufIn <- case tag of- Left tagL -> do- maybeB <- eraseClockSN initialTime sn1 -< (time, tagL, maybeA)- returnA -< Left <$> ((time, , ) <$> outTag proxy1 tagL <*> maybeB)- Right tagR -> do- returnA -< Right <$> (time, ) <$> inTag proxy2 tagR- maybeC <- mapMaybeS $ eraseClockResBuf (outProxy proxy1) (inProxy proxy2) initialTime resBuf -< resBufIn- case tag of- Left _ -> do- returnA -< Nothing- Right tagR -> do- eraseClockSN initialTime sn2 -< (time, tagR, join maybeC)+* To drive the network, the timestamps and tags of the clock are needed+* Since the input and output clocks are not always guaranteed to tick, the inputs and outputs are 'Maybe'.+-}+eraseClockSN ::+ -- | Initial time+ Time cl ->+ -- The original signal network+ SN m cl a b ->+ Automaton m (Time cl, Tag cl, Maybe a) (Maybe b)+eraseClockSN time = flip runReader time . getSN+{-# INLINE eraseClockSN #-} -eraseClockSN initialTime (Parallel snL snR) = proc (time, tag, maybeA) -> do- case tag of- Left tagL -> eraseClockSN initialTime snL -< (time, tagL, maybeA)- Right tagR -> eraseClockSN initialTime snR -< (time, tagR, maybeA)+{- | Translate a resampling buffer into an automaton. --- | Translate a resampling buffer into a monadic stream function.------ The input decides whether the buffer is to accept input or has to produce output.--- (In the latter case, only time information is provided.)-eraseClockResBuf- :: ( Monad m- , Clock m cl1, Clock m cl2- , Time cl1 ~ Time cl2- )- => ClockProxy cl1 -> ClockProxy cl2 -> Time cl1- -> ResBuf m cl1 cl2 a b- -> MSF m (Either (Time cl1, Tag cl1, a) (Time cl2, Tag cl2)) (Maybe b)-eraseClockResBuf proxy1 proxy2 initialTime resBuf0 = feedback resBuf0 $ proc (input, resBuf) -> do+ The input decides whether the buffer is to accept input or has to produce output.+ (In the latter case, only time information is provided.)+-}+eraseClockResBuf ::+ ( Monad m+ , Clock m cl1+ , Clock m cl2+ , Time cl1 ~ Time cl2+ ) =>+ ClockProxy cl1 ->+ ClockProxy cl2 ->+ Time cl1 ->+ ResBuf m cl1 cl2 a b ->+ Automaton m (Either (Time cl1, Tag cl1, a) (Time cl2, Tag cl2)) (Maybe b)+eraseClockResBuf proxy1 proxy2 initialTime ResamplingBuffer {buffer, put, get} = feedback buffer $ proc (input, resBuf) -> do case input of Left (time1, tag1, a) -> do- timeInfo1 <- genTimeInfo proxy1 initialTime -< (time1, tag1)- resBuf' <- arrM (uncurry $ uncurry put) -< ((resBuf, timeInfo1), a)- returnA -< (Nothing, resBuf')+ timeInfo1 <- genTimeInfo proxy1 initialTime -< (time1, tag1)+ resBuf' <- arrM (uncurry $ uncurry put) -< ((timeInfo1, a), resBuf)+ returnA -< (Nothing, resBuf') Right (time2, tag2) -> do- timeInfo2 <- genTimeInfo proxy2 initialTime -< (time2, tag2)- (b, resBuf') <- arrM (uncurry get) -< (resBuf, timeInfo2)- returnA -< (Just b, resBuf')+ timeInfo2 <- genTimeInfo proxy2 initialTime -< (time2, tag2)+ Result resBuf' b <- arrM (uncurry get) -< (timeInfo2, resBuf)+ returnA -< (Just b, resBuf')+{-# INLINE eraseClockResBuf #-}
src/FRP/Rhine/Reactimation/Combinators.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+ {- | Combinators to create 'Rhine's (main programs) from basic components such as 'ClSF's, clocks, 'ResamplingBuffer's and 'Schedule's.@@ -11,69 +15,56 @@ * @*@ composes parallely. * @>@ composes sequentially. -}--{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}- module FRP.Rhine.Reactimation.Combinators where - -- rhine+import FRP.Rhine.ClSF.Core import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy-import FRP.Rhine.ClSF.Core import FRP.Rhine.ResamplingBuffer-import FRP.Rhine.Schedule import FRP.Rhine.SN import FRP.Rhine.SN.Combinators+import FRP.Rhine.Schedule import FRP.Rhine.Type - -- * Combinators and syntactic sugar for high-level composition of signal networks. - infix 5 @@--- | Create a synchronous 'Rhine' by combining a clocked signal function with a matching clock.--- Synchronicity is ensured by requiring that data enters (@In cl@)--- and leaves (@Out cl@) the system at the same as it is processed (@cl@).-(@@) :: ( cl ~ In cl- , cl ~ Out cl )- => ClSF m cl a b -> cl -> Rhine m cl a b-(@@) = 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+{- FOURMOLU_DISABLE -}+{- | Create a synchronous 'Rhine' by combining a clocked signal function with a matching clock.+ Synchronicity is ensured by requiring that data enters (@In cl@)+ and leaves (@Out cl@) the system at the same as it is processed (@cl@).+-}+(@@) ::+ ( cl ~ In cl+ , cl ~ Out cl+ , Monad m+ , Clock m cl+ , GetClockProxy cl+ ) =>+ ClSF m cl a b ->+ cl ->+ Rhine m cl a b+(@@) = Rhine . synchronous+{-# INLINE (@@) #-} --- | A purely syntactical convenience construction--- enabling quadruple syntax for sequential composition, as described below.+{- | A purely syntactical convenience construction+ enabling quadruple syntax for sequential composition, as described below.+-} infix 2 >---data RhineAndResamplingPoint m cl1 cl2 a c = forall b.- RhineAndResamplingPoint (Rhine m cl1 a b) (ResamplingPoint m cl1 cl2 b c) --- | Syntactic sugar for 'RhineAndResamplingPoint'.-(>--) :: Rhine m cl1 a b- -> ResamplingPoint m cl1 cl2 b c- -> RhineAndResamplingPoint m cl1 cl2 a c-(>--) = RhineAndResamplingPoint+data RhineAndResamplingBuffer m cl1 inCl2 a c+ = forall b.+ RhineAndResamplingBuffer (Rhine m cl1 a b) (ResamplingBuffer m (Out cl1) inCl2 b c) +-- | Syntactic sugar for 'RhineAndResamplingBuffer'.+(>--) ::+ Rhine m cl1 a b ->+ ResamplingBuffer m (Out cl1) inCl2 b c ->+ RhineAndResamplingBuffer m cl1 inCl2 a c+(>--) = RhineAndResamplingBuffer+ {- | The combinators for sequential composition allow for the following syntax: @@@ -86,108 +77,125 @@ 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+rh :: Rhine m (SequentialClock cl1 cl2) a d+rh = rh1 >-- rb --> 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 (Out cl2)- , Clock m (In cl1), Clock m (In cl2)- , GetClockProxy cl1, GetClockProxy cl2- )- => RhineAndResamplingPoint m cl1 cl2 a b- -> Rhine m cl2 b c- -> Rhine m (SequentialClock m cl1 cl2) a c-RhineAndResamplingPoint (Rhine sn1 cl1) (ResamplingPoint rb cc) --> (Rhine sn2 cl2)- = Rhine (Sequential sn1 rb sn2) (SequentialClock cl1 cl2 cc)---- | 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+(-->) ::+ ( Clock m cl1+ , Clock m cl2+ , Monad m+ , Time cl1 ~ Time cl2+ , Time (Out cl1) ~ Time cl1+ , Time (In cl2) ~ Time cl2+ , Clock m (Out cl1), Clock m (Out cl2)+ , Clock m (In cl1), Clock m (In cl2)+ , In cl2 ~ inCl2+ , GetClockProxy cl1, GetClockProxy cl2+ ) =>+ RhineAndResamplingBuffer m cl1 inCl2 a b ->+ Rhine m cl2 b c ->+ Rhine m (SequentialClock cl1 cl2) a c+RhineAndResamplingBuffer (Rhine sn1 cl1) rb --> (Rhine sn2 cl2) =+ Rhine (sequential sn1 rb sn2) (SequentialClock cl1 cl2) {- | The combinators for parallel composition allow for the following syntax: @-rh1 :: Rhine m clL a b+rh1 :: Rhine m clL a b rh1 = ... -rh2 :: Rhine m clR a c+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+rh :: Rhine m (ParallelClock clL clR) a (Either b c)+rh = rh1 +\@+ rh2 @ -}-infix 3 @++-(@++)- :: ( Monad m, Clock m clL, Clock m clR- , Clock m (Out clL), Clock m (Out clR)- , GetClockProxy clL, GetClockProxy clR- , Time clL ~ Time (Out clL), Time clR ~ Time (Out clR)- , Time clL ~ Time (In clL), Time clR ~ Time (In clR)- , Time clL ~ Time clR- )- => RhineParallelAndSchedule m clL clR a b- -> Rhine m clR a c- -> Rhine m (ParallelClock m clL clR) a (Either b c)-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+infix 3 +@++(+@+) ::+ ( Monad m, Clock m clL, Clock m clR+ , Clock m (Out clL), Clock m (Out clR)+ , GetClockProxy clL, GetClockProxy clR+ , Time clL ~ Time (Out clL), Time clR ~ Time (Out clR)+ , Time clL ~ Time (In clL), Time clR ~ Time (In clR)+ , Time clL ~ Time clR+ ) =>+ Rhine m clL a b ->+ Rhine m clR a c ->+ Rhine m (ParallelClock clL clR) a (Either b c)+Rhine sn1 clL +@+ Rhine sn2 clR =+ Rhine (sn1 ++++ sn2) (ParallelClock clL clR) {- | The combinators for parallel composition allow for the following syntax: @-rh1 :: Rhine m clL a b+rh1 :: Rhine m clL a b rh1 = ... -rh2 :: Rhine m clR a b+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+rh :: Rhine m (ParallelClock clL clR) a b+rh = rh1 |\@| rh2 @ -}-infix 3 @||-(@||)- :: ( Monad m, Clock m clL, Clock m clR- , Clock m (Out clL), Clock m (Out clR)- , GetClockProxy clL, GetClockProxy clR- , Time clL ~ Time (Out clL), Time clR ~ Time (Out clR)- , Time clL ~ Time (In clL), Time clR ~ Time (In clR)- , Time clL ~ Time clR- )- => RhineParallelAndSchedule m clL clR a b- -> Rhine m clR a b- -> Rhine m (ParallelClock m clL clR) a b-RhineParallelAndSchedule (Rhine sn1 clL) schedule @|| (Rhine sn2 clR)- = Rhine (sn1 |||| sn2) (ParallelClock clL clR schedule)+infix 3 |@|++(|@|) ::+ ( Monad m+ , Clock m clL+ , Clock m clR+ , Clock m (Out clL)+ , Clock m (Out clR)+ , GetClockProxy clL+ , GetClockProxy clR+ , Time clL ~ Time (Out clL)+ , Time clR ~ Time (Out clR)+ , Time clL ~ Time (In clL)+ , Time clR ~ Time (In clR)+ , Time clL ~ Time clR+ ) =>+ Rhine m clL a b ->+ Rhine m clR a b ->+ Rhine m (ParallelClock clL clR) a b+Rhine sn1 clL |@| Rhine sn2 clR =+ Rhine (sn1 |||| sn2) (ParallelClock clL clR)++-- | Postcompose a 'Rhine' with a pure function.+(@>>^) ::+ Monad m =>+ Rhine m cl a b ->+ (b -> c) ->+ Rhine m cl a c+Rhine sn cl @>>^ f = Rhine (sn >>>^ f) cl++-- | Precompose a 'Rhine' with a pure function.+(^>>@) ::+ Monad m =>+ (a -> b) ->+ Rhine m cl b c ->+ Rhine m cl a c+f ^>>@ Rhine sn cl = Rhine (f ^>>> sn) cl++-- | Postcompose a 'Rhine' with a 'ClSF'.+(@>-^) ::+ ( Clock m (Out cl), GetClockProxy cl, Monad m+ , Time cl ~ Time (Out cl)+ ) =>+ Rhine m cl a b ->+ ClSF m (Out cl) b c ->+ Rhine m cl a c+Rhine sn cl @>-^ clsf = Rhine (sn >--^ clsf) cl++-- | Precompose a 'Rhine' with a 'ClSF'.+(^->@) ::+ ( Clock m (In cl), GetClockProxy cl, Monad m+ , Time cl ~ Time (In cl)+ ) =>+ ClSF m (In cl) a b ->+ Rhine m cl b c ->+ Rhine m cl a c+clsf ^->@ Rhine sn cl = Rhine (clsf ^--> sn) cl+{- FOURMOLU_ENABLE -}
src/FRP/Rhine/ResamplingBuffer.hs view
@@ -1,3 +1,8 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+ {- | This module introduces 'ResamplingBuffer's, which are primitives that consume and produce data at different rates.@@ -5,22 +10,21 @@ (resampling) buffers form the boundaries between synchronous signal functions ticking at different speeds. -}+module FRP.Rhine.ResamplingBuffer (+ module FRP.Rhine.ResamplingBuffer,+ module FRP.Rhine.Clock,+)+where -{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies #-}-module FRP.Rhine.ResamplingBuffer- ( module FRP.Rhine.ResamplingBuffer- , module FRP.Rhine.Clock- )- where+-- profunctors+import Data.Profunctor (Profunctor (..)) +-- automaton+import Data.Stream.Result+ -- rhine import FRP.Rhine.Clock --- base-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.@@ -30,7 +34,7 @@ {- | A stateful buffer from which one may 'get' a value, or to which one may 'put' a value, depending on the clocks.-`ResamplingBuffer`s can be clock-polymorphic,+'ResamplingBuffer's can be clock-polymorphic, or specific to certain clocks. * 'm': Monad in which the 'ResamplingBuffer' may have side effects@@ -39,31 +43,57 @@ * 'a': The input type * 'b': The output type -}-data ResamplingBuffer m cla clb a b = ResamplingBuffer- { put- :: TimeInfo cla- -> a- -> m ( ResamplingBuffer m cla clb a b)- -- ^ Store one input value of type 'a' at a given time stamp,- -- and return a continuation.- , get- :: TimeInfo clb- -> m (b, ResamplingBuffer m cla clb a b)- -- ^ Retrieve one output value of type 'b' at a given time stamp,- -- and a continuation.+data ResamplingBuffer m cla clb a b+ = forall s.+ ResamplingBuffer+ { buffer :: s+ -- ^ The internal state of the buffer.+ , put ::+ TimeInfo cla ->+ a ->+ s ->+ m s+ {- ^ Store one input value of type 'a' at a given time stamp,+ and return an updated state.+ -}+ , get ::+ TimeInfo clb ->+ s ->+ m (Result s b)+ {- ^ Retrieve one output value of type 'b' at a given time stamp,+ and an updated state.+ -} } -- | A type synonym to allow for abbreviation. type ResBuf m cla clb a b = ResamplingBuffer m cla clb a b - -- | Hoist a 'ResamplingBuffer' along a monad morphism.-hoistResamplingBuffer- :: (Monad m1, Monad m2)- => (forall c. m1 c -> m2 c)- -> ResamplingBuffer m1 cla clb a b- -> ResamplingBuffer m2 cla clb a b-hoistResamplingBuffer hoist ResamplingBuffer {..} = ResamplingBuffer- { put = (((hoistResamplingBuffer hoist <$>) . hoist) .) . put- , get = (second (hoistResamplingBuffer hoist) <$>) . hoist . get- }+hoistResamplingBuffer ::+ (Monad m1, Monad m2) =>+ (forall c. m1 c -> m2 c) ->+ ResamplingBuffer m1 cla clb a b ->+ ResamplingBuffer m2 cla clb a b+hoistResamplingBuffer morph ResamplingBuffer {..} =+ ResamplingBuffer+ { put = ((morph .) .) . put+ , get = (morph .) . get+ , buffer+ }++instance (Functor m) => Profunctor (ResamplingBuffer m cla clb) where+ lmap f ResamplingBuffer {put, get, buffer} =+ ResamplingBuffer+ { put = (. f) <$> put+ , get+ , buffer+ }+ rmap = fmap++instance (Functor m) => Functor (ResamplingBuffer m cla clb a) where+ fmap f ResamplingBuffer {put, get, buffer} =+ ResamplingBuffer+ { put+ , get = fmap (fmap (fmap f)) <$> get+ , buffer+ }
+ src/FRP/Rhine/ResamplingBuffer/ClSF.hs view
@@ -0,0 +1,45 @@+{- |+Collect and process all incoming values statefully and with time stamps.+-}+module FRP.Rhine.ResamplingBuffer.ClSF where++-- transformers+import Control.Monad.Trans.Reader (ReaderT, runReaderT)++-- automaton+import Data.Automaton hiding (toStreamT)+import Data.Stream+import Data.Stream.Optimized (toStreamT)+import Data.Stream.Result (mapResultState)++-- rhine+import FRP.Rhine.ClSF.Core hiding (toStreamT)+import FRP.Rhine.ResamplingBuffer++{- | Given a clocked signal function that accepts+ a varying number of timestamped inputs (a list),+ a `ResamplingBuffer` can be formed+ that collects all this input and steps the signal function+ whenever output is requested.+-}+clsfBuffer ::+ (Monad m) =>+ {- | The clocked signal function that consumes+ and a list of timestamped inputs,+ and outputs a single value.+ The list will contain the /newest/ element in the head.+ -}+ ClSF m cl2 [(TimeInfo cl1, a)] b ->+ ResamplingBuffer m cl1 cl2 a b+clsfBuffer = clsfBuffer' . toStreamT . getAutomaton+ where+ clsfBuffer' ::+ (Monad m) =>+ StreamT (ReaderT [(TimeInfo cl1, a)] (ReaderT (TimeInfo cl2) m)) b ->+ ResamplingBuffer m cl1 cl2 a b+ clsfBuffer' StreamT {state, step} =+ ResamplingBuffer+ { buffer = (state, [])+ , put = \ti1 a (s, as) -> pure (s, (ti1, a) : as)+ , get = \ti2 (s, as) -> mapResultState (,[]) <$> runReaderT (runReaderT (step s) as) ti2+ }
src/FRP/Rhine/ResamplingBuffer/Collect.hs view
@@ -1,55 +1,64 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RecordWildCards #-}+ {- | Resampling buffers that collect the incoming data in some data structure and release all of it on output. -}--{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE RecordWildCards #-} module FRP.Rhine.ResamplingBuffer.Collect where -- containers import Data.Sequence +-- automaton+import Data.Stream.Result (Result (..))+ -- rhine import FRP.Rhine.ResamplingBuffer import FRP.Rhine.ResamplingBuffer.Timeless --- | Collects all input in a list, with the newest element at the head,--- which is returned and emptied upon `get`.-collect :: Monad m => ResamplingBuffer m cl1 cl2 a [a]+{- | Collects all input in a list, with the newest element at the head,+ which is returned and emptied upon 'get'.+-}+collect :: (Monad m) => ResamplingBuffer m cl1 cl2 a [a] collect = timelessResamplingBuffer AsyncMealy {..} [] where amPut as a = return $ a : as- amGet as = return (as, [])-+ amGet as = return $! Result [] as --- | Reimplementation of 'collect' with sequences,--- which gives a performance benefit if the sequence needs to be reversed or searched.-collectSequence :: Monad m => ResamplingBuffer m cl1 cl2 a (Seq a)+{- | Reimplementation of 'collect' with sequences,+ which gives a performance benefit if the sequence needs to be reversed or searched.+-}+collectSequence :: (Monad m) => ResamplingBuffer m cl1 cl2 a (Seq a) collectSequence = timelessResamplingBuffer AsyncMealy {..} empty where amPut as a = return $ a <| as- amGet as = return (as, empty)+ amGet as = return $! Result empty as --- | 'pureBuffer' collects all input values lazily in a list--- and processes it when output is required.--- Semantically, @pureBuffer f == collect >>-^ arr f@,--- but 'pureBuffer' is slightly more efficient.-pureBuffer :: Monad m => ([a] -> b) -> ResamplingBuffer m cl1 cl2 a b+{- | 'pureBuffer' collects all input values lazily in a list+ and processes it when output is required.+ Semantically, @pureBuffer f == collect >>-^ arr f@,+ but 'pureBuffer' is slightly more efficient.+-}+pureBuffer :: (Monad m) => ([a] -> b) -> ResamplingBuffer m cl1 cl2 a b pureBuffer f = timelessResamplingBuffer AsyncMealy {..} [] where amPut as a = return (a : as)- amGet as = return (f as, [])+ amGet as = return $! Result [] $! f as -- TODO Test whether strictness works here, or consider using deepSeq--- | A buffer collecting all incoming values with a folding function.--- It is strict, i.e. the state value 'b' is calculated on every 'put'.-foldBuffer- :: Monad m- => (a -> b -> b) -- ^ The folding function- -> b -- ^ The initial value- -> ResamplingBuffer m cl1 cl2 a b++{- | A buffer collecting all incoming values with a folding function.+ It is strict, i.e. the state value 'b' is calculated on every 'put'.+-}+foldBuffer ::+ (Monad m) =>+ -- | The folding function+ (a -> b -> b) ->+ -- | The initial value+ b ->+ ResamplingBuffer m cl1 cl2 a b foldBuffer f = timelessResamplingBuffer AsyncMealy {..} where amPut b a = let !b' = f a b in return b'- amGet b = return (b, b)+ amGet b = return $! Result b b
src/FRP/Rhine/ResamplingBuffer/FIFO.hs view
@@ -1,8 +1,8 @@+{-# LANGUAGE RecordWildCards #-}+ {- | Different implementations of FIFO buffers. -}--{-# LANGUAGE RecordWildCards #-} module FRP.Rhine.ResamplingBuffer.FIFO where -- base@@ -11,37 +11,42 @@ -- containers import Data.Sequence +-- automaton+import Data.Stream.Result (Result (..))+ -- rhine import FRP.Rhine.ResamplingBuffer import FRP.Rhine.ResamplingBuffer.Timeless -- * FIFO (first-in-first-out) buffers --- | An unbounded FIFO buffer.--- If the buffer is empty, it will return 'Nothing'.-fifoUnbounded :: Monad m => ResamplingBuffer m cl1 cl2 a (Maybe a)+{- | An unbounded FIFO buffer.+ If the buffer is empty, it will return 'Nothing'.+-}+fifoUnbounded :: (Monad m) => ResamplingBuffer m cl1 cl2 a (Maybe a) fifoUnbounded = timelessResamplingBuffer AsyncMealy {..} empty where amPut as a = return $ a <| as- amGet as = case viewr as of- EmptyR -> return (Nothing, empty)- as' :> a -> return (Just a , as' )+ amGet as = case viewr as of+ EmptyR -> return $! Result empty Nothing+ as' :> a -> return $! Result as' (Just a) --- | 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)+{- | A bounded FIFO buffer that forgets the oldest values when the size is above a given threshold.+ If the buffer is empty, it will return 'Nothing'.+-}+fifoBounded :: (Monad m) => Int -> ResamplingBuffer m cl1 cl2 a (Maybe a) fifoBounded threshold = timelessResamplingBuffer AsyncMealy {..} empty where amPut as a = return $ take threshold $ a <| as amGet as = case viewr as of- EmptyR -> return (Nothing, empty)- as' :> a -> return (Just a , as' )+ EmptyR -> return $! Result empty Nothing+ as' :> a -> return $! Result as' (Just a) -- | An unbounded FIFO buffer that also returns its current size.-fifoWatch :: Monad m => ResamplingBuffer m cl1 cl2 a (Maybe a, Int)+fifoWatch :: (Monad m) => ResamplingBuffer m cl1 cl2 a (Maybe a, Int) fifoWatch = timelessResamplingBuffer AsyncMealy {..} empty where amPut as a = return $ a <| as- amGet as = case viewr as of- EmptyR -> return ((Nothing, 0 ), empty)- as' :> a -> return ((Just a , length as'), as' )+ amGet as = case viewr as of+ EmptyR -> return $! Result empty (Nothing, 0)+ as' :> a -> return $! Result as' (Just a, length as')
src/FRP/Rhine/ResamplingBuffer/Interpolation.hs view
@@ -1,11 +1,11 @@-{- |-Interpolation buffers.--}- {-# LANGUAGE Arrows #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-}++{- |+Interpolation buffers.+-} module FRP.Rhine.ResamplingBuffer.Interpolation where -- containers@@ -14,29 +14,37 @@ -- simple-affine-space import Data.VectorSpace +-- time-domain+import Data.TimeDomain (Diff)+ -- rhine import FRP.Rhine.ClSF import FRP.Rhine.ResamplingBuffer-import FRP.Rhine.ResamplingBuffer.Util import FRP.Rhine.ResamplingBuffer.KeepLast+import FRP.Rhine.ResamplingBuffer.Util -- | A simple linear interpolation based on the last calculated position and velocity.-linear- :: ( Monad m, Clock m cl1, Clock m cl2- , VectorSpace v s- , s ~ Diff (Time cl1)- , s ~ Diff (Time cl2)- )- => v -- ^ The initial velocity (derivative of the signal)- -> v -- ^ The initial position- -> ResamplingBuffer m cl1 cl2 v v-linear initVelocity initPosition- = (derivativeFrom initPosition &&& clId) &&& timeInfoOf sinceInit- ^->> keepLast ((initVelocity, initPosition), 0)- >>-^ proc ((velocity, lastPosition), sinceInit1) -> do- sinceInit2 <- timeInfoOf sinceInit -< ()- let diff = sinceInit2 - sinceInit1- returnA -< lastPosition ^+^ diff *^ velocity+linear ::+ ( Monad m+ , Clock m cl1+ , Clock m cl2+ , VectorSpace v s+ , Num s+ , s ~ Diff (Time cl1)+ , s ~ Diff (Time cl2)+ ) =>+ -- | The initial velocity (derivative of the signal)+ v ->+ -- | The initial position+ v ->+ ResamplingBuffer m cl1 cl2 v v+linear initVelocity initPosition =+ (derivativeFrom initPosition &&& clId) &&& timeInfoOf sinceInit+ ^->> keepLast ((initVelocity, initPosition), 0)+ >>-^ proc ((velocity, lastPosition), sinceInit1) -> do+ sinceInit2 <- timeInfoOf sinceInit -< ()+ let diff = sinceInit2 - sinceInit1+ returnA -< lastPosition ^+^ diff *^ velocity {- | sinc-Interpolation, or Whittaker-Shannon-Interpolation.@@ -49,45 +57,56 @@ the buffer only remembers the past values within a given window, which should be chosen much larger than the average time between @cl1@'s ticks. -}-sinc- :: ( Monad m, Clock m cl1, Clock m cl2- , VectorSpace v s- , Ord (s)- , Floating (s)- , s ~ Diff (Time cl1)- , s ~ Diff (Time cl2)- )- => s- -- ^ The size of the interpolation window- -- (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+sinc ::+ ( Monad m+ , Clock m cl1+ , Clock m cl2+ , VectorSpace v s+ , Ord s+ , Floating s+ , s ~ Diff (Time cl1)+ , s ~ Diff (Time cl2)+ ) =>+ {- | The size of the interpolation window+ (for how long in the past to remember incoming values)+ -}+ s ->+ ResamplingBuffer m cl1 cl2 v v+sinc windowSize =+ historySince windowSize+ ^->> keepLast empty >>-^ proc as -> do+ sinceInit2 <- sinceInitS -< ()+ returnA -< vectorSum $ mkSinc sinceInit2 <$> as where- mkSinc sinceInit2 (TimeInfo {..}, as)- = let t = pi * (sinceInit2 - sinceInit) / sinceLast- in (sin t / t) *^ as+ mkSinc sinceInit2 (TimeInfo {..}, as) =+ let t = pi * (sinceInit2 - sinceInit) / sinceLast+ in (sin t / t) *^ as vectorSum = foldr (^+^) zeroVector -- TODO Do we want to give initial values?--- | Interpolates the signal with Hermite splines,--- using 'threePointDerivative'.------ Caution: In order to calculate the derivatives of the incoming signal,--- it has to be delayed by two ticks of @cl1@.--- In a non-realtime situation, a higher quality is achieved--- if the ticks of @cl2@ are delayed by two ticks of @cl1@.-cubic- :: ( Monad m- , VectorSpace v s- , Floating v, Eq v- , s ~ Diff (Time cl1)- , s ~ Diff (Time cl2)- )- => ResamplingBuffer m cl1 cl2 v v-cubic = ((iPre zeroVector &&& threePointDerivative) &&& (sinceInitS >-> iPre 0))- >-> (clId &&& iPre (zeroVector, 0))++{- | Interpolates the signal with Hermite splines,+ using 'threePointDerivative'.++ Caution: In order to calculate the derivatives of the incoming signal,+ it has to be delayed by two ticks of @cl1@.+ In a non-realtime situation, a higher quality is achieved+ if the ticks of @cl2@ are delayed by two ticks of @cl1@.+-}+cubic ::+ ( Monad m+ , VectorSpace v s+ , Floating v+ , Eq v+ , Fractional s+ , s ~ Diff (Time cl1)+ , s ~ Diff (Time cl2)+ ) =>+ ResamplingBuffer m cl1 cl2 v v+{- FOURMOLU_DISABLE -}+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 -< ()@@ -100,3 +119,4 @@ ^+^ (-2 * tcubed + 3 * tsquared ) *^ v ^+^ ( tcubed - tsquared ) *^ dv returnA -< vInter+{- FOURMOLU_ENABLE -}
src/FRP/Rhine/ResamplingBuffer/KeepLast.hs view
@@ -1,19 +1,24 @@+{-# LANGUAGE RecordWildCards #-}+ {- | A buffer keeping the last value, or zero-order hold. -}--{-# LANGUAGE RecordWildCards #-} module FRP.Rhine.ResamplingBuffer.KeepLast where +-- automaton+import Data.Stream.Result (Result (..))++-- rhine import FRP.Rhine.ResamplingBuffer import FRP.Rhine.ResamplingBuffer.Timeless --- | Always keeps the last input value,--- or in case of no input an initialisation value.--- If @cl2@ approximates continuity,--- this behaves like a zero-order hold.-keepLast :: Monad m => a -> ResamplingBuffer m cl1 cl2 a a+{- | Always keeps the last input value,+ or in case of no input an initialisation value.+ If @cl2@ approximates continuity,+ this behaves like a zero-order hold.+-}+keepLast :: (Monad m) => a -> ResamplingBuffer m cl1 cl2 a a keepLast = timelessResamplingBuffer AsyncMealy {..} where- amPut _ a = return a- amGet a = return (a, a)+ amGet a = return $! Result a a+ amPut _ = return
src/FRP/Rhine/ResamplingBuffer/LIFO.hs view
@@ -1,8 +1,8 @@+{-# LANGUAGE RecordWildCards #-}+ {- | Different implementations of LIFO buffers. -}--{-# LANGUAGE RecordWildCards #-} module FRP.Rhine.ResamplingBuffer.LIFO where -- base@@ -11,37 +11,42 @@ -- containers import Data.Sequence +-- automaton+import Data.Stream.Result (Result (..))+ -- 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)+{- | An unbounded LIFO buffer.+ If the buffer is empty, it will return 'Nothing'.+-}+lifoUnbounded :: (Monad m) => ResamplingBuffer m cl1 cl2 a (Maybe a) lifoUnbounded = timelessResamplingBuffer AsyncMealy {..} empty where amPut as a = return $ a <| as- amGet as = case viewl as of- EmptyL -> return (Nothing, empty)- a :< as' -> return (Just a , as' )+ amGet as = case viewl as of+ EmptyL -> return $! Result empty Nothing+ a :< as' -> return $! Result as' (Just a) --- | 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)+{- | A bounded LIFO buffer that forgets the oldest values when the size is above a given threshold.+ If the buffer is empty, it will return 'Nothing'.+-}+lifoBounded :: (Monad m) => Int -> ResamplingBuffer m cl1 cl2 a (Maybe a) lifoBounded threshold = timelessResamplingBuffer AsyncMealy {..} empty where amPut as a = return $ take threshold $ a <| as amGet as = case viewl as of- EmptyL -> return (Nothing, empty)- a :< as' -> return (Just a , as' )+ EmptyL -> return $! Result empty Nothing+ a :< as' -> return $! Result as' (Just a) -- | An unbounded LIFO buffer that also returns its current size.-lifoWatch :: Monad m => ResamplingBuffer m cl1 cl2 a (Maybe a, Int)+lifoWatch :: (Monad m) => ResamplingBuffer m cl1 cl2 a (Maybe a, Int) lifoWatch = timelessResamplingBuffer AsyncMealy {..} empty where amPut as a = return $ a <| as- amGet as = case viewl as of- EmptyL -> return ((Nothing, 0 ), empty)- a :< as' -> return ((Just a , length as'), as' )+ amGet as = case viewl as of+ EmptyL -> return $! Result empty (Nothing, 0)+ a :< as' -> return $! Result as' (Just a, length as')
− src/FRP/Rhine/ResamplingBuffer/MSF.hs
@@ -1,39 +0,0 @@-{- |-Collect and process all incoming values statefully and with time stamps.--}--{-# LANGUAGE RecordWildCards #-}-module FRP.Rhine.ResamplingBuffer.MSF where---- dunai-import Data.MonadicStreamFunction.InternalCore---- rhine-import FRP.Rhine.ResamplingBuffer---- | Given a monadic stream function that accepts--- a varying number of inputs (a list),--- a `ResamplingBuffer` can be formed--- that collects all input in a timestamped list.-msfBuffer- :: Monad m- => MSF m (TimeInfo cl2, [(TimeInfo cl1, a)]) b- -- ^ The monadic stream function that consumes- -- a single time stamp for the moment when an output value is required,- -- and a list of timestamped inputs,- -- and outputs a single value.- -- The list will contain the /newest/ element in the head.- -> ResamplingBuffer m cl1 cl2 a b-msfBuffer = msfBuffer' []- where- msfBuffer'- :: Monad m- => [(TimeInfo cl1, a)]- -> MSF m (TimeInfo cl2, [(TimeInfo cl1, a)]) b- -> ResamplingBuffer m cl1 cl2 a b- msfBuffer' as msf = ResamplingBuffer {..}- where- put ti1 a = return $ msfBuffer' ((ti1, a) : as) msf- get ti2 = do- (b, msf') <- unMSF msf (ti2, as)- return (b, msfBuffer msf')
src/FRP/Rhine/ResamplingBuffer/Timeless.hs view
@@ -1,46 +1,55 @@+{-# LANGUAGE RecordWildCards #-}+ {- | Resampling buffers from asynchronous Mealy machines. These are used in many other modules implementing 'ResamplingBuffer's. -}--{-# LANGUAGE RecordWildCards #-} module FRP.Rhine.ResamplingBuffer.Timeless where +-- automaton+import Data.Stream.Result++-- rhine import FRP.Rhine.ResamplingBuffer --- | An asynchronous, effectful Mealy machine description.--- (Input and output do not happen simultaneously.)--- It can be used to create 'ResamplingBuffer's.+{- | An asynchronous, effectful Mealy machine description.+ (Input and output do not happen simultaneously.)+ It can be used to create 'ResamplingBuffer's.+-}+{- FOURMOLU_DISABLE -} data AsyncMealy m s a b = AsyncMealy- { amPut :: s -> a -> m s -- ^ Given the previous state and an input value, return the new state.- , amGet :: s -> m (b, s) -- ^ Given the previous state, return an output value and a new state.+ { amPut :: s -> a -> m s+ -- ^ Given the previous state and an input value, return the new state.+ , amGet :: s -> m (Result s b)+ -- ^ Given the previous state, return an output value and a new state. }+{- FOURMOLU_ENABLE -} --- | A resampling buffer that is unaware of the time information of the clock,--- and thus clock-polymorphic.--- It is built from an asynchronous Mealy machine description.--- Whenever 'get' is called on @timelessResamplingBuffer machine s@,--- the method 'amGet' is called on @machine@ with state @s@,--- discarding the time stamp. Analogously for 'put'.-timelessResamplingBuffer- :: Monad m- => AsyncMealy m s a b -- The asynchronous Mealy machine from which the buffer is built- -> s -- ^ The initial state- -> ResamplingBuffer m cl1 cl2 a b-timelessResamplingBuffer AsyncMealy {..} = go+{- | A resampling buffer that is unaware of the time information of the clock,+ and thus clock-polymorphic.+ It is built from an asynchronous Mealy machine description.+ Whenever 'get' is called on @timelessResamplingBuffer machine s@,+ the method 'amGet' is called on @machine@ with state @s@,+ discarding the time stamp. Analogously for 'put'.+-}+timelessResamplingBuffer ::+ (Monad m) =>+ -- | The asynchronous Mealy machine from which the buffer is built+ AsyncMealy m s a b ->+ -- | The initial state+ s ->+ ResamplingBuffer m cl1 cl2 a b+timelessResamplingBuffer AsyncMealy {..} buffer = ResamplingBuffer {..} where- go s =- let- put _ a = go <$> amPut s a- get _ = do- (b, s') <- amGet s- return (b, go s')- in ResamplingBuffer {..}+ put _ a s = amPut s a+ get _ = amGet -- | A resampling buffer that only accepts and emits units.-trivialResamplingBuffer :: Monad m => ResamplingBuffer m cl1 cl2 () ()-trivialResamplingBuffer = timelessResamplingBuffer AsyncMealy- { amPut = const (const (return ()))- , amGet = const (return ((), ()))- }- ()+trivialResamplingBuffer :: (Monad m) => ResamplingBuffer m cl1 cl2 () ()+trivialResamplingBuffer =+ timelessResamplingBuffer+ AsyncMealy+ { amPut = const (const (return ()))+ , amGet = const (return $! Result () ())+ }+ ()
src/FRP/Rhine/ResamplingBuffer/Util.hs view
@@ -1,84 +1,183 @@+{-# LANGUAGE RankNTypes #-}+ {- | Several utilities to create 'ResamplingBuffer's. -}--{-# LANGUAGE RankNTypes #-} module FRP.Rhine.ResamplingBuffer.Util where +-- base+import Data.Function ((&))+ -- transformers import Control.Monad.Trans.Reader (runReaderT) --- dunai-import Data.MonadicStreamFunction.InternalCore+-- time-domain+import Data.TimeDomain (TimeDomain (..)) +-- automaton+import Data.Stream (StreamT (..))+import Data.Stream.Internal (JointState (..))+import Data.Stream.Optimized (toStreamT)+import Data.Stream.Result (Result (..), mapResultState)+ -- rhine+import FRP.Rhine.ClSF hiding (step, toStreamT) import FRP.Rhine.Clock-import FRP.Rhine.ClSF import FRP.Rhine.ResamplingBuffer+import FRP.Rhine.Schedule (ParallelClock) -- * Utilities to build 'ResamplingBuffer's from smaller components infix 2 >>-^++{- FOURMOLU_DISABLE -}+ -- | Postcompose a 'ResamplingBuffer' with a matching 'ClSF'.-(>>-^) :: Monad m- => ResamplingBuffer m cl1 cl2 a b- -> ClSF m cl2 b c- -> ResamplingBuffer m cl1 cl2 a c-resBuf >>-^ clsf = ResamplingBuffer put_ get_+(>>-^) ::+ Monad m =>+ ResamplingBuffer m cl1 cl2 a b ->+ ClSF m cl2 b c ->+ ResamplingBuffer m cl1 cl2 a c+resbuf >>-^ clsf = helper resbuf $ toStreamT $ getAutomaton clsf where- put_ theTimeInfo a = (>>-^ clsf) <$> put resBuf theTimeInfo a- get_ theTimeInfo = do- (b, resBuf') <- get resBuf theTimeInfo- (c, clsf') <- unMSF clsf b `runReaderT` theTimeInfo- return (c, resBuf' >>-^ clsf')-+ helper ResamplingBuffer { buffer, put, get} StreamT { state, step} = ResamplingBuffer+ { buffer = JointState buffer state,+ put = \theTimeInfo a (JointState b s) -> (`JointState` s) <$> put theTimeInfo a b+ , get = \theTimeInfo (JointState b s) -> do+ Result b' b <- get theTimeInfo b+ Result s' c <- step s `runReaderT` b `runReaderT` theTimeInfo+ pure $! Result (JointState b' s') c+ } infix 1 ^->>+ -- | Precompose a 'ResamplingBuffer' with a matching 'ClSF'.-(^->>) :: Monad m- => ClSF m cl1 a b- -> ResamplingBuffer m cl1 cl2 b c- -> ResamplingBuffer m cl1 cl2 a c-clsf ^->> resBuf = ResamplingBuffer put_ get_+(^->>) ::+ Monad m =>+ ClSF m cl1 a b ->+ ResamplingBuffer m cl1 cl2 b c ->+ ResamplingBuffer m cl1 cl2 a c+clsf ^->> resBuf = helper (toStreamT (getAutomaton clsf)) resBuf where- put_ theTimeInfo a = do- (b, clsf') <- unMSF clsf a `runReaderT` theTimeInfo- resBuf' <- put resBuf theTimeInfo b- return $ clsf' ^->> resBuf'- get_ theTimeInfo = second (clsf ^->>) <$> get resBuf theTimeInfo-+ helper StreamT {state, step} ResamplingBuffer {buffer, put, get} = ResamplingBuffer+ {+ buffer = JointState buffer state+ , put = \theTimeInfo a (JointState buf s) -> do+ Result s' b <- step s `runReaderT` a `runReaderT` theTimeInfo+ buf' <- put theTimeInfo b buf+ pure $! JointState buf' s'+ , get = \theTimeInfo (JointState buf s) -> mapResultState (`JointState` s) <$> get theTimeInfo buf+ } infixl 4 *-*+ -- | Parallely compose two 'ResamplingBuffer's.-(*-*) :: Monad m- => ResamplingBuffer m cl1 cl2 a b- -> ResamplingBuffer m cl1 cl2 c d- -> ResamplingBuffer m cl1 cl2 (a, c) (b, d)-resBuf1 *-* resBuf2 = ResamplingBuffer put_ get_- where- put_ theTimeInfo (a, c) = do- resBuf1' <- put resBuf1 theTimeInfo a- resBuf2' <- put resBuf2 theTimeInfo c- return $ resBuf1' *-* resBuf2'- get_ theTimeInfo = do- (b, resBuf1') <- get resBuf1 theTimeInfo- (d, resBuf2') <- get resBuf2 theTimeInfo- return ((b, d), resBuf1' *-* resBuf2')+(*-*) ::+ Monad m =>+ ResamplingBuffer m cl1 cl2 a b ->+ ResamplingBuffer m cl1 cl2 c d ->+ ResamplingBuffer m cl1 cl2 (a, c) (b, d)+ResamplingBuffer buf1 put1 get1 *-* ResamplingBuffer buf2 put2 get2 = ResamplingBuffer+ {+ buffer = JointState buf1 buf2+ , put = \theTimeInfo (a, c) (JointState s1 s2) -> do+ s1' <- put1 theTimeInfo a s1+ s2' <- put2 theTimeInfo c s2+ pure $! JointState s1' s2'+ , get = \theTimeInfo (JointState s1 s2) -> do+ Result s1' b <- get1 theTimeInfo s1+ Result s2' d <- get2 theTimeInfo s2+ pure $! Result (JointState s1' s2') (b, d)+ } infixl 4 &-&+ -- | Parallely compose two 'ResamplingBuffer's, duplicating the input.-(&-&) :: Monad m- => ResamplingBuffer m cl1 cl2 a b- -> ResamplingBuffer m cl1 cl2 a c- -> ResamplingBuffer m cl1 cl2 a (b, c)+(&-&) ::+ Monad m =>+ ResamplingBuffer m cl1 cl2 a b ->+ ResamplingBuffer m cl1 cl2 a c ->+ ResamplingBuffer m cl1 cl2 a (b, c) resBuf1 &-& resBuf2 = arr (\a -> (a, a)) ^->> resBuf1 *-* resBuf2 ---- | Given a 'ResamplingBuffer' where the output type depends on the input type polymorphically,--- we can produce a timestamped version that simply annotates every input value--- with the 'TimeInfo' when it arrived.-timestamped- :: Monad m- => (forall b. ResamplingBuffer m cl clf b (f b))- -> ResamplingBuffer m cl clf a (f (a, TimeInfo cl))+{- | Given a 'ResamplingBuffer' where the output type depends on the input type polymorphically,+ we can produce a timestamped version that simply annotates every input value+ with the 'TimeInfo' when it arrived.+-}+timestamped ::+ Monad m =>+ (forall b. ResamplingBuffer m cl clf b (f b)) ->+ ResamplingBuffer m cl clf a (f (a, TimeInfo cl)) timestamped resBuf = (clId &&& timeInfo) ^->> resBuf++infixl 4 |-|++-- | Combine two 'ResamplingBuffer's in parallel input time.+--+-- The resulting 'ResamplingBuffer' will consume input whenever either of the input clocks ticks.+--+-- Caution: The time differences are split up between the two buffers, so the total passed time on the inputs is not the same as on the output.+(|-|) ::+ ( Monad m,+ TimeDomain (Time cl),+ Time clL ~ Time cl,+ Time clR ~ Time cl+ ) =>+ ResamplingBuffer m clL cl a b ->+ ResamplingBuffer m clR cl a c ->+ ResamplingBuffer m (ParallelClock clL clR) cl a (b, c)+ResamplingBuffer stateL putL getL |-| ResamplingBuffer stateR putR getR =+ ResamplingBuffer+ { buffer = JointState (JointState Nothing stateL) (JointState Nothing stateR),+ put = \theTimeInfo a (JointState (JointState lastTimeMaybeL sL) (JointState lastTimeMaybeR sR)) -> do+ let now = absolute theTimeInfo+ case tag theTimeInfo of+ Left tagL -> do+ sL' <- putL (theTimeInfo & retag (const tagL) & fixSinceLast lastTimeMaybeL) a sL+ pure $! JointState (JointState (Just now) sL') (JointState lastTimeMaybeR sR)+ Right tagR -> do+ sR' <- putR (theTimeInfo & retag (const tagR) & fixSinceLast lastTimeMaybeR) a sR+ pure $! JointState (JointState lastTimeMaybeL sL) (JointState (Just now) sR'),+ get = \theTimeInfo (JointState (JointState lastTimeMaybeL sL) (JointState lastTimeMaybeR sR)) -> do+ Result sL' b <- getL theTimeInfo sL+ Result sR' c <- getR theTimeInfo sR+ pure $! Result (JointState (JointState lastTimeMaybeL sL') (JointState lastTimeMaybeR sR')) (b, c)+ }++infixl 4 ||-||++-- | Combine two 'ResamplingBuffer's in parallel output time.+--+-- The resulting 'ResamplingBuffer' will produce output whenever either of the output clocks ticks.+--+-- Caution: The time differences are split up between the two buffers, so the total passed time on the input is not the same as on the outputs.+(||-||) ::+ ( Monad m,+ TimeDomain (Time cl),+ Time clL ~ Time cl,+ Time clR ~ Time cl+ ) =>+ ResamplingBuffer m cl clL a b ->+ ResamplingBuffer m cl clR a b ->+ ResamplingBuffer m cl (ParallelClock clL clR) a b+ResamplingBuffer stateL putL getL ||-|| ResamplingBuffer stateR putR getR =+ ResamplingBuffer+ { buffer = JointState (JointState Nothing stateL) (JointState Nothing stateR),+ put = \theTimeInfo a (JointState (JointState lastTimeMaybeL sL) (JointState lastTimeMaybeR sR)) -> do+ sL' <- putL theTimeInfo a sL+ sR' <- putR theTimeInfo a sR+ pure $! JointState (JointState lastTimeMaybeL sL') (JointState lastTimeMaybeR sR'),+ get = \theTimeInfo (JointState (JointState lastTimeMaybeL sL) (JointState lastTimeMaybeR sR)) -> case tag theTimeInfo of+ Left tagL -> do+ Result sL' b <- getL (theTimeInfo & retag (const tagL) & fixSinceLast lastTimeMaybeL) sL+ pure $! Result (JointState (JointState lastTimeMaybeL sL') (JointState lastTimeMaybeR sR)) b+ Right tagR -> do+ Result sR' b <- getR (theTimeInfo & retag (const tagR) & fixSinceLast lastTimeMaybeR) sR+ pure $! Result (JointState (JointState lastTimeMaybeL sL) (JointState lastTimeMaybeR sR')) b+ }++-- | Helper function for 'ResamplingBuffer's over 'ParallelClock's to fix the 'sinceLast' field of the 'TimeInfo'.+fixSinceLast :: (TimeDomain (Time cl)) => Maybe (Time cl) -> TimeInfo cl -> TimeInfo cl+fixSinceLast lastTimeMaybe theTimeInfo = case lastTimeMaybe of+ Nothing -> theTimeInfo+ Just lastTime -> theTimeInfo {sinceLast = absolute theTimeInfo `diffTime` lastTime}
src/FRP/Rhine/SN.hs view
@@ -1,3 +1,9 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+ {- | Asynchronous signal networks are combinations of clocked signal functions ('ClSF's) and matching 'ResamplingBuffer's,@@ -6,69 +12,151 @@ This module defines the 'SN' type, combinators are found in a submodule. -}+module FRP.Rhine.SN (+ module FRP.Rhine.SN,+ module FRP.Rhine.SN.Type,+) where -{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-module FRP.Rhine.SN where+-- base+import Control.Monad (join) +-- transformers+import Control.Monad.Trans.Reader (reader) +-- automata+import Data.Stream.Result (Result (..))+ -- rhine+import FRP.Rhine.ClSF.Core import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy-import FRP.Rhine.ClSF.Core+import FRP.Rhine.Clock.Util (genTimeInfo)+import FRP.Rhine.Reactimation.ClockErasure import FRP.Rhine.ResamplingBuffer+import FRP.Rhine.SN.Type import FRP.Rhine.Schedule +{- | A synchronous automaton is the basic building block.+ For such an 'SN', data enters and leaves the system at the same rate as it is processed.+-}+synchronous ::+ forall cl m a b.+ (cl ~ In cl, cl ~ Out cl, Monad m, Clock m cl, GetClockProxy cl) =>+ ClSF m cl a b ->+ SN m cl a b+synchronous clsf = SN $ reader $ \initialTime -> proc (time, tag, Just a) -> do+ b <- eraseClockClSF (getClockProxy @cl) initialTime clsf -< (time, tag, a)+ returnA -< Just b+{-# INLINE synchronous #-} -{- | 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.+-- | Two 'SN's may be sequentially composed if there is a matching 'ResamplingBuffer' between them.+sequential ::+ ( Clock m clab+ , Clock m clcd+ , Clock m (Out clab)+ , Clock m (Out clcd)+ , Clock m (In clab)+ , Clock m (In clcd)+ , GetClockProxy clab+ , GetClockProxy clcd+ , Time clab ~ Time clcd+ , Time clab ~ Time (Out clab)+ , Time clcd ~ Time (In clcd)+ , Monad m+ ) =>+ SN m clab a b ->+ ResamplingBuffer m (Out clab) (In clcd) b c ->+ SN m clcd c d ->+ SN m (SequentialClock clab clcd) a d+-- A sequentially composed signal network may either be triggered in its first component,+-- or its second component. In either case,+-- the resampling buffer (which connects the two components) may be triggered,+-- but only if the outgoing clock of the first component ticks,+-- or the incoming clock of the second component ticks.+sequential sn1 resBuf sn2 = SN $ reader $ \initialTime ->+ let+ proxy1 = toClockProxy sn1+ proxy2 = toClockProxy sn2+ in+ proc (time, tag, maybeA) -> do+ resBufIn <- case tag of+ Left tagL -> do+ maybeB <- eraseClockSN initialTime sn1 -< (time, tagL, maybeA)+ returnA -< Left <$> ((time,,) <$> outTag proxy1 tagL <*> maybeB)+ Right tagR -> do+ returnA -< Right . (time,) <$> inTag proxy2 tagR+ maybeC <- mapMaybeS $ eraseClockResBuf (outProxy proxy1) (inProxy proxy2) initialTime resBuf -< resBufIn+ case tag of+ Left _ -> do+ returnA -< Nothing+ Right tagR -> do+ eraseClockSN initialTime sn2 -< (time, tagR, join maybeC)+{-# INLINE sequential #-} -The type parameters are:+-- | Two 'SN's with the same input and output data may be parallely composed.+parallel snL snR = SN $ reader $ \initialTime -> proc (time, tag, maybeA) -> do+ case tag of+ Left tagL -> eraseClockSN initialTime snL -< (time, tagL, maybeA)+ Right tagR -> eraseClockSN initialTime snR -< (time, tagR, maybeA)+{-# INLINE parallel #-} -* '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@.+-- | A 'ClSF' can always be postcomposed onto an 'SN' if the clocks match on the output.+postcompose sn clsf = SN $ reader $ \initialTime ->+ let+ proxy = toClockProxy sn+ in+ proc input@(time, tag, _) -> do+ bMaybe <- eraseClockSN initialTime sn -< input+ mapMaybeS $ eraseClockClSF (outProxy proxy) initialTime clsf -< (time,,) <$> outTag proxy tag <*> bMaybe+{-# INLINE postcompose #-}++-- | A 'ClSF' can always be precomposed onto an 'SN' if the clocks match on the input.+precompose clsf sn = SN $ reader $ \initialTime ->+ let+ proxy = toClockProxy sn+ in+ proc (time, tag, aMaybe) -> do+ bMaybe <- mapMaybeS $ eraseClockClSF (inProxy proxy) initialTime clsf -< (time,,) <$> inTag proxy tag <*> aMaybe+ eraseClockSN initialTime sn -< (time, tag, bMaybe)+{-# INLINE precompose #-}++{- | Data can be looped back to the beginning of an 'SN',+ but it must be resampled since the 'Out' and 'In' clocks are generally different. -}-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- , Clock m (Out clab), Clock m (Out clcd)- , Clock m (In clab), Clock m (In clcd)- , GetClockProxy clab, GetClockProxy clcd- , Time clab ~ Time clcd- , Time clab ~ Time (Out clab)- , Time clcd ~ Time (In clcd)- )- => SN m clab a b- -> ResamplingBuffer m (Out clab) (In clcd) b c- -> SN m clcd c d- -> SN m (SequentialClock m clab clcd) a d- -- | Two 'SN's with the same input and output data may be parallely composed.- Parallel- :: ( Clock m cl1, Clock m cl2- , Clock m (Out cl1), Clock m (Out cl2)- , GetClockProxy cl1, GetClockProxy cl2- , Time cl1 ~ Time (Out cl1)- , Time cl2 ~ Time (Out cl2)- , Time cl1 ~ Time cl2- , Time cl1 ~ Time (In cl1)- , Time cl2 ~ Time (In cl2)- )- => SN m cl1 a b- -> SN m cl2 a b- -> SN m (ParallelClock m cl1 cl2) a b+feedbackSN ResamplingBuffer {buffer, put, get} sn = SN $ reader $ \initialTime ->+ let+ proxy = toClockProxy sn+ in+ feedback buffer $ proc ((time, tag, aMaybe), buf) -> do+ (cMaybe, buf') <- case inTag proxy tag of+ Nothing -> do+ returnA -< (Nothing, buf)+ Just tagIn -> do+ timeInfo <- genTimeInfo (inProxy proxy) initialTime -< (time, tagIn)+ Result buf' c <- arrM $ uncurry get -< (timeInfo, buf)+ returnA -< (Just c, buf')+ bdMaybe <- eraseClockSN initialTime sn -< (time, tag, (,) <$> aMaybe <*> cMaybe)+ case (,) <$> outTag proxy tag <*> bdMaybe of+ Nothing -> do+ returnA -< (Nothing, buf')+ Just (tagOut, (b, d)) -> do+ timeInfo <- genTimeInfo (outProxy proxy) initialTime -< (time, tagOut)+ buf'' <- arrM $ uncurry $ uncurry put -< ((timeInfo, d), buf')+ returnA -< (Just b, buf'')+{-# INLINE feedbackSN #-} -instance GetClockProxy cl => ToClockProxy (SN m cl a b) where- type Cl (SN m cl a b) = cl+-- | Bypass the signal network by forwarding data in parallel through a 'ResamplingBuffer'.+firstResampling sn buf = SN $ reader $ \initialTime ->+ let+ proxy = toClockProxy sn+ in+ proc (time, tag, acMaybe) -> do+ bMaybe <- eraseClockSN initialTime sn -< (time, tag, fst <$> acMaybe)+ let+ resBufInput = case (inTag proxy tag, outTag proxy tag, snd <$> acMaybe) of+ (Just tagIn, _, Just c) -> Just $ Left (time, tagIn, c)+ (_, Just tagOut, _) -> Just $ Right (time, tagOut)+ _ -> Nothing+ dMaybe <- mapMaybeS $ eraseClockResBuf (inProxy proxy) (outProxy proxy) initialTime buf -< resBufInput+ returnA -< (,) <$> bMaybe <*> join dMaybe+{-# INLINE firstResampling #-}
src/FRP/Rhine/SN/Combinators.hs view
@@ -1,30 +1,29 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+ {- | Combinators for composing signal networks sequentially and parallely. -}--{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-} module FRP.Rhine.SN.Combinators where +-- base+import Data.Functor ((<&>)) -- rhine import FRP.Rhine.ClSF.Core+import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy-import FRP.Rhine.ResamplingBuffer.Util-import FRP.Rhine.Schedule import FRP.Rhine.SN-+import FRP.Rhine.Schedule +{- FOURMOLU_DISABLE -} -- | Postcompose a signal network with a pure function. (>>>^) :: Monad m => 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)-+SN {getSN} >>>^ f = SN $ getSN <&> (>>> arr (fmap f)) -- | Precompose a signal network with a pure function. (^>>>)@@ -32,11 +31,29 @@ => (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)+f ^>>> SN {getSN} = SN $ getSN <&> (arr (fmap (fmap f)) >>>) +-- | Postcompose a signal network with a 'ClSF'.+(>--^)+ :: ( GetClockProxy cl , Clock m (Out cl)+ , Time cl ~ Time (Out cl)+ , Monad m+ )+ => SN m cl a b+ -> ClSF m (Out cl) b c+ -> SN m cl a c+(>--^) = postcompose +-- | Precompose a signal network with a 'ClSF'.+(^-->)+ :: ( Clock m (In cl), GetClockProxy cl, Monad m+ , Time cl ~ Time (In cl)+ )+ => ClSF m (In cl) a b+ -> SN m cl b c+ -> SN m cl a c+(^-->) = precompose+ -- | Compose two signal networks on the same clock in data-parallel. -- At one tick of @cl@, both networks are stepped. (****)@@ -44,20 +61,13 @@ => 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 ****"+SN sn1 **** SN sn2 = SN $ do+ sn1' <- sn1+ sn2' <- sn2+ pure $ arr (\(time, tag, mac) -> ((time, tag, fst <$> mac), (time, tag, snd <$> mac))) >>> (sn1' *** sn2') >>> arr (\(mb, md) -> (,) <$> mb <*> md) -- | Compose two signal networks on different clocks in clock-parallel.--- At one tick of @ParClock m cl1 cl2@, one of the networks is stepped,+-- At one tick of @ParClock cl1 cl2@, one of the networks is stepped, -- dependent on which constituent clock has ticked. -- -- Note: This is essentially an infix synonym of 'Parallel'@@ -71,11 +81,11 @@ ) => SN m clL a b -> SN m clR a b- -> SN m (ParClock m clL clR) a b-(||||) = Parallel+ -> SN m (ParClock 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,+-- At one tick of @ParClock cl1 cl2@, one of the networks is stepped, -- dependent on which constituent clock has ticked. (++++) :: ( Monad m, Clock m clL, Clock m clR@@ -87,5 +97,5 @@ ) => SN m clL a b -> SN m clR a c- -> SN m (ParClock m clL clR) a (Either b c)+ -> SN m (ParClock clL clR) a (Either b c) snL ++++ snR = (snL >>>^ Left) |||| (snR >>>^ Right)
+ src/FRP/Rhine/SN/Type.hs view
@@ -0,0 +1,30 @@+module FRP.Rhine.SN.Type where++-- transformers+import Control.Monad.Trans.Reader (Reader)++-- automaton+import Data.Automaton++-- rhine+import FRP.Rhine.Clock+import FRP.Rhine.Clock.Proxy++-- Andras Kovacs' trick: Encode in the domain++{- | 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@.+-}+newtype SN m cl a b = SN {getSN :: Reader (Time cl) (Automaton m (Time cl, Tag cl, Maybe a) (Maybe b))}++instance (GetClockProxy cl) => ToClockProxy (SN m cl a b) where+ type Cl (SN m cl a b) = cl
src/FRP/Rhine/Schedule.hs view
@@ -1,285 +1,172 @@-{- |-'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 OverloadedLists #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} +{- |+The 'MonadSchedule' class is the compatibility mechanism between two different clocks.+It implements a concurrency abstraction that allows the clocks to run at the same time, independently.+Several such clocks running together form composite clocks, such as 'ParallelClock' and 'SequentialClock'.+This module defines these composite clocks,+and utilities to work with them.+-} module FRP.Rhine.Schedule where -- base-import Data.Semigroup---- transformers-import Control.Monad.Trans.Reader+import Control.Arrow --- dunai-import Data.MonadicStreamFunction+-- automaton+import Data.Automaton hiding (toStreamT)+import Data.Automaton.Schedule+import Data.List.NonEmpty as N -- rhine import FRP.Rhine.Clock-import FRP.Rhine.Schedule.Util --- * The schedule type---- | A schedule implements a combination of two clocks.--- It outputs a time stamp and an 'Either' value,--- which specifies which of the two subclocks has ticked.-data Schedule m cl1 cl2- = (Time cl1 ~ Time cl2)- => Schedule- { initSchedule- :: cl1 -> cl2- -> RunningClockInit m (Time cl1) (Either (Tag cl1) (Tag cl2))- }--- The type constraint in the constructor is actually useful when pattern matching on 'Schedule',--- which is interesting since a constraint like 'Monad m' is useful.--- When reformulating as a GADT, it might get used,--- but that would mean that we can't use record syntax.----- * Utilities to create new schedules from existing ones---- | Lift a schedule along a monad morphism.-hoistSchedule- :: (Monad m1, Monad m2)- => (forall a . m1 a -> m2 a)- -> Schedule m1 cl1 cl2- -> Schedule m2 cl1 cl2-hoistSchedule hoist Schedule {..} = Schedule initSchedule'- where- initSchedule' cl1 cl2 = hoist- $ first (hoistMSF hoist) <$> initSchedule cl1 cl2- hoistMSF = morphS- -- TODO This should be a dunai issue---- | Swaps the clocks for a given schedule.-flipSchedule- :: Monad m- => Schedule m cl1 cl2- -> Schedule m cl2 cl1-flipSchedule Schedule {..} = Schedule initSchedule_- where- initSchedule_ cl2 cl1 = first (arr (second swapEither) <<<) <$> initSchedule cl1 cl2---- TODO I originally wanted to rescale a schedule and its clocks at the same time.--- That's rescaleSequentialClock.--- | If a schedule works for two clocks, a rescaling of the clocks--- also applies to the schedule.-rescaledSchedule- :: Monad m- => Schedule m cl1 cl2- -> Schedule m (RescaledClock cl1 time) (RescaledClock cl2 time)-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')+-- * Scheduling +{- | Run two automata concurrently. +Whenever one automaton returns a value, it is returned.+-}+schedulePair :: (Monad m, MonadSchedule m) => Automaton m a b -> Automaton m a b -> Automaton m a b+schedulePair automatonL automatonR = schedule $ automatonL :| [automatonR] --- TODO What's the most general way we can lift a schedule this way?--- | Lifts a schedule into the 'ReaderT' transformer,--- supplying the same environment to its scheduled clocks.-readerSchedule- :: ( Monad m- , Clock (ReaderT r m) cl1, Clock (ReaderT r m) cl2- , Time cl1 ~ Time cl2- )- => Schedule m- (HoistClock (ReaderT r m) m cl1) (HoistClock (ReaderT r m) m cl2)- -> Schedule (ReaderT r m) cl1 cl2-readerSchedule Schedule {..}- = Schedule $ \cl1 cl2 -> ReaderT $ \r -> first liftTransS- <$> initSchedule- (HoistClock cl1 $ flip runReaderT r)- (HoistClock cl2 $ flip runReaderT r)+-- | Run two running clocks concurrently.+runningSchedule ::+ ( Monad m+ , MonadSchedule m+ , Clock m cl1+ , Clock m cl2+ , Time cl1 ~ Time cl2+ ) =>+ cl1 ->+ cl2 ->+ RunningClock m (Time cl1) (Tag cl1) ->+ RunningClock m (Time cl2) (Tag cl2) ->+ RunningClock m (Time cl1) (Either (Tag cl1) (Tag cl2))+runningSchedule _ _ rc1 rc2 = schedulePair (rc1 >>> arr (second Left)) (rc2 >>> arr (second Right)) +{- | A schedule implements a combination of two clocks.+ It outputs a time stamp and an 'Either' value,+ which specifies which of the two subclocks has ticked.+-}+initSchedule ::+ ( Time cl1 ~ Time cl2+ , Monad m+ , MonadSchedule m+ , Clock m cl1+ , Clock m cl2+ ) =>+ cl1 ->+ cl2 ->+ RunningClockInit m (Time cl1) (Either (Tag cl1) (Tag cl2))+initSchedule cl1 cl2 = do+ (runningClock1, initTime) <- initClock cl1+ (runningClock2, _) <- initClock cl2+ pure+ ( runningSchedule cl1 cl2 runningClock1 runningClock2+ , initTime+ ) -- * Composite clocks -- ** Sequentially combined clocks --- | Two clocks can be combined with a schedule as a clock--- for an asynchronous sequential composition of signal networks.-data SequentialClock m cl1 cl2- = Time cl1 ~ Time cl2- => SequentialClock- { sequentialCl1 :: cl1- , sequentialCl2 :: cl2- , sequentialSchedule :: Schedule m cl1 cl2- }+{- | Two clocks can be combined with a schedule as a clock+ for an asynchronous sequential composition of signal networks.+-}+data SequentialClock cl1 cl2+ = (Time cl1 ~ Time cl2) =>+ SequentialClock+ { sequentialCl1 :: cl1+ , sequentialCl2 :: 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 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+type SeqClock cl1 cl2 = SequentialClock cl1 cl2 +instance+ (Monad m, MonadSchedule m, Clock m cl1, Clock m cl2) =>+ Clock m (SequentialClock cl1 cl2)+ where+ type Time (SequentialClock cl1 cl2) = Time cl1+ type Tag (SequentialClock cl1 cl2) = Either (Tag cl1) (Tag cl2)+ initClock SequentialClock {..} =+ initSchedule sequentialCl1 sequentialCl2+ {-# INLINE initClock #-} -- ** Parallelly combined clocks ---- | Two clocks can be combined with a schedule as a clock--- for an asynchronous parallel composition of signal networks.-data ParallelClock m cl1 cl2- = Time cl1 ~ Time cl2- => ParallelClock- { parallelCl1 :: cl1- , parallelCl2 :: cl2- , parallelSchedule :: Schedule m cl1 cl2- }+{- | Two clocks can be combined with a schedule as a clock+ for an asynchronous parallel composition of signal networks.+-}+data ParallelClock cl1 cl2+ = (Time cl1 ~ Time cl2) =>+ ParallelClock+ { parallelCl1 :: cl1+ , parallelCl2 :: 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 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+type ParClock cl1 cl2 = ParallelClock cl1 cl2 +instance+ (Monad m, MonadSchedule m, Clock m cl1, Clock m cl2) =>+ Clock m (ParallelClock cl1 cl2)+ where+ type Time (ParallelClock cl1 cl2) = Time cl1+ type Tag (ParallelClock cl1 cl2) = Either (Tag cl1) (Tag cl2)+ initClock ParallelClock {..} =+ initSchedule parallelCl1 parallelCl2+ {-# INLINE initClock #-} -- * Navigating the clock tree -- | The clock that represents the rate at which data enters the system. type family In cl where- In (SequentialClock m cl1 cl2) = In cl1- In (ParallelClock m cl1 cl2) = ParallelClock m (In cl1) (In cl2)- In cl = cl+ In (SequentialClock cl1 cl2) = In cl1+ In (ParallelClock cl1 cl2) = ParallelClock (In cl1) (In cl2)+ In cl = cl -- | The clock that represents the rate at which data leaves the system. type family Out cl where- Out (SequentialClock m cl1 cl2) = Out cl2- Out (ParallelClock m cl1 cl2) = ParallelClock m (Out cl1) (Out cl2)- Out cl = cl-+ Out (SequentialClock cl1 cl2) = Out cl2+ Out (ParallelClock cl1 cl2) = ParallelClock (Out cl1) (Out cl2)+ Out cl = cl --- | A tree representing possible last times to which--- the constituents of a clock may have ticked.+{- | A tree representing possible last times to which+ the constituents of a clock may have ticked.+-} data LastTime cl where- SequentialLastTime- :: LastTime cl1 -> LastTime cl2- -> LastTime (SequentialClock m cl1 cl2)- ParallelLastTime- :: LastTime cl1 -> LastTime cl2- -> LastTime (ParallelClock m cl1 cl2)+ SequentialLastTime ::+ LastTime cl1 ->+ LastTime cl2 ->+ LastTime (SequentialClock cl1 cl2)+ ParallelLastTime ::+ LastTime cl1 ->+ LastTime cl2 ->+ LastTime (ParallelClock cl1 cl2) LeafLastTime :: Time cl -> LastTime cl - -- | An inclusion of a clock into a tree of parallel compositions of clocks. data ParClockInclusion clS cl where- ParClockInL- :: ParClockInclusion (ParallelClock m clL clR) cl- -> ParClockInclusion clL cl- ParClockInR- :: ParClockInclusion (ParallelClock m clL clR) cl- -> ParClockInclusion clR cl+ ParClockInL ::+ ParClockInclusion (ParallelClock clL clR) cl ->+ ParClockInclusion clL cl+ ParClockInR ::+ ParClockInclusion (ParallelClock clL clR) cl ->+ ParClockInclusion clR cl ParClockRefl :: ParClockInclusion cl cl --- | Generates a tag for the composite clock from a tag of a leaf clock,--- given a parallel clock inclusion.+{- | Generates a tag for the composite clock from a tag of a leaf clock,+ given a parallel clock inclusion.+-} parClockTagInclusion :: ParClockInclusion clS cl -> Tag clS -> Tag cl-parClockTagInclusion (ParClockInL parClockInL) tag = parClockTagInclusion parClockInL $ Left tag+parClockTagInclusion (ParClockInL parClockInL) tag = parClockTagInclusion parClockInL $ Left tag parClockTagInclusion (ParClockInR parClockInR) tag = parClockTagInclusion parClockInR $ Right tag-parClockTagInclusion ParClockRefl tag = tag+parClockTagInclusion ParClockRefl tag = tag
− src/FRP/Rhine/Schedule/Concurrently.hs
@@ -1,150 +0,0 @@-{- |-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 #-}-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.Clock-import FRP.Rhine.Schedule----- | Runs two clocks in separate GHC threads--- and collects the results in the foreground thread.--- Caution: The data processing will still happen in the same thread--- (since data processing and scheduling are separated concerns).-concurrently- :: ( Clock IO cl1, Clock IO cl2- , Time cl1 ~ Time cl2- )- => Schedule IO cl1 cl2-concurrently = Schedule $ \cl1 cl2 -> do- iMVar <- newEmptyMVar- mvar <- newEmptyMVar- _ <- launchSubthread cl1 Left iMVar mvar- _ <- launchSubthread cl2 Right iMVar mvar- initTime <- takeMVar iMVar -- The first clock to be initialised sets the first time stamp- _ <- takeMVar iMVar -- Initialise the second clock- return (constM $ takeMVar mvar, initTime)- where- launchSubthread cl leftright iMVar mvar = forkIO $ do- (runningClock, initTime) <- initClock cl- putMVar iMVar initTime- reactimate $ runningClock >>> second (arr leftright) >>> arrM (putMVar mvar)--- TODO These threads can't be killed from outside easily since we've lost their ids--- => make a MaybeT or ExceptT variant---- TODO Test whether signal networks also share the writer and except effects correctly with these schedules---- | As 'concurrently', but in the @WriterT w IO@ monad.--- Both background threads share a joint variable with the foreground--- to which the writer effect writes.-concurrentlyWriter- :: ( Monoid w- , Clock (WriterT w IO) cl1- , Clock (WriterT w IO) cl2- , Time cl1 ~ Time cl2- )- => Schedule (WriterT w IO) cl1 cl2-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 (constM (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 = constM $ 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 <- constM (lift $ readIORef errorref) -< ()- _ <- throwMaybe -< me- returnA -< ()- putMVar mvar $ Left e -- Either throw own exception or acknowledge the exception from the other clock- Left e -> void $ putMVar iMVar $ Left e- catchAndDrain mvar initScheduleAction = catchE initScheduleAction $ \e -> do- _ <- reactimate $ (constM $ ExceptT $ takeMVar mvar) >>> arr (const ()) -- Drain the mvar until the other clock acknowledges the exception- 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 ()
− src/FRP/Rhine/Schedule/Trans.hs
@@ -1,74 +0,0 @@-{- |-Clocks implemented in the 'ScheduleT' monad transformer-can always be scheduled (by construction).--}--{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies #-}-module FRP.Rhine.Schedule.Trans where---- dunai-import Data.MonadicStreamFunction.InternalCore---- rhine-import Control.Monad.Schedule-import FRP.Rhine.Clock-import FRP.Rhine.Schedule----- * Universal schedule for the 'ScheduleT' monad transformer---- | Two clocks in the 'ScheduleT' monad transformer--- can always be canonically scheduled.--- Indeed, this is the purpose for which 'ScheduleT' was defined.-schedule- :: ( Monad m- , Clock (ScheduleT (Diff (Time cl1)) m) cl1- , Clock (ScheduleT (Diff (Time cl1)) m) cl2- , Time cl1 ~ Time cl2- , Ord (Diff (Time cl1))- , Num (Diff (Time cl1))- )- => Schedule (ScheduleT (Diff (Time cl1)) m) cl1 cl2-schedule = Schedule {..}- where- initSchedule cl1 cl2 = do- (runningClock1, initTime) <- initClock cl1- (runningClock2, _) <- initClock cl2- return- ( runningSchedule cl1 cl2 runningClock1 runningClock2- , initTime- )-- -- Combines the two individual running clocks to one running clock.- runningSchedule- :: ( Monad m- , Clock (ScheduleT (Diff (Time cl1)) m) cl1- , Clock (ScheduleT (Diff (Time cl2)) m) cl2- , Time cl1 ~ Time cl2- , Ord (Diff (Time cl1))- , Num (Diff (Time cl1))- )- => cl1 -> cl2- -> MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl1, Tag cl1)- -> MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl2, Tag cl2)- -> MSF (ScheduleT (Diff (Time cl1)) m) () (Time cl1, Either (Tag cl1) (Tag cl2))- runningSchedule cl1 cl2 rc1 rc2 = MSF $ \_ -> do- -- Race both clocks against each other- raceResult <- race (unMSF rc1 ()) (unMSF rc2 ())- case raceResult of- -- The first clock ticks first...- Left (((time, tag1), rc1'), cont2) -> return- -- so we can emit its time stamp...- ( (time, Left tag1)- -- and continue.- , runningSchedule cl1 cl2 rc1' (MSF $ const cont2)- )- -- The second clock ticks first...- Right (cont1, ((time, tag2), rc2')) -> return- -- so we can emit its time stamp...- ( (time, Right tag2)- -- and continue.- , runningSchedule cl1 cl2 (MSF $ const cont1) rc2'- )
− src/FRP/Rhine/Schedule/Util.hs
@@ -1,20 +0,0 @@--- | 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
− src/FRP/Rhine/TimeDomain.hs
@@ -1,52 +0,0 @@-{- |-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 #-}-module FRP.Rhine.TimeDomain- ( module FRP.Rhine.TimeDomain- , UTCTime- )- where---- time-import Data.Time.Clock (UTCTime, diffUTCTime)---- | 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 time where- type Diff time- diffTime :: time -> time -> Diff time---instance TimeDomain UTCTime where- type Diff UTCTime = Double- diffTime t1 t2 = realToFrac $ diffUTCTime t1 t2--instance TimeDomain Double where- type Diff Double = Double- diffTime = (-)--instance TimeDomain Float where- type Diff Float = Float- diffTime = (-)--instance TimeDomain Integer where- type Diff Integer = Integer- diffTime = (-)--instance TimeDomain () where- type Diff () = ()- diffTime _ _ = ()---- | Any 'Num' can be wrapped to form a 'TimeDomain'.-newtype NumTimeDomain a = NumTimeDomain { fromNumTimeDomain :: a }- deriving Num--instance Num a => TimeDomain (NumTimeDomain a) where- type Diff (NumTimeDomain a) = NumTimeDomain a- diffTime = (-)
src/FRP/Rhine/Type.hs view
@@ -1,21 +1,25 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+ {- | The type of a complete Rhine program: A signal network together with a matching clock value. -}--{-# LANGUAGE Arrows #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies #-} module FRP.Rhine.Type where --- dunai-import Data.MonadicStreamFunction+-- automaton+import Data.Automaton -- rhine-import FRP.Rhine.Reactimation.ClockErasure import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy+import FRP.Rhine.Reactimation.ClockErasure+import FRP.Rhine.ResamplingBuffer (ResamplingBuffer) import FRP.Rhine.SN+import FRP.Rhine.Schedule (In, Out) {- | A 'Rhine' consists of a 'SN' together with a clock of matching type 'cl'.@@ -26,18 +30,17 @@ then it is a standalone reactive program that can be run with the function 'flow'. -Otherwise, one can start the clock and the signal network jointly as a monadic stream function,+Otherwise, one can start the clock and the signal network jointly as an automaton, using 'eraseClock'. -} data Rhine m cl a b = Rhine- { sn :: SN m cl a b+ { sn :: SN m cl a b , clock :: cl } -instance GetClockProxy cl => ToClockProxy (Rhine m cl a b) where+instance (GetClockProxy cl) => ToClockProxy (Rhine m cl a b) where type Cl (Rhine m cl a b) = cl - {- | Start the clock and the signal network, effectively hiding the clock type from the outside.@@ -45,13 +48,38 @@ Since the caller will not know when the clock @'In' cl@ ticks, the input 'a' has to be given at all times, even those when it doesn't tick. -}-eraseClock- :: (Monad m, Clock m cl, GetClockProxy cl)- => Rhine m cl a b- -> m (MSF m a (Maybe b))+eraseClock ::+ (Monad m, Clock m cl, GetClockProxy cl) =>+ Rhine m cl a b ->+ m (Automaton m a (Maybe b)) eraseClock Rhine {..} = do (runningClock, initTime) <- initClock clock -- Run the main loop return $ proc a -> do (time, tag) <- runningClock -< () eraseClockSN initTime sn -< (time, tag, a <$ inTag (toClockProxy sn) tag)+{-# INLINE eraseClock #-}++{- |+Loop back data from the output to the input.++Since output and input will generally tick at different clocks,+the data needs to be resampled.+-}+feedbackRhine ::+ ( Clock m (In cl)+ , Clock m (Out cl)+ , Time (In cl) ~ Time cl+ , Time (Out cl) ~ Time cl+ , GetClockProxy cl+ , Monad m+ ) =>+ ResamplingBuffer m (Out cl) (In cl) d c ->+ Rhine m cl (a, c) (b, d) ->+ Rhine m cl a b+feedbackRhine buf Rhine {..} =+ Rhine+ { sn = feedbackSN buf sn+ , clock+ }+{-# INLINE feedbackRhine #-}
+ test/Clock.hs view
@@ -0,0 +1,17 @@+module Clock where++-- tasty+import Test.Tasty++-- rhine+import Clock.Except+import Clock.FixedStep+import Clock.Millisecond++tests =+ testGroup+ "Clock"+ [ Clock.Except.tests+ , Clock.FixedStep.tests+ , Clock.Millisecond.tests+ ]
+ test/Clock/Except.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE OverloadedStrings #-}++module Clock.Except where++-- base+import Control.Applicative (Alternative (empty))+import Data.Either (isLeft)+import GHC.IO.Handle (hDuplicateTo)+import System.IO (IOMode (ReadMode), stdin, withFile)+import System.IO.Error (isEOFError)++-- mtl+import Control.Monad.Writer.Class++-- transformers+-- Replace Strict by CPS when bumping mtl to 2.3+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Maybe (MaybeT (..))+import Control.Monad.Trans.Writer.Strict hiding (tell)++-- text+import Data.Text (Text)++-- tasty+import Test.Tasty (TestTree, testGroup)++-- tasty-hunit+import Test.Tasty.HUnit (testCase, (@?), (@?=))++-- rhine+import FRP.Rhine+import FRP.Rhine.Clock.Except (+ CatchClock (CatchClock),+ DelayIOError,+ DelayMonadIOError,+ ExceptClock (ExceptClock),+ catchClSF,+ delayIOError,+ delayMonadIOError',+ )+import Paths_rhine++tests :: TestTree+tests =+ testGroup+ "Except"+ [exceptClockTests, catchClockTests, delayedClockTests, innerWriterTests]++-- * 'Except'++type E = ExceptT IOError IO+type EClock = ExceptClock StdinClock IOError++exceptClock :: EClock+exceptClock = ExceptClock StdinClock++exceptClockTests :: TestTree+exceptClockTests =+ testGroup+ "ExceptClock"+ [ testCase "Raises the exception in ExceptT on EOF" $ withTestStdin $ do+ Left result <- runExceptT $ flow $ clId @@ exceptClock+ isEOFError result @? "It's an EOF error"+ ]++-- ** 'CatchClock'++type TestCatchClock = CatchClock EClock IOError EClock++testClock :: TestCatchClock+testClock = CatchClock exceptClock $ const exceptClock++type ME = MaybeT E+type TestCatchClockMaybe = CatchClock EClock IOError (LiftClock E MaybeT (LiftClock IO (ExceptT IOError) Busy))++testClockMaybe :: TestCatchClockMaybe+testClockMaybe = CatchClock exceptClock (const (liftClock (liftClock Busy)))++catchClockTests :: TestTree+catchClockTests =+ testGroup+ "CatchClock"+ [ testCase "Outputs the exception of the second clock as well" $ withTestStdin $ do+ Left result <- runExceptT $ flow $ clId @@ testClock+ isEOFError result @? "It's an EOF error"+ , testCase "Can recover from an exception" $ withTestStdin $ do+ let stopInClsf :: ClSF ME TestCatchClockMaybe () ()+ stopInClsf = catchClSF clId $ constMCl empty+ result <- runExceptT $ runMaybeT $ flow_ $ stopInClsf @@ testClockMaybe+ result @?= Right Nothing+ ]++-- ** Clock failing at init++{- | This clock throws an exception at initialization.++Useful for testing clock initialization.+-}+data FailingClock = FailingClock++instance (Monad m) => Clock (ExceptT () m) FailingClock where+ type Time FailingClock = UTCTime+ type Tag FailingClock = ()+ initClock FailingClock = throwE ()+ {-# INLINE initClock #-}++instance GetClockProxy FailingClock++type CatchFailingClock = CatchClock FailingClock () Busy++catchFailingClock :: CatchFailingClock+catchFailingClock = CatchClock FailingClock $ const Busy++failingClockTests :: TestTree+failingClockTests =+ testGroup+ "FailingClock"+ [ testCase "flow fails immediately" $ do+ result <- runExceptT $ flow_ $ clId @@ FailingClock+ result @?= Left ()+ , testCase "CatchClock recovers from failure at init" $ do+ let+ clsfStops :: ClSF (MaybeT IO) CatchFailingClock () ()+ clsfStops = catchClSF clId $ constM $ lift empty+ result <- runMaybeT $ flow_ $ clsfStops @@ catchFailingClock+ result @?= Nothing -- The ClSF stopped the execution, not the clock+ ]++-- ** 'DelayException'++type DelayedClock = DelayIOError StdinClock (Maybe [Text])++delayedClock :: DelayedClock+delayedClock = delayIOError StdinClock $ const Nothing++delayedClockTests :: TestTree+delayedClockTests =+ testGroup+ "DelayedClock"+ [ testCase "DelayException delays error by 1 step" $ withTestStdin $ do+ let+ throwCollectedText :: ClSF (ExceptT (Maybe [Text]) IO) DelayedClock () ()+ throwCollectedText = proc () -> do+ tag <- tagS -< ()+ textSoFar <- mappendS -< either (const []) pure tag+ throwOn' -< (isLeft tag, Just textSoFar)+ result <- runExceptT $ flow_ $ throwCollectedText @@ delayedClock+ result @?= Left (Just ["data", "test"])+ , testCase "DelayException throws error after 1 step" $ withTestStdin $ do+ let+ dontThrow :: ClSF (ExceptT (Maybe [Text]) IO) DelayedClock () ()+ dontThrow = clId+ result <- runExceptT $ flow_ $ dontThrow @@ delayedClock+ result @?= Left Nothing+ ]++-- ** Inner writer++{- | 'WriterT' is now the inner monad, meaning that the log survives exceptions.+This way, the state is not lost.+-}+type ClWriterExcept = DelayMonadIOError (ExceptT IOError (WriterT [Text] IO)) StdinClock IOError++clWriterExcept :: ClWriterExcept+clWriterExcept = delayMonadIOError' StdinClock++innerWriterTests :: TestTree+innerWriterTests = testCase "DelayException throws error after 1 step, but can write down results" $ withTestStdin $ do+ let+ tellStdin :: (MonadWriter [Text] m) => ClSF m ClWriterExcept () ()+ tellStdin = catchClSF (tagS >>> arrMCl (tell . pure)) clId++ (Left e, result) <- runWriterT $ runExceptT $ flow $ tellStdin @@ clWriterExcept+ isEOFError e @? "is EOF"+ result @?= ["test", "data"]++-- * Test helpers++-- | Emulate test standard input+withTestStdin :: IO a -> IO a+withTestStdin action = do+ testdataFile <- getDataFileName "test/assets/testdata.txt"+ withFile testdataFile ReadMode $ \h -> do+ hDuplicateTo h stdin+ action
+ test/Clock/FixedStep.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}++module Clock.FixedStep where++-- vector-sized+import Data.Vector.Sized (toList)++-- tasty+import Test.Tasty (testGroup)++-- tasty-hunit+import Test.Tasty.HUnit (testCase, (@?=))++-- rhine+import FRP.Rhine+import Util++tests =+ testGroup+ "Clock.FixedStep"+ [ testCase "Outputs linearly increasing ticks" $+ let+ output = runScheduleRhinePure (absoluteS @@ (FixedStep @5)) $ replicate 4 ()+ in+ output @?= Just <$> [5, 10, 15, 20]+ , testCase "Outputs scheduled ticks in order" $+ let+ output = runScheduleRhinePure ((absoluteS @@ (FixedStep @5)) |@| (absoluteS @@ (FixedStep @3))) $ replicate 6 ()+ in+ output @?= Just <$> [3, 5, 6, 9, 10, 12]+ , testCase "Outputs scheduled ticks in order (mirrored)" $+ let+ output = runScheduleRhinePure ((absoluteS @@ (FixedStep @3)) |@| (absoluteS @@ (FixedStep @5))) $ replicate 6 ()+ in+ output @?= Just <$> [3, 5, 6, 9, 10, 12]+ , testCase "Resamples correctly (downsampleFixedStep)" $+ let+ output = fmap (fmap (first toList)) $ runScheduleRhinePure ((absoluteS @@ (FixedStep @3)) >-- downsampleFixedStep --> ((clId &&& absoluteS) @@ (FixedStep @12))) $ replicate 10 ()+ in+ output+ @?= [ Nothing+ , Nothing+ , Nothing+ , Nothing+ , Just ([12, 9, 6, 3], 12)+ , Nothing+ , Nothing+ , Nothing+ , Nothing+ , Just ([24, 21, 18, 15], 24)+ ]+ , testCase "Resamples correctly (collect)" $+ let+ output = runScheduleRhinePure ((absoluteS @@ (FixedStep @3)) >-- collect --> ((clId &&& absoluteS) @@ (FixedStep @12))) $ replicate 10 ()+ in+ output+ @?= [ Nothing+ , Nothing+ , Nothing+ , Nothing+ , Just ([12, 9, 6, 3], 12)+ , Nothing+ , Nothing+ , Nothing+ , Nothing+ , Just ([24, 21, 18, 15], 24)+ ]+ ]
+ test/Clock/Millisecond.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Clock.Millisecond where++-- base+import Control.Monad (when)+import System.Info (os)++-- tasty+import Test.Tasty (testGroup)++-- tasty-hunit+import Test.Tasty.HUnit (Assertion, assertBool, testCase)++-- rhine+import FRP.Rhine+import Util (runRhine)++-- | Milliseconds+newtype MS = MS Int+ deriving (Num, Show, Eq, Ord)++millisecondsSinceInit :: (Monad m) => ClSF m (Millisecond n) a MS+millisecondsSinceInit = sinceInitS >>> arr (MS . round . (* 1000))++tests =+ testGroup+ "Millisecond"+ [ testCase "Outputs milliseconds chronologically" $ do+ output <- runRhine (millisecondsSinceInit @@ (waitClock @1)) $ replicate 5 ()+ assertTiming output $ Just <$> [1, 2, 3, 4, 5]+ , testCase "Schedules chronologically" $ do+ output <- runRhine (millisecondsSinceInit @@ (waitClock @30) >-- collect --> (clId &&& millisecondsSinceInit) @@ (waitClock @50)) $ replicate 5 ()+ assertTiming+ output+ [ Nothing+ , Just ([30], 50)+ , Nothing+ , Nothing+ , Just ([90, 60], 100)+ ]+ ]++assertTiming :: (Show a, TimingSubsumes a) => a -> a -> Assertion+assertTiming observed expected =+ when (os /= "darwin") $+ assertBool ("Observed timing: " ++ show observed ++ "\nExpected timing: " ++ show expected) $+ timingSubsumes observed expected++class TimingSubsumes a where+ timingSubsumes :: a -> a -> Bool++instance TimingSubsumes MS where+ timingSubsumes tObserved tExpected = tExpected <= tObserved && tObserved <= 2 * tExpected + 10++instance (TimingSubsumes a) => TimingSubsumes (Maybe a) where+ timingSubsumes (Just aObserved) (Just aExpected) = timingSubsumes aObserved aExpected+ timingSubsumes Nothing Nothing = True+ timingSubsumes _ _ = False++instance (TimingSubsumes a, TimingSubsumes b) => TimingSubsumes (a, b) where+ timingSubsumes (aObserved, bObserved) (aExpected, bExpected) = timingSubsumes aObserved aExpected && timingSubsumes bObserved bExpected++instance (TimingSubsumes a) => TimingSubsumes [a] where+ timingSubsumes [] [] = True+ timingSubsumes (aObserved : aObserveds) (aExpected : aExpecteds) = timingSubsumes aObserved aExpected && timingSubsumes aObserveds aExpecteds+ timingSubsumes _ _ = False
+ test/Except.hs view
@@ -0,0 +1,42 @@+module Except where++-- tasty+import Test.Tasty++-- tasty-hunit+import Test.Tasty.HUnit++-- rhine+import FRP.Rhine+import Util (runScheduleRhinePure)++tests =+ testGroup+ "Except"+ [ testCase "Can raise and catch an exception" $ do+ let clsf = safely $ do+ try $ sinceInitS >>> throwOnCond (== 3) ()+ safe $ arr (const (-1))+ runScheduleRhinePure (clsf @@ FixedStep @1) (replicate 5 ()) @?= [Just 1, Just 2, Just (-1), Just (-1), Just (-1)]+ , testCase "Can raise and catch very many exceptions without steps in between" $ do+ let clsf = safely $ go 100000+ go n = do+ _ <- try $ throwOnCond (< n) ()+ go $ n - 1+ inputs = [0]+ runScheduleRhinePure (clsf @@ FixedStep @1) inputs @?= [Just 0]+ , testCase "Can raise, catch, and keep very many exceptions without steps in between" $ do+ let clsf = safely $ go 1000 []+ go n ns = do+ _ <- try $ throwOnCond (< n) () >>> arr (const ns)+ go (n - 1) (n : ns)+ inputs = [0]+ runScheduleRhinePure (clsf @@ FixedStep @1) inputs @?= [Just [1 .. 1000]]+ , testCase "Can raise, catch, and keep very many exceptions without steps in between, using Monad" $ do+ let clsf = safely $ go 1000 []+ go n ns = do+ n' <- try $ throwOnCond (< n) n >>> arr (const ns)+ go (n' - 1) (n' : ns)+ inputs = [0]+ runScheduleRhinePure (clsf @@ FixedStep @1) inputs @?= [Just [1 .. 1000]]+ ]
+ test/Main.hs view
@@ -0,0 +1,18 @@+module Main where++-- tasty+import Test.Tasty++-- rhine+import Clock+import Except+import Schedule++main =+ defaultMain $+ testGroup+ "Main"+ [ Clock.tests+ , Except.tests+ , Schedule.tests+ ]
+ test/Schedule.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedLists #-}++module Schedule where++-- tasty+import Test.Tasty++-- tasty-hunit+import Test.Tasty.HUnit++-- time-domain+import Data.TimeDomain (Seconds)++-- automaton+import Data.Automaton (embed)+import Data.Automaton.Schedule.Trans (Schedule, evalSchedule)++-- rhine+import FRP.Rhine (FixedStep (..), ParallelClock (..), initClock, runningSchedule)+import FRP.Rhine.Clock (RunningClockInit)++tests =+ testGroup+ "Schedule"+ [ testGroup+ "scheduling running clocks"+ [ testCase "chronological ticks" $ do+ let clA = FixedStep @5+ clB = FixedStep @3+ (runningClockA, _) = evalSchedule (initClock clA :: RunningClockInit (Schedule (Seconds Integer)) (Seconds Integer) ())+ (runningClockB, _) = evalSchedule (initClock clB :: RunningClockInit (Schedule (Seconds Integer)) (Seconds Integer) ())+ output = evalSchedule $ embed (runningSchedule clA clB runningClockA runningClockB) $ replicate 6 ()+ output+ @?= [ (3, Right ())+ , (5, Left ())+ , (6, Right ())+ , (9, Right ())+ , (10, Left ())+ , (12, Right ())+ ]+ ]+ , testGroup+ "ParallelClock"+ [ testCase "chronological ticks" $ do+ let (runningClock, _time) = evalSchedule (initClock (ParallelClock (FixedStep @5) (FixedStep @3)) :: RunningClockInit (Schedule (Seconds Integer)) (Seconds Integer) (Either () ()))+ output = evalSchedule $ embed runningClock $ replicate 6 ()+ output+ @?= [ (3, Right ())+ , (5, Left ())+ , (6, Right ())+ , (9, Right ())+ , (10, Left ())+ , (12, Right ())+ ]+ ]+ ]
+ test/Util.hs view
@@ -0,0 +1,15 @@+module Util where++-- automaton+import Data.Automaton.Schedule.Trans (Schedule, evalSchedule)++-- rhine+import FRP.Rhine++runScheduleRhinePure :: (Clock (Schedule (Seconds Integer)) cl, GetClockProxy cl) => Rhine (Schedule (Seconds Integer)) cl a b -> [a] -> [Maybe b]+runScheduleRhinePure rhine = evalSchedule . runRhine rhine++runRhine :: (Clock m cl, GetClockProxy cl, Monad m) => Rhine m cl a b -> [a] -> m [Maybe b]+runRhine rhine input = do+ automaton <- eraseClock rhine+ embed automaton input
+ test/assets/testdata.txt view
@@ -0,0 +1,2 @@+test+data