diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,9 @@ +-- criterion +import Criterion.Main + +-- rhine +import Sum +import WordCount + +main :: IO () +main = defaultMain [WordCount.benchmarks, Sum.benchmarks] diff --git a/bench/Sum.hs b/bench/Sum.hs new file mode 100644 --- /dev/null +++ b/bench/Sum.hs @@ -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] diff --git a/bench/Test.hs b/bench/Test.hs new file mode 100644 --- /dev/null +++ b/bench/Test.hs @@ -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 + ] + ] diff --git a/bench/WordCount.hs b/bench/WordCount.hs new file mode 100644 --- /dev/null +++ b/bench/WordCount.hs @@ -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 diff --git a/bench/pg100.txt b/bench/pg100.txt new file mode 100644 # file too large to diff: bench/pg100.txt diff --git a/rhine.cabal b/rhine.cabal --- a/rhine.cabal +++ b/rhine.cabal @@ -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 diff --git a/src/Control/Monad/Schedule.hs b/src/Control/Monad/Schedule.hs deleted file mode 100644 --- a/src/Control/Monad/Schedule.hs +++ /dev/null @@ -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) diff --git a/src/FRP/Rhine.hs b/src/FRP/Rhine.hs --- a/src/FRP/Rhine.hs +++ b/src/FRP/Rhine.hs @@ -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 diff --git a/src/FRP/Rhine/ClSF.hs b/src/FRP/Rhine/ClSF.hs --- a/src/FRP/Rhine/ClSF.hs +++ b/src/FRP/Rhine/ClSF.hs @@ -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 diff --git a/src/FRP/Rhine/ClSF/Core.hs b/src/FRP/Rhine/ClSF/Core.hs --- a/src/FRP/Rhine/ClSF/Core.hs +++ b/src/FRP/Rhine/ClSF/Core.hs @@ -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 diff --git a/src/FRP/Rhine/ClSF/Except.hs b/src/FRP/Rhine/ClSF/Except.hs --- a/src/FRP/Rhine/ClSF/Except.hs +++ b/src/FRP/Rhine/ClSF/Except.hs @@ -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 diff --git a/src/FRP/Rhine/ClSF/Except/Util.hs b/src/FRP/Rhine/ClSF/Except/Util.hs --- a/src/FRP/Rhine/ClSF/Except/Util.hs +++ b/src/FRP/Rhine/ClSF/Except/Util.hs @@ -1,7 +1,6 @@ -{-| +{- | Utilities for 'FRP.Rhine.ClSF.Except' that need not be exported. -} - module FRP.Rhine.ClSF.Except.Util where -- transformers diff --git a/src/FRP/Rhine/ClSF/Random.hs b/src/FRP/Rhine/ClSF/Random.hs --- a/src/FRP/Rhine/ClSF/Random.hs +++ b/src/FRP/Rhine/ClSF/Random.hs @@ -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 diff --git a/src/FRP/Rhine/ClSF/Random/Util.hs b/src/FRP/Rhine/ClSF/Random/Util.hs --- a/src/FRP/Rhine/ClSF/Random/Util.hs +++ b/src/FRP/Rhine/ClSF/Random/Util.hs @@ -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 - diff --git a/src/FRP/Rhine/ClSF/Reader.hs b/src/FRP/Rhine/ClSF/Reader.hs --- a/src/FRP/Rhine/ClSF/Reader.hs +++ b/src/FRP/Rhine/ClSF/Reader.hs @@ -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_ #-} diff --git a/src/FRP/Rhine/ClSF/Upsample.hs b/src/FRP/Rhine/ClSF/Upsample.hs --- a/src/FRP/Rhine/ClSF/Upsample.hs +++ b/src/FRP/Rhine/ClSF/Upsample.hs @@ -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) diff --git a/src/FRP/Rhine/ClSF/Util.hs b/src/FRP/Rhine/ClSF/Util.hs --- a/src/FRP/Rhine/ClSF/Util.hs +++ b/src/FRP/Rhine/ClSF/Util.hs @@ -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) diff --git a/src/FRP/Rhine/Clock.hs b/src/FRP/Rhine/Clock.hs --- a/src/FRP/Rhine/Clock.hs +++ b/src/FRP/Rhine/Clock.hs @@ -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 + , .. + } diff --git a/src/FRP/Rhine/Clock/Except.hs b/src/FRP/Rhine/Clock/Except.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Rhine/Clock/Except.hs @@ -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 diff --git a/src/FRP/Rhine/Clock/FixedStep.hs b/src/FRP/Rhine/Clock/FixedStep.hs --- a/src/FRP/Rhine/Clock/FixedStep.hs +++ b/src/FRP/Rhine/Clock/FixedStep.hs @@ -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" diff --git a/src/FRP/Rhine/Clock/Periodic.hs b/src/FRP/Rhine/Clock/Periodic.hs --- a/src/FRP/Rhine/Clock/Periodic.hs +++ b/src/FRP/Rhine/Clock/Periodic.hs @@ -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 diff --git a/src/FRP/Rhine/Clock/Proxy.hs b/src/FRP/Rhine/Clock/Proxy.hs --- a/src/FRP/Rhine/Clock/Proxy.hs +++ b/src/FRP/Rhine/Clock/Proxy.hs @@ -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 diff --git a/src/FRP/Rhine/Clock/Realtime.hs b/src/FRP/Rhine/Clock/Realtime.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Rhine/Clock/Realtime.hs @@ -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) + } diff --git a/src/FRP/Rhine/Clock/Realtime/Audio.hs b/src/FRP/Rhine/Clock/Realtime/Audio.hs --- a/src/FRP/Rhine/Clock/Realtime/Audio.hs +++ b/src/FRP/Rhine/Clock/Realtime/Audio.hs @@ -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 + } diff --git a/src/FRP/Rhine/Clock/Realtime/Busy.hs b/src/FRP/Rhine/Clock/Realtime/Busy.hs --- a/src/FRP/Rhine/Clock/Realtime/Busy.hs +++ b/src/FRP/Rhine/Clock/Realtime/Busy.hs @@ -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 diff --git a/src/FRP/Rhine/Clock/Realtime/Event.hs b/src/FRP/Rhine/Clock/Realtime/Event.hs --- a/src/FRP/Rhine/Clock/Realtime/Event.hs +++ b/src/FRP/Rhine/Clock/Realtime/Event.hs @@ -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 + } diff --git a/src/FRP/Rhine/Clock/Realtime/Millisecond.hs b/src/FRP/Rhine/Clock/Realtime/Millisecond.hs --- a/src/FRP/Rhine/Clock/Realtime/Millisecond.hs +++ b/src/FRP/Rhine/Clock/Realtime/Millisecond.hs @@ -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) diff --git a/src/FRP/Rhine/Clock/Realtime/Never.hs b/src/FRP/Rhine/Clock/Realtime/Never.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Rhine/Clock/Realtime/Never.hs @@ -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 diff --git a/src/FRP/Rhine/Clock/Realtime/Stdin.hs b/src/FRP/Rhine/Clock/Realtime/Stdin.hs --- a/src/FRP/Rhine/Clock/Realtime/Stdin.hs +++ b/src/FRP/Rhine/Clock/Realtime/Stdin.hs @@ -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 diff --git a/src/FRP/Rhine/Clock/Select.hs b/src/FRP/Rhine/Clock/Select.hs --- a/src/FRP/Rhine/Clock/Select.hs +++ b/src/FRP/Rhine/Clock/Select.hs @@ -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) diff --git a/src/FRP/Rhine/Clock/Skip.hs b/src/FRP/Rhine/Clock/Skip.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Rhine/Clock/Skip.hs @@ -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 #-} diff --git a/src/FRP/Rhine/Clock/Trivial.hs b/src/FRP/Rhine/Clock/Trivial.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Rhine/Clock/Trivial.hs @@ -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 diff --git a/src/FRP/Rhine/Clock/Util.hs b/src/FRP/Rhine/Clock/Util.hs --- a/src/FRP/Rhine/Clock/Util.hs +++ b/src/FRP/Rhine/Clock/Util.hs @@ -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 #-} diff --git a/src/FRP/Rhine/Reactimation.hs b/src/FRP/Rhine/Reactimation.hs --- a/src/FRP/Rhine/Reactimation.hs +++ b/src/FRP/Rhine/Reactimation.hs @@ -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 #-} diff --git a/src/FRP/Rhine/Reactimation/ClockErasure.hs b/src/FRP/Rhine/Reactimation/ClockErasure.hs --- a/src/FRP/Rhine/Reactimation/ClockErasure.hs +++ b/src/FRP/Rhine/Reactimation/ClockErasure.hs @@ -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 #-} diff --git a/src/FRP/Rhine/Reactimation/Combinators.hs b/src/FRP/Rhine/Reactimation/Combinators.hs --- a/src/FRP/Rhine/Reactimation/Combinators.hs +++ b/src/FRP/Rhine/Reactimation/Combinators.hs @@ -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 -} diff --git a/src/FRP/Rhine/ResamplingBuffer.hs b/src/FRP/Rhine/ResamplingBuffer.hs --- a/src/FRP/Rhine/ResamplingBuffer.hs +++ b/src/FRP/Rhine/ResamplingBuffer.hs @@ -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 + } diff --git a/src/FRP/Rhine/ResamplingBuffer/ClSF.hs b/src/FRP/Rhine/ResamplingBuffer/ClSF.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Rhine/ResamplingBuffer/ClSF.hs @@ -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 + } diff --git a/src/FRP/Rhine/ResamplingBuffer/Collect.hs b/src/FRP/Rhine/ResamplingBuffer/Collect.hs --- a/src/FRP/Rhine/ResamplingBuffer/Collect.hs +++ b/src/FRP/Rhine/ResamplingBuffer/Collect.hs @@ -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 diff --git a/src/FRP/Rhine/ResamplingBuffer/FIFO.hs b/src/FRP/Rhine/ResamplingBuffer/FIFO.hs --- a/src/FRP/Rhine/ResamplingBuffer/FIFO.hs +++ b/src/FRP/Rhine/ResamplingBuffer/FIFO.hs @@ -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') diff --git a/src/FRP/Rhine/ResamplingBuffer/Interpolation.hs b/src/FRP/Rhine/ResamplingBuffer/Interpolation.hs --- a/src/FRP/Rhine/ResamplingBuffer/Interpolation.hs +++ b/src/FRP/Rhine/ResamplingBuffer/Interpolation.hs @@ -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 -} diff --git a/src/FRP/Rhine/ResamplingBuffer/KeepLast.hs b/src/FRP/Rhine/ResamplingBuffer/KeepLast.hs --- a/src/FRP/Rhine/ResamplingBuffer/KeepLast.hs +++ b/src/FRP/Rhine/ResamplingBuffer/KeepLast.hs @@ -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 diff --git a/src/FRP/Rhine/ResamplingBuffer/LIFO.hs b/src/FRP/Rhine/ResamplingBuffer/LIFO.hs --- a/src/FRP/Rhine/ResamplingBuffer/LIFO.hs +++ b/src/FRP/Rhine/ResamplingBuffer/LIFO.hs @@ -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') diff --git a/src/FRP/Rhine/ResamplingBuffer/MSF.hs b/src/FRP/Rhine/ResamplingBuffer/MSF.hs deleted file mode 100644 --- a/src/FRP/Rhine/ResamplingBuffer/MSF.hs +++ /dev/null @@ -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') diff --git a/src/FRP/Rhine/ResamplingBuffer/Timeless.hs b/src/FRP/Rhine/ResamplingBuffer/Timeless.hs --- a/src/FRP/Rhine/ResamplingBuffer/Timeless.hs +++ b/src/FRP/Rhine/ResamplingBuffer/Timeless.hs @@ -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 () ()) + } + () diff --git a/src/FRP/Rhine/ResamplingBuffer/Util.hs b/src/FRP/Rhine/ResamplingBuffer/Util.hs --- a/src/FRP/Rhine/ResamplingBuffer/Util.hs +++ b/src/FRP/Rhine/ResamplingBuffer/Util.hs @@ -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} diff --git a/src/FRP/Rhine/SN.hs b/src/FRP/Rhine/SN.hs --- a/src/FRP/Rhine/SN.hs +++ b/src/FRP/Rhine/SN.hs @@ -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 #-} diff --git a/src/FRP/Rhine/SN/Combinators.hs b/src/FRP/Rhine/SN/Combinators.hs --- a/src/FRP/Rhine/SN/Combinators.hs +++ b/src/FRP/Rhine/SN/Combinators.hs @@ -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) diff --git a/src/FRP/Rhine/SN/Type.hs b/src/FRP/Rhine/SN/Type.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Rhine/SN/Type.hs @@ -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 diff --git a/src/FRP/Rhine/Schedule.hs b/src/FRP/Rhine/Schedule.hs --- a/src/FRP/Rhine/Schedule.hs +++ b/src/FRP/Rhine/Schedule.hs @@ -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 diff --git a/src/FRP/Rhine/Schedule/Concurrently.hs b/src/FRP/Rhine/Schedule/Concurrently.hs deleted file mode 100644 --- a/src/FRP/Rhine/Schedule/Concurrently.hs +++ /dev/null @@ -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 () diff --git a/src/FRP/Rhine/Schedule/Trans.hs b/src/FRP/Rhine/Schedule/Trans.hs deleted file mode 100644 --- a/src/FRP/Rhine/Schedule/Trans.hs +++ /dev/null @@ -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' - ) diff --git a/src/FRP/Rhine/Schedule/Util.hs b/src/FRP/Rhine/Schedule/Util.hs deleted file mode 100644 --- a/src/FRP/Rhine/Schedule/Util.hs +++ /dev/null @@ -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 diff --git a/src/FRP/Rhine/TimeDomain.hs b/src/FRP/Rhine/TimeDomain.hs deleted file mode 100644 --- a/src/FRP/Rhine/TimeDomain.hs +++ /dev/null @@ -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 = (-) diff --git a/src/FRP/Rhine/Type.hs b/src/FRP/Rhine/Type.hs --- a/src/FRP/Rhine/Type.hs +++ b/src/FRP/Rhine/Type.hs @@ -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 #-} diff --git a/test/Clock.hs b/test/Clock.hs new file mode 100644 --- /dev/null +++ b/test/Clock.hs @@ -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 + ] diff --git a/test/Clock/Except.hs b/test/Clock/Except.hs new file mode 100644 --- /dev/null +++ b/test/Clock/Except.hs @@ -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 diff --git a/test/Clock/FixedStep.hs b/test/Clock/FixedStep.hs new file mode 100644 --- /dev/null +++ b/test/Clock/FixedStep.hs @@ -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) + ] + ] diff --git a/test/Clock/Millisecond.hs b/test/Clock/Millisecond.hs new file mode 100644 --- /dev/null +++ b/test/Clock/Millisecond.hs @@ -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 diff --git a/test/Except.hs b/test/Except.hs new file mode 100644 --- /dev/null +++ b/test/Except.hs @@ -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]] + ] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 + ] diff --git a/test/Schedule.hs b/test/Schedule.hs new file mode 100644 --- /dev/null +++ b/test/Schedule.hs @@ -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 ()) + ] + ] + ] diff --git a/test/Util.hs b/test/Util.hs new file mode 100644 --- /dev/null +++ b/test/Util.hs @@ -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 diff --git a/test/assets/testdata.txt b/test/assets/testdata.txt new file mode 100644 --- /dev/null +++ b/test/assets/testdata.txt @@ -0,0 +1,2 @@ +test +data