rhine 1.2 → 1.3
raw patch · 53 files changed
+1356/−382 lines, 53 filesdep +QuickCheckdep +automatondep +criteriondep −dunaidep ~basedep ~monad-scheduledep ~tasty
Dependencies added: QuickCheck, automaton, criterion, mmorph, mtl, profunctors, selective, sop-core, tasty-quickcheck
Dependencies removed: dunai
Dependency ranges changed: base, monad-schedule, tasty, text
Files
- ChangeLog.md +15/−0
- bench/Main.hs +9/−0
- bench/Sum.hs +67/−0
- bench/Test.hs +31/−0
- bench/WordCount.hs +146/−0
- bench/pg100.txt too large to diff
- rhine.cabal +141/−77
- src/FRP/Rhine.hs +6/−5
- src/FRP/Rhine/ClSF.hs +1/−1
- src/FRP/Rhine/ClSF/Core.hs +9/−9
- src/FRP/Rhine/ClSF/Except.hs +25/−27
- src/FRP/Rhine/ClSF/Random.hs +7/−7
- src/FRP/Rhine/ClSF/Reader.hs +8/−4
- src/FRP/Rhine/ClSF/Upsample.hs +7/−7
- src/FRP/Rhine/ClSF/Util.hs +4/−16
- src/FRP/Rhine/Clock.hs +10/−11
- src/FRP/Rhine/Clock/Except.hs +209/−0
- src/FRP/Rhine/Clock/FixedStep.hs +4/−0
- src/FRP/Rhine/Clock/Periodic.hs +6/−15
- src/FRP/Rhine/Clock/Realtime/Audio.hs +7/−5
- src/FRP/Rhine/Clock/Realtime/Busy.hs +10/−3
- src/FRP/Rhine/Clock/Realtime/Event.hs +1/−1
- src/FRP/Rhine/Clock/Realtime/Millisecond.hs +7/−1
- src/FRP/Rhine/Clock/Realtime/Never.hs +37/−0
- src/FRP/Rhine/Clock/Realtime/Stdin.hs +5/−2
- src/FRP/Rhine/Clock/Select.hs +9/−8
- src/FRP/Rhine/Clock/Trivial.hs +18/−0
- src/FRP/Rhine/Clock/Unschedule.hs +11/−4
- src/FRP/Rhine/Clock/Util.hs +8/−2
- src/FRP/Rhine/Reactimation.hs +20/−6
- src/FRP/Rhine/Reactimation/ClockErasure.hs +20/−19
- src/FRP/Rhine/Reactimation/Combinators.hs +1/−0
- src/FRP/Rhine/ResamplingBuffer.hs +20/−10
- src/FRP/Rhine/ResamplingBuffer/ClSF.hs +44/−0
- src/FRP/Rhine/ResamplingBuffer/Collect.hs +8/−5
- src/FRP/Rhine/ResamplingBuffer/FIFO.hs +9/−6
- src/FRP/Rhine/ResamplingBuffer/Interpolation.hs +2/−2
- src/FRP/Rhine/ResamplingBuffer/KeepLast.hs +5/−1
- src/FRP/Rhine/ResamplingBuffer/LIFO.hs +9/−6
- src/FRP/Rhine/ResamplingBuffer/MSF.hs +0/−40
- src/FRP/Rhine/ResamplingBuffer/Timeless.hs +12/−14
- src/FRP/Rhine/ResamplingBuffer/Util.hs +37/−25
- src/FRP/Rhine/SN.hs +1/−1
- src/FRP/Rhine/Schedule.hs +51/−18
- src/FRP/Rhine/Type.hs +6/−4
- test/Clock.hs +3/−1
- test/Clock/Except.hs +184/−0
- test/Clock/Millisecond.hs +51/−14
- test/Except.hs +42/−0
- test/Main.hs +2/−0
- test/Schedule.hs +4/−1
- test/Util.hs +5/−4
- test/assets/testdata.txt +2/−0
ChangeLog.md view
@@ -1,5 +1,20 @@ # Revision history for rhine +## 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
+ 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,67 @@+{-# 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 "automaton" Data.Stream.Result (Result (..))+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,11 +1,7 @@-cabal-version: 2.2--name: rhine--version: 1.2-+cabal-version: 2.2+name: rhine+version: 1.3 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@@ -22,68 +18,93 @@ A (synchronous) program outputting "Hello World!" every tenth of a second looks like this: @flow $ constMCl (putStrLn "Hello World!") \@\@ (waitClock :: Millisecond 100)@ --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+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 tested-with:- GHC == 9.0.2- GHC == 9.2.8- GHC == 9.4.7+ ghc ==9.0.2+ ghc ==9.2.8+ ghc ==9.4.7+ ghc ==9.6.4+ ghc ==9.8.2 source-repository head- type: git+ type: git location: https://github.com/turion/rhine.git source-repository this- type: git+ type: git location: https://github.com/turion/rhine.git- tag: v1.0+ tag: v1.3 common opts build-depends:- , base >= 4.14 && < 4.18- , vector-sized >= 1.4+ automaton ^>=1.3,+ base >=4.14 && <4.20,+ monad-schedule ^>=0.1.2,+ mtl >=2.2 && <2.4,+ selective ^>=0.7,+ text >=1.2 && <2.2,+ time >=1.8,+ transformers >=0.5,+ vector-sized >=1.4, if flag(dev) ghc-options: -Werror-- ghc-options: -W- -Wno-unticked-promoted-constructors+ ghc-options:+ -W+ -Wno-unticked-promoted-constructors default-extensions:- DataKinds- , FlexibleContexts- , FlexibleInstances- , MultiParamTypeClasses- , NamedFieldPuns- , NoStarIsType- , TupleSections- , TypeApplications- , TypeFamilies- , TypeOperators+ Arrows+ DataKinds+ FlexibleContexts+ FlexibleInstances+ ImportQualifiedPost+ MultiParamTypeClasses+ NamedFieldPuns+ NoStarIsType+ TupleSections+ TypeApplications+ TypeFamilies+ TypeOperators -- Base language which the package is written in.- default-language: Haskell2010+ default-language: Haskell2010 +common test-deps+ build-depends:+ QuickCheck ^>=2.14,+ tasty >=1.4 && <1.6,+ tasty-hunit ^>=0.10,+ tasty-quickcheck ^>=0.10,++common bench-deps+ build-depends:+ criterion ^>=1.6+ library import: opts exposed-modules: 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@@ -91,77 +112,120 @@ 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.Trivial FRP.Rhine.Clock.Unschedule 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.SN FRP.Rhine.SN.Combinators+ FRP.Rhine.Schedule FRP.Rhine.Type other-modules:- FRP.Rhine.ClSF.Random.Util FRP.Rhine.ClSF.Except.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:- , dunai ^>= 0.11- , transformers >= 0.5- , time >= 1.8- , free >= 5.1- , containers >= 0.5- , text >= 1.2 && < 2.1- , deepseq >= 1.4- , random >= 1.1- , MonadRandom >= 0.5- , simple-affine-space ^>= 0.2- , time-domain ^>= 0.1.0.2- , monad-schedule ^>= 0.1.2+ MonadRandom >=0.5,+ containers >=0.5,+ deepseq >=1.4,+ free >=5.1,+ mmorph ^>=1.2,+ profunctors ^>=5.6,+ random >=1.1,+ simple-affine-space ^>=0.2,+ sop-core ^>=0.5,+ text >=1.2 && <2.2,+ time >=1.8,+ time-domain ^>=0.1.0.2,+ transformers >=0.5, -- Directories containing source files.- hs-source-dirs: src+ hs-source-dirs: src test-suite test- import: opts- hs-source-dirs: test- type: exitcode-stdio-1.0- main-is: Main.hs+ 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++ autogen-modules: Paths_rhine build-depends:- , rhine- , monad-schedule- , tasty ^>= 1.4- , tasty-hunit ^>= 0.10+ rhine 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/FRP/Rhine.hs view
@@ -12,12 +12,11 @@ -} module FRP.Rhine (module X) where --- dunai-import Data.MonadicStreamFunction as X hiding ((>>>^), (^>>>))-import Data.VectorSpace as X+-- automaton+import Data.Automaton as X -- rhine-+import Data.VectorSpace as X import FRP.Rhine.ClSF as X import FRP.Rhine.Clock as X import FRP.Rhine.Clock.Proxy as X@@ -38,14 +37,16 @@ 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.Clock.Trivial as X import FRP.Rhine.Clock.Unschedule 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.MSF as X import FRP.Rhine.ResamplingBuffer.Timeless 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),
src/FRP/Rhine/ClSF/Core.hs view
@@ -22,19 +22,19 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Reader (ReaderT, mapReaderT, withReaderT) --- dunai-import Data.MonadicStreamFunction as X hiding ((>>>^), (^>>>))+-- automaton+import Data.Automaton as X -- rhine import FRP.Rhine.Clock -- * Clocked signal functions and behaviours -{- | A (synchronous, clocked) monadic stream function+{- | 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 = MSF (ReaderT (TimeInfo cl) m) a b+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.@@ -67,7 +67,7 @@ (forall c. m1 c -> m2 c) -> ClSF m1 cl a b -> ClSF m2 cl a b-hoistClSF hoist = morphS $ mapReaderT hoist+hoistClSF hoist = hoistS $ mapReaderT hoist -- | Hoist a 'ClSF' and its clock along a monad morphism. hoistClSFAndClock ::@@ -76,7 +76,7 @@ ClSF m1 cl a b -> ClSF m2 (HoistClock m1 m2 cl) a b hoistClSFAndClock hoist =- morphS $ withReaderT (retag id) . mapReaderT hoist+ hoistS $ withReaderT (retag id) . mapReaderT hoist -- | Lift a 'ClSF' into a monad transformer. liftClSF ::@@ -92,11 +92,11 @@ ClSF (t m) (LiftClock m t cl) a b liftClSFAndClock = hoistClSFAndClock lift -{- | A monadic stream function without dependency on time+{- | An automaton without dependency on time is a 'ClSF' for any clock. -}-timeless :: (Monad m) => MSF m a b -> ClSF m cl a b-timeless = liftTransS+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
src/FRP/Rhine/ClSF/Except.hs view
@@ -5,7 +5,7 @@ {- | This module provides exception handling, and thus control flow, to synchronous signal functions. -The API presented here closely follows 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. -} module FRP.Rhine.ClSF.Except (@@ -14,25 +14,22 @@ safe, safely, exceptS,- runMSFExcept,+ runAutomatonExcept, currentInput, ) 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 Control.Monad.Trans.MSF.Except hiding (once, once_, throwOn, throwOn', throwS, try)-import Data.MonadicStreamFunction---- 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@@ -46,11 +43,11 @@ 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.@@ -90,53 +87,54 @@ -- * 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+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+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+step :: (Monad m) => (a -> m (b, e)) -> ClSFExcept cl a b m e+step f = AutomatonE.step $ lift . f
src/FRP/Rhine/ClSF/Random.hs view
@@ -3,8 +3,8 @@ {- | Create 'ClSF's with randomness without 'IO'. Uses the @MonadRandom@ package.- This module copies the API from @dunai@'s- 'Control.Monad.Trans.MSF.Random'.+ This module copies the API from @automaton@'s+ 'Data.Automaton.Trans.Random'. -} module FRP.Rhine.ClSF.Random ( module FRP.Rhine.ClSF.Random,@@ -18,10 +18,10 @@ -- MonadRandom import Control.Monad.Random --- dunai-import Control.Monad.Trans.MSF.Except (performOnFirstSample)-import Control.Monad.Trans.MSF.Random as X hiding (evalRandS, getRandomRS, getRandomRS_, getRandomS, runRandS)-import qualified Control.Monad.Trans.MSF.Random as MSF+-- 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@@ -36,7 +36,7 @@ -- | The initial random seed g -> ClSF m cl a (g, b)-runRandS clsf = MSF.runRandS (morphS commuteReaderRand clsf)+runRandS clsf = Automaton.runRandS (hoistS commuteReaderRand clsf) -- | Updates the generator every step but discards the generator. evalRandS ::
src/FRP/Rhine/ClSF/Reader.hs view
@@ -13,8 +13,8 @@ -- 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@@ -23,6 +23,7 @@ commuteReaders :: ReaderT r1 (ReaderT r2 m) a -> ReaderT r2 (ReaderT r1 m) a 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@@ -33,7 +34,8 @@ ClSF m cl (a, r) b -> ClSF (ReaderT r m) cl a b readerS behaviour =- morphS commuteReaders $ MSF.readerS $ arr swap >>> 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.@@ -43,7 +45,8 @@ ClSF (ReaderT r m) cl a b -> ClSF m cl (a, r) b runReaderS behaviour =- arr swap >>> MSF.runReaderS (morphS commuteReaders behaviour)+ arr swap >>> Automaton.runReaderS (hoistS commuteReaders behaviour)+{-# INLINE runReaderS #-} -- | Remove a 'ReaderT' layer by passing the readonly environment explicitly. runReaderS_ ::@@ -52,3 +55,4 @@ r -> ClSF m cl a b runReaderS_ behaviour r = arr (,r) >>> runReaderS behaviour+{-# INLINE runReaderS_ #-}
src/FRP/Rhine/ClSF/Upsample.hs view
@@ -7,22 +7,22 @@ module FRP.Rhine.ClSF.Upsample where -- dunai-import Control.Monad.Trans.MSF.Reader+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+{- | An 'Automaton' 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+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.@@ -37,7 +37,7 @@ b -> ClSF m clR a b -> ClSF m (ParallelClock clL clR) a b-upsampleR b clsf = readerS $ arr remap >>> upsampleMSF b (runReaderS clsf)+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)@@ -52,7 +52,7 @@ b -> ClSF m clL a b -> ClSF m (ParallelClock clL clR) a b-upsampleL b clsf = readerS $ arr remap >>> upsampleMSF b (runReaderS clsf)+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)
src/FRP/Rhine/ClSF/Util.hs view
@@ -15,9 +15,7 @@ -- 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@@ -26,9 +24,7 @@ import Control.Monad.Trans.Reader (ask, asks) -- dunai-import Control.Monad.Trans.MSF.Reader (readerS)-import Data.MonadicStreamFunction.Instances.Num ()-import Data.MonadicStreamFunction.Instances.VectorSpace ()+import Data.Automaton.Trans.Reader (readerS) -- simple-affine-space import Data.VectorSpace@@ -178,7 +174,7 @@ 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 @@ -205,7 +201,7 @@ BehaviorF m td v v threePointDerivativeFrom v0 = proc v -> do dv <- derivativeFrom v0 -< v- dv' <- iPre zeroVector -< dv+ dv' <- delay zeroVector -< dv returnA -< (dv ^+^ dv') ^/ 2 {- | Like 'threePointDerivativeFrom',@@ -435,11 +431,3 @@ 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
@@ -22,14 +22,15 @@ where -- base-import qualified Control.Category as Category+import Control.Arrow+import Control.Category qualified as Category -- transformers 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) -- time-domain import Data.TimeDomain as X@@ -41,7 +42,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@@ -109,11 +110,11 @@ -} type RescalingM m cl time = Time cl -> m time -{- | An effectful, stateful morphism of time domains is an 'MSF'+{- | 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 = MSF m (Time cl, Tag cl) (time, tag)+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.@@ -128,7 +129,7 @@ (Monad m) => (time1 -> m time2) -> time1 ->- m (MSF m (time1, tag) (time2, tag), time2)+ m (Automaton m (time1, tag) (time2, tag), time2) rescaleMToSInit rescaling time1 = (arrM rescaling *** Category.id,) <$> rescaling time1 -- ** Applying rescalings to clocks@@ -185,7 +186,7 @@ } {- | Instead of a mere function as morphism of time domains,- we can transform one time domain into the other with a monadic stream function.+ we can transform one time domain into the other with an automaton. -} data RescaledClockS m cl time tag = RescaledClockS { unscaledClockS :: cl@@ -241,10 +242,8 @@ 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+ ( hoistS monadMorphism runningClock , initialTime )
+ src/FRP/Rhine/Clock/Except.hs view
@@ -0,0 +1,209 @@+module FRP.Rhine.Clock.Except where++-- base+import Control.Arrow+import Control.Exception+import Control.Exception qualified as Exception+import Control.Monad ((<=<))+import Data.Functor ((<&>))+import Data.Void++-- time+import Data.Time (UTCTime, getCurrentTime)++-- mtl+import Control.Monad.Error.Class+import Control.Monad.IO.Class (MonadIO, liftIO)++-- 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 (..),+ TimeDomain,+ 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++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++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)++-- * '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
@@ -12,6 +12,7 @@ module FRP.Rhine.Clock.FixedStep where -- base+import Control.Arrow import Data.Functor (($>)) import Data.Maybe (fromMaybe) import GHC.TypeLits@@ -22,6 +23,9 @@ -- monad-schedule import Control.Monad.Schedule.Class import Control.Monad.Schedule.Trans (ScheduleT, wait)++-- automaton+import Data.Automaton (accumulateWith, arrM) -- rhine import FRP.Rhine.Clock
src/FRP/Rhine/Clock/Periodic.hs view
@@ -15,16 +15,16 @@ module FRP.Rhine.Clock.Periodic (Periodic (Periodic)) where -- base+import Control.Arrow import Data.List.NonEmpty hiding (unfold)-import Data.Maybe (fromMaybe) import GHC.TypeLits (KnownNat, Nat, natVal) --- dunai-import Data.MonadicStreamFunction- -- monad-schedule import Control.Monad.Schedule.Trans +-- automaton+import Data.Automaton (Automaton (..), accumulateWith, concatS, withSideEffect)+ -- rhine import FRP.Rhine.Clock import FRP.Rhine.Clock.Proxy@@ -80,15 +80,6 @@ -- * 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/Realtime/Audio.hs view
@@ -21,6 +21,7 @@ where -- base+import Control.Arrow import Data.Time.Clock import GHC.Float (double2Float) import GHC.TypeLits (KnownNat, Nat, natVal)@@ -28,8 +29,9 @@ -- transformers import Control.Monad.IO.Class --- dunai-import Control.Monad.Trans.MSF.Except hiding (step)+-- automaton+import Data.Automaton+import Data.Automaton.Trans.Except hiding (step) -- rhine import FRP.Rhine.Clock@@ -100,11 +102,11 @@ initClock audioClock = do let step =- picosecondsToDiffTime $ -- The only sufficiently precise conversion function- round (10 ^ (12 :: Integer) / theRateNum audioClock :: Double)+ 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 -< ()
src/FRP/Rhine/Clock/Realtime/Busy.hs view
@@ -5,8 +5,15 @@ 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,14 +25,14 @@ -} data Busy = Busy -instance Clock IO Busy where+instance (MonadIO m) => Clock m Busy where type Time Busy = UTCTime type Tag Busy = () initClock _ = do- initialTime <- getCurrentTime+ initialTime <- liftIO getCurrentTime return- ( constM getCurrentTime+ ( constM (liftIO getCurrentTime) &&& arr (const ()) , initialTime )
src/FRP/Rhine/Clock/Realtime/Event.hs view
@@ -66,7 +66,7 @@ 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'.
src/FRP/Rhine/Clock/Realtime/Millisecond.hs view
@@ -9,14 +9,20 @@ module FRP.Rhine.Clock.Realtime.Millisecond where -- base+import Control.Arrow import Control.Concurrent (threadDelay) import Control.Monad.IO.Class (liftIO) import Data.Maybe (fromMaybe)-import Data.Time.Clock import GHC.TypeLits +-- time+import Data.Time.Clock+ -- vector-sized import Data.Vector.Sized (Vector, fromList)++-- automaton+import Data.Automaton (arrM) -- rhine import FRP.Rhine.Clock
+ src/FRP/Rhine/Clock/Realtime/Never.hs view
@@ -0,0 +1,37 @@+{-# 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+ )++instance GetClockProxy Never
src/FRP/Rhine/Clock/Realtime/Stdin.hs view
@@ -16,8 +16,11 @@ import Control.Monad.IO.Class -- text-import qualified Data.Text as Text-import qualified Data.Text.IO as Text+import Data.Text qualified as Text+import Data.Text.IO qualified as Text++-- automaton+import Data.Automaton (constM) -- rhine import FRP.Rhine.Clock
src/FRP/Rhine/Clock/Select.hs view
@@ -14,16 +14,17 @@ -} 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 --- dunai-import Data.MonadicStreamFunction.Async (concatS)---- base-import Data.Maybe (maybeToList)- {- | A clock that selects certain subevents of type 'a', from the tag of a main clock. @@ -66,8 +67,8 @@ instance GetClockProxy (SelectClock cl a) -{- | Helper function that runs an 'MSF' with 'Maybe' output+{- | Helper function that runs an 'Automaton' with 'Maybe' output until it returns a value. -}-filterS :: (Monad m) => MSF m () (Maybe b) -> MSF m () b+filterS :: (Monad m) => Automaton m () (Maybe b) -> Automaton m () b filterS = concatS . (>>> arr maybeToList)
+ src/FRP/Rhine/Clock/Trivial.hs view
@@ -0,0 +1,18 @@+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 ((), ()), ())++instance GetClockProxy Trivial
src/FRP/Rhine/Clock/Unschedule.hs view
@@ -5,12 +5,16 @@ module FRP.Rhine.Clock.Unschedule where -- base-import qualified Control.Concurrent as Concurrent (yield)+import Control.Arrow+import Control.Concurrent qualified as Concurrent (yield) import Control.Monad.IO.Class -- monad-schedule import Control.Monad.Schedule.Trans +-- automaton+import Data.Automaton (hoistS)+ -- rhine import FRP.Rhine.Clock @@ -22,14 +26,17 @@ , scheduleWait :: Diff (Time cl) -> m () } --- The 'yield' action is interpreted as thread yielding in 'IO'.+{- | Remove a 'ScheduleT' layer from the monad transformer stack of the clock.++The 'yield' action is interpreted as thread yielding in 'IO'.+-} unyieldClock :: cl -> UnscheduleClock IO cl unyieldClock cl = UnscheduleClock cl $ const $ liftIO Concurrent.yield -instance (Clock (ScheduleT (Diff (Time cl)) m) cl, Monad m) => Clock m (UnscheduleClock m cl) where+instance (TimeDomain (Time cl), Clock (ScheduleT (Diff (Time cl)) m) cl, Monad m) => Clock m (UnscheduleClock m cl) where type Tag (UnscheduleClock _ cl) = Tag cl type Time (UnscheduleClock _ cl) = Time cl- initClock UnscheduleClock {scheduleClock, scheduleWait} = run $ first (morphS run) <$> initClock scheduleClock+ initClock UnscheduleClock {scheduleClock, scheduleWait} = run $ first (hoistS run) <$> initClock scheduleClock where run :: ScheduleT (Diff (Time cl)) m a -> m a run = runScheduleT scheduleWait
src/FRP/Rhine/Clock/Util.hs view
@@ -3,9 +3,15 @@ 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@@ -19,9 +25,9 @@ (Monad m, Clock m cl) => ClockProxy cl -> Time cl ->- MSF m (Time cl, Tag cl) (TimeInfo cl)+ Automaton m (Time cl, Tag cl) (TimeInfo cl) genTimeInfo _ initialTime = proc (absolute, tag) -> do- lastTime <- iPre initialTime -< absolute+ lastTime <- delay initialTime -< absolute returnA -< TimeInfo
src/FRP/Rhine/Reactimation.hs view
@@ -6,9 +6,6 @@ -} module FRP.Rhine.Reactimation where --- dunai-import Data.MonadicStreamFunction.InternalCore- -- rhine import FRP.Rhine.ClSF.Core import FRP.Rhine.Clock@@ -56,11 +53,27 @@ , Time cl ~ Time (Out cl) ) => Rhine m cl () () ->- m ()+ m void flow rhine = do- msf <- eraseClock rhine- reactimate $ msf >>> arr (const ())+ automaton <- eraseClock rhine+ reactimate $ automaton >>> arr (const ())+{-# INLINE flow #-} +{- | 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'. -}@@ -75,3 +88,4 @@ ClSF m cl () () -> m () reactimateCl cl clsf = flow $ clsf @@ cl+{-# INLINE reactimateCl #-}
src/FRP/Rhine/Reactimation/ClockErasure.hs view
@@ -3,8 +3,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE TupleSections #-} -{- |-Translate clocked signal processing components to stream functions without explicit clock types.+{- | 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'.@@ -14,12 +13,11 @@ -- base import Control.Monad (join) --- dunai-import Control.Monad.Trans.MSF.Reader-import Data.MonadicStreamFunction+-- 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@@ -27,7 +25,7 @@ import FRP.Rhine.ResamplingBuffer import FRP.Rhine.SN -{- | Run a clocked signal function as a monadic stream function,+{- | Run a clocked signal function as an automaton, accepting the timestamps and tags as explicit inputs. -} eraseClockClSF ::@@ -35,12 +33,13 @@ ClockProxy cl -> Time cl -> ClSF m cl a b ->- MSF m (Time cl, Tag 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)+{-# INLINE eraseClockClSF #-} -{- | Run a signal network as a monadic stream function.+{- | Run a signal network as an automaton. Depending on the incoming clock, input data may need to be provided,@@ -53,7 +52,7 @@ (Monad m, Clock m cl, GetClockProxy cl) => Time cl -> SN m cl a b ->- MSF m (Time cl, Tag cl, Maybe a) (Maybe b)+ Automaton m (Time cl, Tag cl, Maybe a) (Maybe b) -- A synchronous signal network is run by erasing the clock from the clocked signal function. eraseClockSN initialTime sn@(Synchronous clsf) = proc (time, tag, Just a) -> do b <- eraseClockClSF (toClockProxy sn) initialTime clsf -< (time, tag, a)@@ -100,17 +99,17 @@ proc (time, tag, aMaybe) -> do bMaybe <- mapMaybeS $ eraseClockClSF (inProxy proxy) initialTime clsf -< (time,,) <$> inTag proxy tag <*> aMaybe eraseClockSN initialTime sn -< (time, tag, bMaybe)-eraseClockSN initialTime (Feedback buf0 sn) =+eraseClockSN initialTime (Feedback ResamplingBuffer {buffer, put, get} sn) = let proxy = toClockProxy sn in- feedback buf0 $ proc ((time, tag, aMaybe), buf) -> do+ 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)- (c, buf') <- arrM $ uncurry get -< (buf, timeInfo)+ 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@@ -118,7 +117,7 @@ returnA -< (Nothing, buf') Just (tagOut, (b, d)) -> do timeInfo <- genTimeInfo (outProxy proxy) initialTime -< (time, tagOut)- buf'' <- arrM $ uncurry $ uncurry put -< ((buf', timeInfo), d)+ buf'' <- arrM $ uncurry $ uncurry put -< ((timeInfo, d), buf') returnA -< (Just b, buf'') eraseClockSN initialTime (FirstResampling sn buf) = let@@ -133,8 +132,9 @@ _ -> Nothing dMaybe <- mapMaybeS $ eraseClockResBuf (inProxy proxy) (outProxy proxy) initialTime buf -< resBufInput returnA -< (,) <$> bMaybe <*> join dMaybe+{-# INLINE eraseClockSN #-} -{- | Translate a resampling buffer into a monadic stream function.+{- | Translate a resampling buffer into an automaton. The input decides whether the buffer is to accept input or has to produce output. (In the latter case, only time information is provided.)@@ -149,14 +149,15 @@ 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+ 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)+ 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)+ Result resBuf' b <- arrM (uncurry get) -< (timeInfo2, resBuf) returnA -< (Just b, resBuf')+{-# INLINE eraseClockResBuf #-}
src/FRP/Rhine/Reactimation/Combinators.hs view
@@ -44,6 +44,7 @@ cl -> Rhine m cl a b (@@) = Rhine . Synchronous+{-# INLINE (@@) #-} {- | A purely syntactical convenience construction enabling quadruple syntax for sequential composition, as described below.
src/FRP/Rhine/ResamplingBuffer.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-}@@ -15,6 +16,9 @@ ) where +-- automaton+import Data.Stream.Result+ -- rhine import FRP.Rhine.Clock @@ -27,7 +31,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@@ -36,18 +40,23 @@ * 'a': The input type * 'b': The output type -}-data ResamplingBuffer m cla clb a b = ResamplingBuffer- { put ::+data ResamplingBuffer m cla clb a b = forall s.+ ResamplingBuffer+ { buffer :: s+ -- ^ The internal state of the buffer.+ , put :: TimeInfo cla -> a ->- m (ResamplingBuffer m cla clb a b)+ s ->+ m s -- ^ Store one input value of type 'a' at a given time stamp,- -- and return a continuation.+ -- and return an updated state. , get :: TimeInfo clb ->- m (b, ResamplingBuffer m cla clb a b)+ s ->+ m (Result s b) -- ^ Retrieve one output value of type 'b' at a given time stamp,- -- and a continuation.+ -- and an updated state. } -- | A type synonym to allow for abbreviation.@@ -59,8 +68,9 @@ (forall c. m1 c -> m2 c) -> ResamplingBuffer m1 cla clb a b -> ResamplingBuffer m2 cla clb a b-hoistResamplingBuffer hoist ResamplingBuffer {..} =+hoistResamplingBuffer morph ResamplingBuffer {..} = ResamplingBuffer- { put = (((hoistResamplingBuffer hoist <$>) . hoist) .) . put- , get = (second (hoistResamplingBuffer hoist) <$>) . hoist . get+ { put = ((morph .) .) . put+ , get = (morph .) . get+ , buffer }
+ src/FRP/Rhine/ResamplingBuffer/ClSF.hs view
@@ -0,0 +1,44 @@+{- |+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+import Data.Stream+import Data.Stream.Optimized (toStreamT)+import Data.Stream.Result (mapResultState)++-- rhine+import FRP.Rhine.ClSF.Core+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) -> return (s, (ti1, a) : as)+ , get = \ti2 (s, as) -> mapResultState (,[]) <$> runReaderT (runReaderT (step s) as) ti2+ }
src/FRP/Rhine/ResamplingBuffer/Collect.hs view
@@ -10,18 +10,21 @@ -- 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`.+ 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.@@ -30,7 +33,7 @@ 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.@@ -41,7 +44,7 @@ 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 @@ -58,4 +61,4 @@ 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
@@ -11,6 +11,9 @@ -- containers import Data.Sequence +-- automaton+import Data.Stream.Result (Result (..))+ -- rhine import FRP.Rhine.ResamplingBuffer import FRP.Rhine.ResamplingBuffer.Timeless@@ -25,8 +28,8 @@ where amPut as a = return $ 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) {- | 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'.@@ -36,8 +39,8 @@ 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)@@ -45,5 +48,5 @@ 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')+ EmptyR -> return $! Result empty (Nothing, 0)+ as' :> a -> return $! Result as' (Just a, length as')
src/FRP/Rhine/ResamplingBuffer/Interpolation.hs view
@@ -101,8 +101,8 @@ ResamplingBuffer m cl1 cl2 v v {- FOURMOLU_DISABLE -} cubic =- ((iPre zeroVector &&& threePointDerivative) &&& (sinceInitS >-> iPre 0))- >-> (clId &&& iPre (zeroVector, 0))+ ((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 -< ()
src/FRP/Rhine/ResamplingBuffer/KeepLast.hs view
@@ -5,6 +5,10 @@ -} module FRP.Rhine.ResamplingBuffer.KeepLast where +-- automaton+import Data.Stream.Result (Result (..))++-- rhine import FRP.Rhine.ResamplingBuffer import FRP.Rhine.ResamplingBuffer.Timeless @@ -16,5 +20,5 @@ keepLast :: (Monad m) => a -> ResamplingBuffer m cl1 cl2 a a keepLast = timelessResamplingBuffer AsyncMealy {..} where- amGet a = return (a, a)+ amGet a = return $! Result a a amPut _ = return
src/FRP/Rhine/ResamplingBuffer/LIFO.hs view
@@ -11,6 +11,9 @@ -- containers import Data.Sequence +-- automaton+import Data.Stream.Result (Result (..))+ -- rhine import FRP.Rhine.ResamplingBuffer import FRP.Rhine.ResamplingBuffer.Timeless@@ -25,8 +28,8 @@ where amPut as a = return $ 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) {- | 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'.@@ -36,8 +39,8 @@ 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)@@ -45,5 +48,5 @@ 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')+ EmptyL -> return $! Result empty (Nothing, 0)+ a :< as' -> return $! Result as' (Just a, length as')
− src/FRP/Rhine/ResamplingBuffer/MSF.hs
@@ -1,40 +0,0 @@-{-# LANGUAGE RecordWildCards #-}--{- |-Collect and process all incoming values statefully and with time stamps.--}-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) =>- -- | 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.- MSF m (TimeInfo cl2, [(TimeInfo cl1, a)]) b ->- ResamplingBuffer m cl1 cl2 a b-msfBuffer = msfBuffer' []- where- msfBuffer' ::- (Monad m) =>- [(TimeInfo cl1, a)] ->- MSF m (TimeInfo cl2, [(TimeInfo cl1, a)]) b ->- ResamplingBuffer m cl1 cl2 a b- msfBuffer' 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
@@ -6,6 +6,10 @@ -} module FRP.Rhine.ResamplingBuffer.Timeless where +-- automaton+import Data.Stream.Result++-- rhine import FRP.Rhine.ResamplingBuffer {- | An asynchronous, effectful Mealy machine description.@@ -14,9 +18,9 @@ -} {- FOURMOLU_DISABLE -} data AsyncMealy m s a b = AsyncMealy- { amPut :: s -> a -> m s+ { amPut :: s -> a -> m s -- ^ Given the previous state and an input value, return the new state.- , amGet :: s -> m (b, s)+ , amGet :: s -> m (Result s b) -- ^ Given the previous state, return an output value and a new state. } {- FOURMOLU_ENABLE -}@@ -30,21 +34,15 @@ -} timelessResamplingBuffer :: (Monad m) =>- AsyncMealy m s a b -> -- The asynchronous Mealy machine from which the buffer is built-+ -- | 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 {..} = go+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 () ()@@ -52,6 +50,6 @@ timelessResamplingBuffer AsyncMealy { amPut = const (const (return ()))- , amGet = const (return ((), ()))+ , amGet = const (return $! Result () ()) } ()
src/FRP/Rhine/ResamplingBuffer/Util.hs view
@@ -8,11 +8,14 @@ -- transformers import Control.Monad.Trans.Reader (runReaderT) --- dunai-import Data.MonadicStreamFunction.InternalCore+-- 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+import FRP.Rhine.ClSF hiding (step) import FRP.Rhine.Clock import FRP.Rhine.ResamplingBuffer @@ -28,13 +31,16 @@ ResamplingBuffer m cl1 cl2 a b -> ClSF m cl2 b c -> ResamplingBuffer m cl1 cl2 a c-resBuf >>-^ clsf = ResamplingBuffer put_ get_+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+ return $! Result (JointState b' s') c+ } infix 1 ^->> @@ -44,13 +50,17 @@ ClSF m cl1 a b -> ResamplingBuffer m cl1 cl2 b c -> ResamplingBuffer m cl1 cl2 a c-clsf ^->> resBuf = ResamplingBuffer put_ get_+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+ return $! JointState buf' s'+ , get = \theTimeInfo (JointState buf s) -> mapResultState (`JointState` s) <$> get theTimeInfo buf+ } infixl 4 *-* @@ -60,16 +70,18 @@ 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')+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+ return $! JointState s1' s2'+ , get = \theTimeInfo (JointState s1 s2) -> do+ Result s1' b <- get1 theTimeInfo s1+ Result s2' d <- get2 theTimeInfo s2+ return $! Result (JointState s1' s2') (b, d)+ } infixl 4 &-&
src/FRP/Rhine/SN.hs view
@@ -35,7 +35,7 @@ * 'b': The output type. Output arrives at the rate @Out cl@. -} data SN m cl a b where- -- | A synchronous monadic stream function is the basic building block.+ -- | 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 :: ( cl ~ In cl, cl ~ Out cl) =>
src/FRP/Rhine/Schedule.hs view
@@ -17,35 +17,68 @@ module FRP.Rhine.Schedule where -- base-import Data.List.NonEmpty (NonEmpty (..))-import qualified Data.List.NonEmpty as N+import Control.Arrow+import Data.List.NonEmpty as N --- dunai-import Data.MonadicStreamFunction-import Data.MonadicStreamFunction.Async (concatS)-import Data.MonadicStreamFunction.InternalCore+-- transformers+import Control.Monad.Trans.Reader -- monad-schedule import Control.Monad.Schedule.Class +-- automaton+import Data.Automaton+import Data.Automaton.Final (getFinal, toFinal)+import Data.Stream+import Data.Stream.Final qualified as StreamFinal+import Data.Stream.Optimized (OptimizedStreamT (..), toStreamT)+import Data.Stream.Result+ -- rhine import FRP.Rhine.Clock -- * Scheduling -scheduleList :: (Monad m, MonadSchedule m) => NonEmpty (MSF m a b) -> MSF m a (NonEmpty b)-scheduleList msfs = scheduleList' msfs []- where- scheduleList' msfs running = MSF $ \a -> do- let bsAndConts = flip unMSF a <$> msfs- (done, running) <- schedule (N.head bsAndConts :| N.tail bsAndConts ++ running)- let (bs, dones) = N.unzip done- return (bs, scheduleList' dones running)+{- | Run several automata concurrently. -{- | Two clocks in the 'ScheduleT' monad transformer- can always be canonically scheduled.- Indeed, this is the purpose for which 'ScheduleT' was defined.+Whenever one automaton outputs a value,+it is returned together with all other values that happen to be output at the same time. -}+scheduleList :: (Monad m, MonadSchedule m) => NonEmpty (Automaton m a b) -> Automaton m a (NonEmpty b)+scheduleList automatons0 =+ Automaton $+ Stateful $+ StreamT+ { state = (getFinal . toFinal <$> automatons0, [])+ , step = \(automatons, running) -> ReaderT $ \a -> do+ let bsAndConts = flip (runReaderT . StreamFinal.getFinal) a <$> automatons+ (done, running') <- schedule (N.head bsAndConts :| N.tail bsAndConts ++ running)+ return $ Result (resultState <$> done, running') $ output <$> done+ }++{- | Run two automata concurrently.++Whenever one automaton returns a value, it is returned.++This is similar to 'scheduleList', but more efficient.+-}+schedulePair :: (Monad m, MonadSchedule m) => Automaton m a b -> Automaton m a b -> Automaton m a b+schedulePair (Automaton automatonL) (Automaton automatonR) = Automaton $! Stateful $! scheduleStreams (toStreamT automatonL) (toStreamT automatonR)+ where+ scheduleStreams :: (Monad m, MonadSchedule m) => StreamT m b -> StreamT m b -> StreamT m b+ scheduleStreams (StreamT stateL0 stepL) (StreamT stateR0 stepR) =+ StreamT+ { state = (stepL stateL0, stepR stateR0)+ , step+ }+ where+ step (runningL, runningR) = do+ result <- race runningL runningR+ case result of+ Left (Result stateL' b, runningR') -> return $ Result (stepL stateL', runningR') b+ Right (runningL', Result stateR' b) -> return $ Result (runningL', stepR stateR') b++-- | Run two running clocks concurrently. runningSchedule :: ( Monad m , MonadSchedule m@@ -58,7 +91,7 @@ RunningClock m (Time cl1) (Tag cl1) -> RunningClock m (Time cl2) (Tag cl2) -> RunningClock m (Time cl1) (Either (Tag cl1) (Tag cl2))-runningSchedule _ _ rc1 rc2 = concatS $ scheduleList [rc1 >>> arr (second Left), rc2 >>> arr (second Right)] >>> arr N.toList+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,
src/FRP/Rhine/Type.hs view
@@ -10,8 +10,8 @@ -} module FRP.Rhine.Type where --- dunai-import Data.MonadicStreamFunction+-- automaton+import Data.Automaton -- rhine import FRP.Rhine.Clock@@ -30,7 +30,7 @@ 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@@ -51,13 +51,14 @@ eraseClock :: (Monad m, Clock m cl, GetClockProxy cl) => Rhine m cl a b ->- m (MSF m a (Maybe 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.@@ -79,3 +80,4 @@ { sn = Feedback buf sn , clock }+{-# INLINE feedbackRhine #-}
test/Clock.hs view
@@ -4,12 +4,14 @@ import Test.Tasty -- rhine+import Clock.Except import Clock.FixedStep import Clock.Millisecond tests = testGroup "Clock"- [ Clock.FixedStep.tests+ [ Clock.Except.tests+ , Clock.FixedStep.tests , Clock.Millisecond.tests ]
+ test/Clock/Except.hs view
@@ -0,0 +1,184 @@+{-# 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 ()++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/Millisecond.hs view
@@ -1,31 +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 (testCase, (@?=))+import Test.Tasty.HUnit (Assertion, assertBool, testCase) -- rhine import FRP.Rhine import Util (runRhine) -secondsSinceInit :: (Monad m) => ClSF m (Millisecond n) a Int-secondsSinceInit = sinceInitS >>> arr round+-- | 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 "Runs to second precision" $ do- output <- runRhine (secondsSinceInit @@ (waitClock @1000)) $ replicate 5 ()- output @?= Just <$> [1, 2, 3, 4, 5]+ [ 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 (secondsSinceInit @@ (waitClock @3000) >-- collect --> (clId &&& secondsSinceInit) @@ (waitClock @5000)) $ replicate 5 ()- output- @?= [ Nothing- , Just ([3], 5)- , Nothing- , Nothing- , Just ([9, 6], 10)- ]+ 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
@@ -5,6 +5,7 @@ -- rhine import Clock+import Except import Schedule main =@@ -12,5 +13,6 @@ testGroup "Main" [ Clock.tests+ , Except.tests , Schedule.tests ]
test/Schedule.hs view
@@ -16,8 +16,11 @@ -- monad-schedule import Control.Monad.Schedule.Trans (Schedule, runScheduleT, wait) +-- automaton+import Data.Automaton (accumulateWith, constM, embed)+ -- rhine-import FRP.Rhine.Clock (Clock (initClock), RunningClockInit, accumulateWith, constM, embed)+import FRP.Rhine.Clock (Clock (initClock), RunningClockInit) import FRP.Rhine.Clock.FixedStep (FixedStep (FixedStep)) import FRP.Rhine.Schedule import Util
test/Util.hs view
@@ -1,11 +1,12 @@ module Util where +-- base+import Data.Functor.Identity (Identity (runIdentity))+ -- monad-schedule import Control.Monad.Schedule.Trans (Schedule, runScheduleT) -- rhine--import Data.Functor.Identity (Identity (runIdentity)) import FRP.Rhine runScheduleRhinePure :: (Clock (Schedule (Diff (Time cl))) cl, GetClockProxy cl) => Rhine (Schedule (Diff (Time cl))) cl a b -> [a] -> [Maybe b]@@ -13,8 +14,8 @@ runRhine :: (Clock m cl, GetClockProxy cl, Monad m) => Rhine m cl a b -> [a] -> m [Maybe b] runRhine rhine input = do- msf <- eraseClock rhine- embed msf input+ automaton <- eraseClock rhine+ embed automaton input -- FIXME Move to monad-schedule runSchedule :: Schedule diff a -> a
+ test/assets/testdata.txt view
@@ -0,0 +1,2 @@+test+data