Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Improve clock erasure in the light of automata #309

Open
wants to merge 12 commits into
base: master
Choose a base branch
from
Open
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
4 changes: 2 additions & 2 deletions CHEATSHEET.md
Original file line number Diff line number Diff line change
@@ -109,8 +109,8 @@ rhL -- A rhine that inputs some data `a` and outputs some data `b`, on some c

### Clocked signal functions (`ClSF`s)

Stream functions in [`dunai`](http://hackage.haskell.org/package/dunai) are usually valid clocked signal functions.
Here are some that are not in `dunai`.
Automata in [`automaton`](http://hackage.haskell.org/package/automaton) are usually valid clocked signal functions.
Here are some of the most used:

| Name | Type (abbreviated) | Meaning |
|--------------|------------------------------------------------------|---------------------------------------------------|
7 changes: 3 additions & 4 deletions README.md
Original file line number Diff line number Diff line change
@@ -8,12 +8,11 @@ Rhine is a library for synchronous and asynchronous Functional Reactive Programm
It separates the aspects of clocking, scheduling and resampling
from each other, and ensures clock-safety on the type level.

## Versions 1.* vs. 0.*
## Recent breakage?

Confused because some examples from the article don't work anymore?
As a big simplification and breaking change,
explicit schedules were removed in version 1.0.
For an overview of the required changes, see [this page](/version1.md).
Rhine went through a few bigger API simplifications and changes.
If this broke your code, have a look at [the versions readme](./versions.md) to fix it.

## Concept

5 changes: 5 additions & 0 deletions automaton/CHANGELOG.md
Original file line number Diff line number Diff line change
@@ -0,0 +1,5 @@
# Revision history for automaton

## 0.1.0.0

* Initial version ;)
20 changes: 20 additions & 0 deletions automaton/LICENSE
Original file line number Diff line number Diff line change
@@ -0,0 +1,20 @@
Copyright (c) 2024 Manuel Bärenz

Permission is hereby granted, free of charge, to any person obtaining
a copy of this software and associated documentation files (the
"Software"), to deal in the Software without restriction, including
without limitation the rights to use, copy, modify, merge, publish,
distribute, sublicense, and/or sell copies of the Software, and to
permit persons to whom the Software is furnished to do so, subject to
the following conditions:

The above copyright notice and this permission notice shall be included
in all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
70 changes: 70 additions & 0 deletions automaton/README.md
Original file line number Diff line number Diff line change
@@ -0,0 +1,70 @@
# `automaton`: Effectful streams and automata in initial encoding

This library defines effectful streams and automata, in initial encoding.
They are useful to define effectful automata, or state machines, transducers, monadic stream functions and similar streaming abstractions.
In comparison to most other libraries, they are implemented here with explicit state types,
and thus are amenable to GHC optimizations, often resulting in dramatically better performance.

## What?

The core concept is an effectful stream in initial encoding:
```haskell
data StreamT m a = forall s.
StreamT
{ state :: s
, step :: s -> m (s, a)
}
```
This is an stream because you can repeatedly call `step` on the `state` and produce output values `a`,
while mutating the internal state.
It is effectful because each step performs a side effect in `m`, typically a monad.

The definitions you will most often find in the wild is the "final encoding":
```haskell
data StreamT m a = StreamT (m (StreamT m a, a))
```
Semantically, there is no big difference between them, and in nearly all cases you can map the initial encoding onto the final one and vice versa.
(For the single edge case, see [the section in `Data.Automaton` about recursive definitions](hackage.haskell.org/package/automaton/docs/Data.Automaton.html).)
But when composing streams,
the initial encoding will often be more performant that than the final encoding because GHC can optimise the joint state and step functions of the streams.

### How are these automata?

Effectful streams are very versatile, because you can change the effect type `m` to get a number of different concepts.
When `m` contains a `Reader` effect, you get automata!
From the effectful stream alone, a side effect, a state transition and an output value is produced at every step.
If this effect includes reading an input value, you have all ingredients for an automaton (also known as a Mealy state machine, or a transducer).

Automata can be composed in many useful ways, and are very expressive.
A lot of reactive programs can be written with them,
by composing a big program out of many automaton components.

## Why?

Mostly, performance.
When composing a big automaton out of small ones, the final encoding is not very performant, as mentioned above:
Each step of each component contains a closure, which is basically opaque for the compiler.
In the initial encoding, the step functions of two composed automata are themselves composed, and the compiler can optimize them just like any regular function.
This often results in massive speedups.

### But really, why?

To serve as the basic building block in [`rhine`](https://hackage.haskell.org/package/rhine),
a library for Functional Reactive Programming.

## Doesn't this exist already?

Not quite.
There are many streaming libraries ([`streamt`](https://hackage.haskell.org/package/streamt), [`streaming`](https://hackage.haskell.org/package/streaming)),
and state machine libraries ([`machines`](https://hackage.haskell.org/package/machines)) that implement effectful streams.
Prominently, [`dunai`](https://hackage.haskell.org/package/dunai) implements monadic stream functions
(which are essentially effectful state machines)
and has inspired the design and API of this package to a great extent.
(Feel free to extend this list by other notable libraries.)
But all of these are implemented in the final encoding.

I am aware of only two fleshed-out implementations of effectful automata in the initial encoding,
both of which have been a big inspiration for this package:

* [`essence-of-live-coding`](https://hackage.haskell.org/package/essence-of-live-coding) restricts the state type to be serializable, gaining live coding capabilities, but sacrificing on expressivity.
* https://github.com/lexi-lambda/incremental/blob/master/src/Incremental/Fast.hs is unfortunately not published on Hackage, and doesn't seem maintained.
99 changes: 99 additions & 0 deletions automaton/automaton.cabal
Original file line number Diff line number Diff line change
@@ -0,0 +1,99 @@
cabal-version: 3.0
name: automaton
version: 0.1.0.0
synopsis: Effectful streams and automata in initial encoding
description:
Effectful streams have an internal state and a step function.
Varying the effect type, this gives many different useful concepts:
For example with a reader effect, it results in automata/transducers/state machines.

license: MIT
license-file: LICENSE
author: Manuel Bärenz
maintainer: programming@manuelbaerenz.de
category: Streaming
build-type: Simple
extra-doc-files:
CHANGELOG.md
README.md

common opts
build-depends:
MonadRandom >=0.5,
base >=4.14 && <4.18,
mmorph ^>=1.2,
mtl >=2.2 && <2.4,
profunctors ^>=5.6,
selective ^>=0.7,
semialign ^>=1.3,
simple-affine-space ^>=0.2,
these ^>=1.2,
transformers >=0.5,

if flag(dev)
ghc-options: -Werror
ghc-options:
-W

default-extensions:
Arrows
DataKinds
FlexibleContexts
FlexibleInstances
ImportQualifiedPost
MultiParamTypeClasses
NamedFieldPuns
NoStarIsType
TupleSections
TypeApplications
TypeFamilies
TypeOperators

default-language: Haskell2010

library
import: opts
exposed-modules:
Data.Automaton
Data.Automaton.Final
Data.Automaton.Trans.Except
Data.Automaton.Trans.Maybe
Data.Automaton.Trans.RWS
Data.Automaton.Trans.Random
Data.Automaton.Trans.Reader
Data.Automaton.Trans.State
Data.Automaton.Trans.Writer
Data.Stream
Data.Stream.Except
Data.Stream.Final
Data.Stream.Internal
Data.Stream.Optimized
Data.Stream.Result

other-modules:
Data.Automaton.Trans.Except.Internal
Data.Stream.Final.Except

hs-source-dirs: src

test-suite automaton-test
import: opts
type: exitcode-stdio-1.0
hs-source-dirs: test
main-is: Main.hs
other-modules:
Automaton
Automaton.Except
Stream

build-depends:
QuickCheck ^>=2.14,
automaton,
tasty ^>=1.4,
tasty-hunit ^>=0.10,
tasty-quickcheck ^>=0.10,

flag dev
description: Enable warnings as errors. Active on ci.
default: False
manual: True
511 changes: 511 additions & 0 deletions automaton/src/Data/Automaton.hs

Large diffs are not rendered by default.

36 changes: 36 additions & 0 deletions automaton/src/Data/Automaton/Final.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,36 @@
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Data.Automaton.Final where

-- base
import Control.Applicative (Alternative)
import Control.Arrow
import Control.Category
import Prelude hiding (id, (.))

-- transformers
import Control.Monad.Trans.Reader

-- automaton
import Data.Automaton
import Data.Stream.Final qualified as StreamFinal
import Data.Stream.Optimized qualified as StreamOptimized

-- | Automata in final encoding.
newtype Final m a b = Final {getFinal :: StreamFinal.Final (ReaderT a m) b}
deriving newtype (Functor, Applicative, Alternative)

instance (Monad m) => Category (Final m) where
id = toFinal id
f1 . f2 = toFinal $ fromFinal f1 . fromFinal f2

instance (Monad m) => Arrow (Final m) where
arr = toFinal . arr
first = toFinal . first . fromFinal

toFinal :: (Functor m) => Automaton m a b -> Final m a b
toFinal (Automaton automaton) = Final $ StreamOptimized.toFinal automaton

fromFinal :: Final m a b -> Automaton m a b
fromFinal Final {getFinal} = Automaton $ StreamOptimized.fromFinal getFinal
327 changes: 327 additions & 0 deletions automaton/src/Data/Automaton/Trans/Except.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,327 @@
{-# LANGUAGE Arrows #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE StrictData #-}

{- | An 'Automaton' in the 'ExceptT' monad can throw an exception to terminate.
This module defines several ways to throw exceptions,
and implements control flow by handling them.
The API is heavily inspired by @dunai@.
-}
module Data.Automaton.Trans.Except (
module Data.Automaton.Trans.Except,
module Control.Monad.Trans.Except,
)
where

-- base
import Control.Arrow (arr, returnA, (<<<), (>>>))
import Control.Category qualified as Category
import Data.Void (Void, absurd)

-- transformers
import Control.Monad.Trans.Except (ExceptT (..), runExceptT, throwE)
import Control.Monad.Trans.Maybe (MaybeT, runMaybeT)
import Control.Monad.Trans.Reader

-- selective
import Control.Selective (Selective)

-- mmorph
import Control.Monad.Morph

-- automaton
import Data.Automaton (
Automaton (..),
arrM,
constM,
count,
feedback,
hoistS,
liftS,
mapMaybeS,
reactimate,
)
import Data.Automaton.Trans.Except.Internal
import Data.Stream.Except hiding (safely)
import Data.Stream.Except qualified as StreamExcept
import Data.Stream.Optimized (mapOptimizedStreamT)
import Data.Stream.Optimized qualified as StreamOptimized

-- * Throwing exceptions

-- | Throw the exception 'e' whenever the function evaluates to 'True'.
throwOnCond :: (Monad m) => (a -> Bool) -> e -> Automaton (ExceptT e m) a a
throwOnCond cond e = proc a ->
if cond a
then throwS -< e
else returnA -< a

{- | Throws the exception when the input is 'True'. Variant of 'throwOnCond'
for Kleisli arrows.
-}
throwOnCondM :: (Monad m) => (a -> m Bool) -> e -> Automaton (ExceptT e m) a a
throwOnCondM cond e = proc a -> do
b <- arrM (lift . cond) -< a
if b
then throwS -< e
else returnA -< a

-- | Throw the exception when the input is 'True'.
throwOn :: (Monad m) => e -> Automaton (ExceptT e m) Bool ()
throwOn e = proc b -> throwOn' -< (b, e)

-- | Variant of 'throwOn', where the exception may change every tick.
throwOn' :: (Monad m) => Automaton (ExceptT e m) (Bool, e) ()
throwOn' = proc (b, e) ->
if b
then throwS -< e
else returnA -< ()

{- | When the input is @Just e@, throw the exception @e@.
This does not output any data since it terminates on the first nontrivial input.
-}
throwMaybe :: (Monad m) => Automaton (ExceptT e m) (Maybe e) (Maybe void)
throwMaybe = mapMaybeS throwS

{- | Immediately throw the incoming exception.
This is useful to combine with 'ArrowChoice',
e.g. with @if@ and @case@ expressions in Arrow syntax.
-}
throwS :: (Monad m) => Automaton (ExceptT e m) e a
throwS = arrM throwE

-- | Immediately throw the given exception.
throw :: (Monad m) => e -> Automaton (ExceptT e m) a b
throw = constM . throwE

-- | Do not throw an exception.
pass :: (Monad m) => Automaton (ExceptT e m) a a
pass = Category.id

{- | Converts an 'Automaton' in 'MaybeT' to an 'Automaton' in 'ExceptT'.
Whenever 'Nothing' is thrown, throw @()@ instead.
-}
maybeToExceptS ::
(Functor m, Monad m) =>
Automaton (MaybeT m) a b ->
Automaton (ExceptT () m) a b
maybeToExceptS = hoistS (ExceptT . (maybe (Left ()) Right <$>) . runMaybeT)

-- * Catching exceptions

{- | Catch an exception in an 'Automaton'.
As soon as an exception occurs, switch to a new 'Automaton',
the exception handler, based on the exception value.
For exception catching where the handler can throw further exceptions, see 'AutomatonExcept' further below.
-}
catchS :: (Monad m) => Automaton (ExceptT e m) a b -> (e -> Automaton m a b) -> Automaton m a b
catchS automaton f = safely $ do
e <- try automaton
safe $ f e

-- | Similar to Yampa's delayed switching. Loses a @b@ in case of an exception.
untilE ::
(Monad m) =>
Automaton m a b ->
Automaton m b (Maybe e) ->
Automaton (ExceptT e m) a b
untilE automaton automatone = proc a -> do
b <- liftS automaton -< a
me <- liftS automatone -< b
inExceptT -< ExceptT $ return $ maybe (Right b) Left me

{- | Escape an 'ExceptT' layer by outputting the exception whenever it occurs.
If an exception occurs, the current state is is tested again on the next input.
-}
exceptS :: (Functor m, Monad m) => Automaton (ExceptT e m) a b -> Automaton m a (Either e b)
exceptS = Automaton . StreamOptimized.exceptS . mapOptimizedStreamT commuteReader . getAutomaton

{- | Embed an 'ExceptT' value inside the 'Automaton'.
Whenever the input value is an ordinary value, it is passed on. If it is an exception, it is raised.
-}
inExceptT :: (Monad m) => Automaton (ExceptT e m) (ExceptT e m a) a
inExceptT = arrM id

{- | In case an exception occurs in the first argument, replace the exception
by the second component of the tuple.
-}
tagged :: (Monad m) => Automaton (ExceptT e1 m) a b -> Automaton (ExceptT e2 m) (a, e2) b
tagged automaton = runAutomatonExcept $ try (automaton <<< arr fst) *> (snd <$> currentInput)

-- * Monad interface for Exception Automatons

{- | An 'Automaton' that can terminate with an exception.
* @m@: The monad that the 'Automaton' may take side effects in.
* @a@: The type of input values the stream constantly consumes.
* @b@: The type of output values the stream constantly produces.
* @e@: The type of exceptions with which the stream can terminate.
This type is useful because it is a monad in the /exception type/ @e@.
* 'return' corresponds to throwing an exception immediately.
* '>>=' is exception handling: The first value throws an exception, while
the Kleisli arrow handles the exception and produces a new signal
function, which can throw exceptions in a different type.
Consider this example:
@
automaton :: AutomatonExcept a b m e1
f :: e1 -> AutomatonExcept a b m e2
example :: AutomatonExcept a b m e2
example = automaton >>= f
@
Here, @automaton@ produces output values of type @b@ until an exception @e1@ occurs.
The function @f@ is called on the exception value and produces a continuation automaton
which is then executed (until it possibly throws an exception @e2@ itself).
The generality of the monad interface comes at a cost, though.
In order to achieve higher performance, you should use the 'Monad' interface sparingly.
Whenever you can express the same control flow using 'Functor', 'Applicative', 'Selective',
or just the '(>>)' operator, you should do this.
The encoding of the internal state type will be much more efficiently optimized.
The reason for this is that in an expression @ma >>= f@,
the type of @f@ is @e1 -> AutomatonExcept a b m e2@,
which implies that the state of the 'AutomatonExcept' produced isn't known at compile time,
and thus GHC cannot optimize the automaton.
But often the full expressiveness of '>>=' isn't necessary, and in these cases,
a much faster automaton is produced by using 'Functor', 'Applicative' and 'Selective'.
Note: By "exceptions", we mean an 'ExceptT' transformer layer, not 'IO' exceptions.
-}
newtype AutomatonExcept a b m e = AutomatonExcept {getAutomatonExcept :: StreamExcept b (ReaderT a m) e}
deriving newtype (Functor, Applicative, Selective, Monad)

instance MonadTrans (AutomatonExcept a b) where
lift = AutomatonExcept . lift . lift

instance MFunctor (AutomatonExcept a b) where
hoist morph = AutomatonExcept . hoist (mapReaderT morph) . getAutomatonExcept

runAutomatonExcept :: (Monad m) => AutomatonExcept a b m e -> Automaton (ExceptT e m) a b
runAutomatonExcept = Automaton . hoist commuteReaderBack . runStreamExcept . getAutomatonExcept

{- | Execute an 'Automaton' in 'ExceptT' until it raises an exception.
Typically used to enter the monad context of 'AutomatonExcept'.
-}
try :: (Monad m) => Automaton (ExceptT e m) a b -> AutomatonExcept a b m e
try = AutomatonExcept . InitialExcept . hoist commuteReader . getAutomaton

{- | Immediately throw the current input as an exception.
Useful inside 'AutomatonExcept' if you don't want to advance a further step in execution,
but first see what the current input is before continuing.
-}
currentInput :: (Monad m) => AutomatonExcept e b m e
currentInput = try throwS

{- | If no exception can occur, the 'Automaton' can be executed without the 'ExceptT'
layer.
Used to exit the 'AutomatonExcept' context, often in combination with 'safe':
@
automaton = safely $ do
e <- try someAutomaton
once $ \input -> putStrLn $ "Whoops, something happened when receiving input " ++ show input ++ ": " ++ show e ++ ", but I'll continue now."
safe fallbackAutomaton
-}
safely :: (Monad m) => AutomatonExcept a b m Void -> Automaton m a b
safely = Automaton . StreamExcept.safely . getAutomatonExcept

{- | An 'Automaton' without an 'ExceptT' layer never throws an exception, and can
thus have an arbitrary exception type.
In particular, the exception type can be 'Void', so it can be used as the last statement in an 'AutomatonExcept' @do@-block.
See 'safely' for an example.
-}
safe :: (Monad m) => Automaton m a b -> AutomatonExcept a b m e
safe = try . liftS

{- | Inside the 'AutomatonExcept' monad, execute an action of the wrapped monad.
This passes the last input value to the action, but doesn't advance a tick.
-}
once :: (Monad m) => (a -> m e) -> AutomatonExcept a b m e
once f = AutomatonExcept $ InitialExcept $ StreamOptimized.constM $ ExceptT $ ReaderT $ fmap Left <$> f

-- | Variant of 'once' without input.
once_ :: (Monad m) => m e -> AutomatonExcept 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)) -> AutomatonExcept a b m e
step f = try $ proc a -> do
n <- count -< ()
(b, e) <- arrM (lift . f) -< a
_ <- throwOn' -< (n > (1 :: Int), e)
returnA -< b

-- | Advances a single tick outputting the value, and then throws '()'.
step_ :: (Monad m) => b -> AutomatonExcept a b m ()
step_ b = step $ const $ return (b, ())

{- | Converts a list to an 'AutomatonExcept', which outputs an element of the list at
each step, throwing '()' when the list ends.
-}
listToAutomatonExcept :: (Monad m) => [b] -> AutomatonExcept a b m ()
listToAutomatonExcept = mapM_ step_

-- * Utilities definable in terms of 'AutomatonExcept'

{- | Extract an 'Automaton' from a monadic action.
Runs a monadic action that produces an 'Automaton' on the first step,
and then runs result for all further inputs (including the first one).
-}
performOnFirstSample :: (Monad m) => m (Automaton m a b) -> Automaton m a b
performOnFirstSample mAutomaton = safely $ do
automaton <- once_ mAutomaton
safe automaton

-- | 'reactimate's an 'AutomatonExcept' until it throws an exception.
reactimateExcept :: (Monad m) => AutomatonExcept () () m e -> m e
reactimateExcept ae = fmap (either id absurd) $ runExceptT $ reactimate $ runAutomatonExcept ae

-- | 'reactimate's an 'Automaton' until it returns 'True'.
reactimateB :: (Monad m) => Automaton m () Bool -> m ()
reactimateB ae = reactimateExcept $ try $ liftS ae >>> throwOn ()

{- | Run the first 'Automaton' until the second value in the output tuple is @Just c@,
then start the second automaton, discarding the current output @b@.
This is analogous to Yampa's
[@switch@](https://hackage.haskell.org/package/Yampa/docs/FRP-Yampa-Switches.html#v:switch),
with 'Maybe' instead of @Event@.
-}
switch :: (Monad m) => Automaton m a (b, Maybe c) -> (c -> Automaton m a b) -> Automaton m a b
switch automaton = catchS $ proc a -> do
(b, me) <- liftS automaton -< a
throwMaybe -< me
returnA -< b

{- | Run the first 'Automaton' until the second value in the output tuple is @Just c@,
then start the second automaton one step later (after the current @b@ has been output).
Analog to Yampa's
[@dswitch@](https://hackage.haskell.org/package/Yampa/docs/FRP-Yampa-Switches.html#v:dSwitch),
with 'Maybe' instead of @Event@.
-}
dSwitch :: (Monad m) => Automaton m a (b, Maybe c) -> (c -> Automaton m a b) -> Automaton m a b
dSwitch sf = catchS $ feedback Nothing $ proc (a, me) -> do
throwMaybe -< me
liftS sf -< a
11 changes: 11 additions & 0 deletions automaton/src/Data/Automaton/Trans/Except/Internal.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,11 @@
module Data.Automaton.Trans.Except.Internal where

-- transformers
import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
import Control.Monad.Trans.Reader

commuteReader :: ReaderT r (ExceptT e m) a -> ExceptT e (ReaderT r m) a
commuteReader = ExceptT . ReaderT . fmap runExceptT . runReaderT

commuteReaderBack :: ExceptT e (ReaderT r m) a -> ReaderT r (ExceptT e m) a
commuteReaderBack = ReaderT . fmap ExceptT . runReaderT . runExceptT
120 changes: 120 additions & 0 deletions automaton/src/Data/Automaton/Trans/Maybe.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,120 @@
-- | An 'Automaton' with 'Maybe' or 'MaybeT' in its monad stack can terminate execution at any step.
module Data.Automaton.Trans.Maybe (
module Data.Automaton.Trans.Maybe,
module Control.Monad.Trans.Maybe,
maybeToExceptS,
)
where

-- base
import Control.Arrow (arr, returnA, (>>>))

-- transformers
import Control.Monad.Trans.Maybe hiding (
liftCallCC,
liftCatch,
liftListen,
liftPass,
)

-- automaton
import Data.Automaton (Automaton, arrM, constM, hoistS, liftS)
import Data.Automaton.Trans.Except (
ExceptT,
exceptS,
listToAutomatonExcept,
maybeToExceptS,
reactimateExcept,
runAutomatonExcept,
runExceptT,
safe,
safely,
try,
)

-- * Throwing 'Nothing' as an exception ("exiting")

-- | Throw the exception immediately.
exit :: (Monad m) => Automaton (MaybeT m) a b
exit = constM $ MaybeT $ return Nothing

-- | Throw the exception when the condition becomes true on the input.
exitWhen :: (Monad m) => (a -> Bool) -> Automaton (MaybeT m) a a
exitWhen condition = proc a -> do
_ <- exitIf -< condition a
returnA -< a

-- | Exit when the incoming value is 'True'.
exitIf :: (Monad m) => Automaton (MaybeT m) Bool ()
exitIf = proc condition ->
if condition
then exit -< ()
else returnA -< ()

-- | @Just a@ is passed along, 'Nothing' causes the whole 'Automaton' to exit.
maybeExit :: (Monad m) => Automaton (MaybeT m) (Maybe a) a
maybeExit = inMaybeT

-- | Embed a 'Maybe' value in the 'MaybeT' layer. Identical to 'maybeExit'.
inMaybeT :: (Monad m) => Automaton (MaybeT m) (Maybe a) a
inMaybeT = arrM $ MaybeT . return

-- * Catching Maybe exceptions

-- | Run the first automaton until the second one produces 'True' from the output of the first.
untilMaybe :: (Monad m) => Automaton m a b -> Automaton m b Bool -> Automaton (MaybeT m) a b
untilMaybe automaton cond = proc a -> do
b <- liftS automaton -< a
c <- liftS cond -< b
inMaybeT -< if c then Nothing else Just b

{- | When an exception occurs in the first 'automaton', the second 'automaton' is executed
from there.
-}
catchMaybe ::
(Functor m, Monad m) =>
Automaton (MaybeT m) a b ->
Automaton m a b ->
Automaton m a b
catchMaybe automaton1 automaton2 = safely $ try (maybeToExceptS automaton1) >> safe automaton2

-- * Converting to and from 'MaybeT'

-- | Convert exceptions into `Nothing`, discarding the exception value.
exceptToMaybeS ::
(Functor m, Monad m) =>
Automaton (ExceptT e m) a b ->
Automaton (MaybeT m) a b
exceptToMaybeS =
hoistS $ MaybeT . fmap (either (const Nothing) Just) . runExceptT

{- | Converts a list to an 'Automaton' in 'MaybeT', which outputs an element of the
list at each step, throwing 'Nothing' when the list ends.
-}
listToMaybeS :: (Functor m, Monad m) => [b] -> Automaton (MaybeT m) a b
listToMaybeS = exceptToMaybeS . runAutomatonExcept . listToAutomatonExcept

-- * Running 'MaybeT'

{- | Remove the 'MaybeT' layer by outputting 'Nothing' when the exception occurs.
The current state is then tested again on the next input.
-}
runMaybeS :: (Functor m, Monad m) => Automaton (MaybeT m) a b -> Automaton m a (Maybe b)
runMaybeS automaton = exceptS (maybeToExceptS automaton) >>> arr eitherToMaybe
where
eitherToMaybe (Left ()) = Nothing
eitherToMaybe (Right b) = Just b

-- | 'reactimate's an 'Automaton' in the 'MaybeT' monad until it throws 'Nothing'.
reactimateMaybe ::
(Functor m, Monad m) =>
Automaton (MaybeT m) () () ->
m ()
reactimateMaybe automaton = reactimateExcept $ try $ maybeToExceptS automaton

{- | Run an 'Automaton' fed from a list, discarding results. Useful when one needs to
combine effects and streams (i.e., for testing purposes).
-}
embed_ :: (Functor m, Monad m) => Automaton m a () -> [a] -> m ()
embed_ automaton as = reactimateMaybe $ listToMaybeS as >>> liftS automaton
40 changes: 40 additions & 0 deletions automaton/src/Data/Automaton/Trans/RWS.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,40 @@
{- | This module combines the wrapping and running functions for the 'Reader',
'Writer' and 'State' monad layers in a single layer.
It is based on the _strict_ 'RWS' monad 'Control.Monad.Trans.RWS.Strict',
so when combining it with other modules such as @mtl@'s, the strict version
has to be included, i.e. 'Control.Monad.RWS.Strict' instead of
'Control.Monad.RWS' or 'Control.Monad.RWS.Lazy'.
-}
module Data.Automaton.Trans.RWS (
module Data.Automaton.Trans.RWS,
module Control.Monad.Trans.RWS.Strict,
)
where

-- transformers
import Control.Monad.Trans.RWS.Strict hiding (liftCallCC, liftCatch)

-- automaton
import Data.Automaton (Automaton, withAutomaton)
import Data.Stream.Result (Result (..))

-- * 'RWS' (Reader-Writer-State) monad

-- | Wrap an 'Automaton' with explicit state variables in 'RWST' monad transformer.
rwsS ::
(Functor m, Monad m, Monoid w) =>
Automaton m (r, s, a) (w, s, b) ->
Automaton (RWST r w s m) a b
rwsS = withAutomaton $ \f a -> RWST $ \r s ->
(\(Result c (w, s', b)) -> (Result c b, s', w))
<$> f (r, s, a)

-- | Run the 'RWST' layer by making the state variables explicit.
runRWSS ::
(Functor m, Monad m, Monoid w) =>
Automaton (RWST r w s m) a b ->
Automaton m (r, s, a) (w, s, b)
runRWSS = withAutomaton $ \f (r, s, a) ->
(\(Result c b, s', w) -> Result c (w, s', b))
<$> runRWST (f a) r s
94 changes: 94 additions & 0 deletions automaton/src/Data/Automaton/Trans/Random.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,94 @@
{- | An 'Automaton's in a monad supporting random number generation (i.e.
having the 'RandT' layer in its stack) can be run.
Running means supplying an initial random number generator,
where the update of the generator at every random number generation is already taken care of.
Under the hood, 'RandT' is basically just 'StateT', with the current random
number generator as mutable state.
-}
module Data.Automaton.Trans.Random (
runRandS,
evalRandS,
getRandomS,
getRandomsS,
getRandomRS,
getRandomRS_,
getRandomsRS,
getRandomsRS_,
)
where

-- base
import Control.Arrow (arr, (>>>))

-- MonadRandom
import Control.Monad.Random (
MonadRandom,
RandT,
Random,
RandomGen,
getRandom,
getRandomR,
getRandomRs,
getRandoms,
runRandT,
)

-- automaton
import Data.Automaton (Automaton, arrM, constM, hoistS)
import Data.Automaton.Trans.State (StateT (..), runStateS_)

-- Creating random values

-- | Create a stream of random values.
getRandomS :: (MonadRandom m, Random b) => Automaton m a b
getRandomS = constM getRandom

-- | Create a stream of lists of random values.
getRandomsS :: (MonadRandom m, Random b) => Automaton m a [b]
getRandomsS = constM getRandoms

-- | Create a stream of random values in a given fixed range.
getRandomRS :: (MonadRandom m, Random b) => (b, b) -> Automaton m a b
getRandomRS range = constM $ getRandomR range

{- | Create a stream of random values in a given range, where the range is
specified on every tick.
-}
getRandomRS_ :: (MonadRandom m, Random b) => Automaton m (b, b) b
getRandomRS_ = arrM getRandomR

-- | Create a stream of lists of random values in a given fixed range.
getRandomsRS :: (MonadRandom m, Random b) => (b, b) -> Automaton m a [b]
getRandomsRS range = constM $ getRandomRs range

{- | Create a stream of lists of random values in a given range, where the
range is specified on every tick.
-}
getRandomsRS_ :: (MonadRandom m, Random b) => Automaton m (b, b) [b]
getRandomsRS_ = arrM getRandomRs

-- * Running automata with random effects

{- | Run an 'Automaton' in the 'RandT' random number monad transformer by supplying
an initial random generator. Updates and outputs the generator every step.
-}
runRandS ::
(RandomGen g, Functor m, Monad m) =>
Automaton (RandT g m) a b ->
-- | The initial random number generator.
g ->
Automaton m a (g, b)
runRandS = runStateS_ . hoistS (StateT . runRandT)

{- | Evaluate an 'Automaton' in the 'RandT' transformer, i.e. extract possibly random
values by supplying an initial random generator. Updates the generator every
step but discards the generator.
-}
evalRandS ::
(RandomGen g, Functor m, Monad m) =>
Automaton (RandT g m) a b ->
g ->
Automaton m a b
evalRandS automaton g = runRandS automaton g >>> arr snd
43 changes: 43 additions & 0 deletions automaton/src/Data/Automaton/Trans/Reader.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,43 @@
{- | An 'Automaton' with a 'ReaderT' layer has an extra input.
This module converts between explicit automata inputs and implicit 'ReaderT' inputs.
-}
module Data.Automaton.Trans.Reader (
module Control.Monad.Trans.Reader,
readerS,
runReaderS,
runReaderS_,
)
where

-- base
import Control.Arrow (arr, (>>>))

-- transformers
import Control.Monad.Trans.Reader

-- automaton
import Data.Automaton (Automaton, withAutomaton)

-- * Reader 'Automaton' running and wrapping

{- | Convert an explicit 'Automaton' input into an environment in the 'ReaderT' monad transformer.
This is the opposite of 'runReaderS'.
-}
readerS :: (Monad m) => Automaton m (r, a) b -> Automaton (ReaderT r m) a b
readerS = withAutomaton $ \f a -> ReaderT $ \r -> f (r, a)
{-# INLINE readerS #-}

{- | Convert an implicit 'ReaderT' environment into an explicit 'Automaton' input.
This is the opposite of 'readerS'.
-}
runReaderS :: (Monad m) => Automaton (ReaderT r m) a b -> Automaton m (r, a) b
runReaderS = withAutomaton $ \f (r, a) -> runReaderT (f a) r
{-# INLINE runReaderS #-}

-- | Eliminate a 'ReaderT' layer by providing its environment statically.
runReaderS_ :: (Monad m) => Automaton (ReaderT s m) a b -> s -> Automaton m a b
runReaderS_ automaton s = arr (s,) >>> runReaderS automaton
{-# INLINE runReaderS_ #-}
70 changes: 70 additions & 0 deletions automaton/src/Data/Automaton/Trans/State.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,70 @@
{- | Handle a global 'StateT' layer in an 'Automaton'.
A global state can be hidden by an automaton by making it an internal state.
This module is based on the _strict_ state monad 'Control.Monad.Trans.State.Strict',
so when combining it with other modules such as @mtl@'s,
the strict version has to be included, i.e. 'Control.Monad.State.Strict'
instead of 'Control.Monad.State' or 'Control.Monad.State.Lazy'.
-}
module Data.Automaton.Trans.State (
module Control.Monad.Trans.State.Strict,
stateS,
runStateS,
runStateS_,
runStateS__,
)
where

-- base
import Control.Arrow (arr, (>>>))

-- transformers
import Control.Monad.Trans.State.Strict
import Data.Tuple (swap)

-- Internal imports

import Data.Automaton (Automaton, feedback, withAutomaton)
import Data.Stream.Result (Result (..))

-- * 'State' 'Automaton' running and wrapping

{- | Convert from explicit states to the 'StateT' monad transformer.
The original automaton is interpreted to take a state as input and return the updated state as output.
This is the opposite of 'runStateS'.
-}
stateS :: (Functor m, Monad m) => Automaton m (s, a) (s, b) -> Automaton (StateT s m) a b
stateS = withAutomaton $ \f a -> StateT $ \s ->
(\(Result s' (s, b)) -> (Result s' b, s))
<$> f (s, a)

{- | Make the state transition in 'StateT' explicit as 'Automaton' inputs and outputs.
This is the opposite of 'stateS'.
-}
runStateS :: (Functor m, Monad m) => Automaton (StateT s m) a b -> Automaton m (s, a) (s, b)
runStateS = withAutomaton $ \f (s, a) ->
(\(Result s' b, s) -> Result s' (s, b))
<$> runStateT (f a) s

{- | Convert global state to internal state of an 'Automaton'.
The current state is output on every step.
-}
runStateS_ ::
(Functor m, Monad m) =>
-- | An automaton with a global state effect
Automaton (StateT s m) a b ->
-- | The initial global state
s ->
Automaton m a (s, b)
runStateS_ automaton s =
feedback s $
arr swap >>> runStateS automaton >>> arr (\(s', b) -> ((s', b), s'))

-- | Like 'runStateS_', but don't output the current state.
runStateS__ :: (Functor m, Monad m) => Automaton (StateT s m) a b -> s -> Automaton m a b
runStateS__ automaton s = runStateS_ automaton s >>> arr snd
42 changes: 42 additions & 0 deletions automaton/src/Data/Automaton/Trans/Writer.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,42 @@
{- | An 'Automaton' with a 'WriterT' layer outputs an extra monoid value on every step.
It is based on the _strict_ writer monad 'Control.Monad.Trans.Writer.Strict',
so when combining it with other modules such as @mtl@'s,
the strict version has to be included, i.e. 'Control.Monad.Writer.Strict'
instead of 'Control.Monad.Writer' or 'Control.Monad.Writer.Lazy'.
-}
module Data.Automaton.Trans.Writer (
module Control.Monad.Trans.Writer.Strict,
writerS,
runWriterS,
)
where

-- transformers
import Control.Monad.Trans.Writer.Strict hiding (liftCallCC, liftCatch, pass)

-- automaton
import Data.Automaton (Automaton, withAutomaton)
import Data.Stream.Result (Result (Result))

{- | Convert an extra log output into a 'WriterT' effect.
This is the opposite of 'runWriterS'.
-}
writerS ::
(Functor m, Monad m, Monoid w) =>
Automaton m a (w, b) ->
Automaton (WriterT w m) a b
writerS = withAutomaton $ \f a -> WriterT $ (\(Result s (w, b)) -> (Result s b, w)) <$> f a

{- | Convert a 'WriterT' effect into an extra log output.
This is the opposite of 'writerS'.
-}
runWriterS ::
(Functor m, Monad m) =>
Automaton (WriterT w m) a b ->
Automaton m a (w, b)
runWriterS = withAutomaton $ \f a ->
(\(Result s b, w) -> Result s (w, b))
<$> runWriterT (f a)
417 changes: 417 additions & 0 deletions automaton/src/Data/Stream.hs

Large diffs are not rendered by default.

63 changes: 63 additions & 0 deletions automaton/src/Data/Stream/Except.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,63 @@
module Data.Stream.Except where

-- base
import Control.Monad (ap)
import Data.Void

-- transformers
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except

-- mmorph
import Control.Monad.Morph (MFunctor, hoist)

-- selective
import Control.Selective

-- automaton
import Data.Stream.Final (Final (..))
import Data.Stream.Final.Except
import Data.Stream.Optimized (OptimizedStreamT, applyExcept, constM, selectExcept)
import Data.Stream.Optimized qualified as StreamOptimized

data StreamExcept a m e
= -- | When using '>>=', this encoding needs to be used.
FinalExcept (Final (ExceptT e m) a)
| -- | This is usually the faster encoding, as it can be optimized by GHC.
InitialExcept (OptimizedStreamT (ExceptT e m) a)

toFinal :: (Functor m) => StreamExcept a m e -> Final (ExceptT e m) a
toFinal (FinalExcept final) = final
toFinal (InitialExcept initial) = StreamOptimized.toFinal initial

runStreamExcept :: StreamExcept a m e -> OptimizedStreamT (ExceptT e m) a
runStreamExcept (FinalExcept final) = StreamOptimized.fromFinal final
runStreamExcept (InitialExcept initial) = initial

instance (Monad m) => Functor (StreamExcept a m) where
fmap f (FinalExcept fe) = FinalExcept $ hoist (withExceptT f) fe
fmap f (InitialExcept ae) = InitialExcept $ hoist (withExceptT f) ae

instance (Monad m) => Applicative (StreamExcept a m) where
pure = InitialExcept . constM . throwE
InitialExcept f <*> InitialExcept a = InitialExcept $ applyExcept f a
f <*> a = ap f a

instance (Monad m) => Selective (StreamExcept a m) where
select (InitialExcept e) (InitialExcept f) = InitialExcept $ selectExcept e f
select e f = selectM e f

-- | 'return'/'pure' throw exceptions, '(>>=)' uses the last thrown exception as input for an exception handler.
instance (Monad m) => Monad (StreamExcept a m) where
(>>) = (*>)
ae >>= f = FinalExcept $ handleExceptT (toFinal ae) (toFinal . f)

instance MonadTrans (StreamExcept a) where
lift = InitialExcept . constM . ExceptT . fmap Left

instance MFunctor (StreamExcept a) where
hoist morph (InitialExcept automaton) = InitialExcept $ hoist (mapExceptT morph) automaton
hoist morph (FinalExcept final) = FinalExcept $ hoist (mapExceptT morph) final

safely :: (Monad m) => StreamExcept a m Void -> OptimizedStreamT m a
safely = hoist (fmap (either absurd id) . runExceptT) . runStreamExcept
63 changes: 63 additions & 0 deletions automaton/src/Data/Stream/Final.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,63 @@
module Data.Stream.Final where

-- base
import Control.Applicative (Alternative (..))

-- mmorph
import Control.Monad.Morph (MFunctor (..))

-- automaton
import Data.Stream (StreamT (..), stepStream)
import Data.Stream.Result

{- | A stream transformer in final encoding.
One step of the stream transformer performs a monadic action and results in an output and a new stream.
-}
newtype Final m a = Final {getFinal :: m (Result (Final m a) a)}

{- | Translate an initially encoded stream into a finally encoded one.
This is usually a performance penalty.
-}
toFinal :: (Functor m) => StreamT m a -> Final m a
toFinal automaton = Final $ mapResultState toFinal <$> stepStream automaton
{-# INLINE toFinal #-}

{- | Translate a finally encoded stream into an initially encoded one.
The internal state is the stream itself.
-}
fromFinal :: Final m a -> StreamT m a
fromFinal final =
StreamT
{ state = final
, step = getFinal
}
{-# INLINE fromFinal #-}

instance MFunctor Final where
hoist morph = go
where
go Final {getFinal} = Final $ morph $ mapResultState go <$> getFinal

instance (Functor m) => Functor (Final m) where
fmap f Final {getFinal} = Final $ fmap f . mapResultState (fmap f) <$> getFinal

instance (Applicative m) => Applicative (Final m) where
pure a = go
where
go = Final $! pure $! Result go a

Final mf <*> Final ma = Final $! (\(Result cf f) (Result ca a) -> Result (cf <*> ca) $! f a) <$> mf <*> ma

-- | Constantly perform the same effect, without remembering a state.
constM :: (Functor m) => m a -> Final m a
constM ma = go
where
go = Final $ Result go <$> ma

instance (Alternative m) => Alternative (Final m) where
empty = constM empty

Final ma1 <|> Final ma2 = Final $ ma1 <|> ma2
18 changes: 18 additions & 0 deletions automaton/src/Data/Stream/Final/Except.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,18 @@
module Data.Stream.Final.Except where

-- transformers
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except (ExceptT, runExceptT)

-- automaton
import Data.Stream.Final (Final (..))
import Data.Stream.Result (mapResultState)

handleExceptT :: (Monad m) => Final (ExceptT e1 m) b -> (e1 -> Final (ExceptT e2 m) b) -> Final (ExceptT e2 m) b
handleExceptT final handler = go final
where
go final = Final $ do
resultOrException <- lift $ runExceptT $ getFinal final
case resultOrException of
Right result -> return $! mapResultState go result
Left e -> getFinal $ handler e
23 changes: 23 additions & 0 deletions automaton/src/Data/Stream/Internal.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,23 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StrictData #-}

-- | Helper functions and types for Data.Stream. You will typically not need them.
module Data.Stream.Internal where

-- | A strict tuple type
data JointState a b = JointState a b

-- | Internal state of the result of 'Alternative' constructions
data Alternatively stateL stateR = Undecided | DecideL stateL | DecideR stateR

-- | Internal state of 'many' and 'some'
data Many state x = NotStarted | Ongoing x state | Finished

-- newtype makes GHC loop on using fixStream
{- HLINT ignore Fix "Use newtype instead of data" -}
data Fix t = Fix {getFix :: ~(t (Fix t))}

fixState :: (forall s. s -> t s) -> Fix t
fixState transformState = go
where
go = Fix $ transformState go
220 changes: 220 additions & 0 deletions automaton/src/Data/Stream/Optimized.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,220 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

{- | An optimization layer on 'Data.Stream'.
Since both variants are semantically the same, not the full API of 'Data.Stream' is replicated here.
-}
module Data.Stream.Optimized where

-- base
import Control.Applicative (Alternative (..), liftA2)
import Data.Monoid (Ap (..))

-- transformers
import Control.Monad.Trans.Except (ExceptT)

-- selective
import Control.Selective (Selective (select))

-- simple-affine-space
import Data.VectorSpace

-- mmorph
import Control.Monad.Morph

-- automaton

import Data.Align (Align, Semialign)
import Data.Semialign (Align (..), Semialign (..))
import Data.Stream hiding (hoist')
import Data.Stream qualified as StreamT
import Data.Stream.Final (Final (..))
import Data.Stream.Final qualified as Final (fromFinal, toFinal)
import Data.Stream.Result

{- | An optimized version of 'StreamT' which has an extra constructor for stateless streams.
In most cases, using 'OptimizedStreamT' is preferable over 'StreamT',
because building up bigger programs with 'StreamT' will build up big accumulations of trivial states.
The API of 'OptimizedStreamT' only keeps the nontrivial parts of the state.
Semantically, both types are the same.
-}
data OptimizedStreamT m a
= -- | Embed a 'StreamT'. Take care only to use this constructor on streams with nontrivial state.
Stateful (StreamT m a)
| -- | A stateless stream is simply an action in a monad which is performed repetitively.
Stateless (m a)
deriving (Functor)

{- | Remove the optimization layer.
For stateful streams, this is just the identity.
A stateless stream is encoded as a stream with state '()'.
-}
toStreamT :: (Functor m) => OptimizedStreamT m b -> StreamT m b
toStreamT (Stateful stream) = stream
toStreamT (Stateless m) = StreamT {state = (), step = const $ Result () <$> m}
{-# INLINE toStreamT #-}

-- | Only builds up tuples of states if both streams are stateful.
instance (Applicative m) => Applicative (OptimizedStreamT m) where
pure = Stateless . pure
{-# INLINE pure #-}

Stateful stream1 <*> Stateful stream2 = Stateful $ stream1 <*> stream2
Stateless m <*> Stateful (StreamT state0 step) = Stateful $ StreamT state0 $ \state -> fmap . ($) <$> m <*> step state
Stateful (StreamT state0 step) <*> Stateless m = Stateful $ StreamT state0 $ \state -> flip (fmap . flip ($)) <$> step state <*> m
Stateless mf <*> Stateless ma = Stateless $ mf <*> ma
{-# INLINE (<*>) #-}

deriving via Ap (OptimizedStreamT m) a instance (Applicative m, Num a) => Num (OptimizedStreamT m a)

instance (Applicative m, Fractional a) => Fractional (OptimizedStreamT m a) where
fromRational = pure . fromRational
recip = fmap recip

instance (Applicative m, Floating a) => Floating (OptimizedStreamT m a) where
pi = pure pi
exp = fmap exp
log = fmap log
sin = fmap sin
cos = fmap cos
asin = fmap asin
acos = fmap acos
atan = fmap atan
sinh = fmap sinh
cosh = fmap cosh
asinh = fmap asinh
acosh = fmap acosh
atanh = fmap atanh

instance (VectorSpace v s, Eq s, Floating s, Applicative m) => VectorSpace (OptimizedStreamT m v) (OptimizedStreamT m s) where
zeroVector = pure zeroVector
(*^) = liftA2 (*^)
(^+^) = liftA2 (^+^)
dot = liftA2 dot
normalize = fmap normalize

instance (Alternative m) => Alternative (OptimizedStreamT m) where
empty = Stateless empty
{-# INLINE empty #-}

-- The semantics prescribe that we save the state which stream was selected.
stream1 <|> stream2 = Stateful $ toStreamT stream1 <|> toStreamT stream2
{-# INLINE (<|>) #-}

many stream = Stateful $ many $ toStreamT stream
{-# INLINE many #-}

some stream = Stateful $ some $ toStreamT stream
{-# INLINE some #-}

instance (Selective m) => Selective (OptimizedStreamT m) where
select (Stateless mab) (Stateless f) = Stateless $ select mab f
select stream1 stream2 = Stateful $ select (toStreamT stream1) (toStreamT stream2)

instance (Semialign m) => Semialign (OptimizedStreamT m) where
align (Stateless ma) (Stateless mb) = Stateless $ align ma mb
align stream1 stream2 = Stateful $ align (toStreamT stream1) (toStreamT stream2)

instance (Align m) => Align (OptimizedStreamT m) where
nil = Stateless nil

instance MFunctor OptimizedStreamT where
hoist = hoist'
{-# INLINE hoist #-}

-- | Like 'hoist', but without the @'Monad' m2@ constraint.
hoist' :: (forall x. m1 x -> m2 x) -> OptimizedStreamT m1 a -> OptimizedStreamT m2 a
hoist' f (Stateful stream) = Stateful $ StreamT.hoist' f stream
hoist' f (Stateless m) = Stateless $ f m
{-# INLINE hoist' #-}

-- | Change the output type and effect of a stream without changing its state type.
mapOptimizedStreamT :: (Functor m, Functor n) => (forall s. m (Result s a) -> n (Result s b)) -> OptimizedStreamT m a -> OptimizedStreamT n b
mapOptimizedStreamT f (Stateful stream) = Stateful $ withStreamT f stream
mapOptimizedStreamT f (Stateless m) = Stateless $ fmap output $ f $ fmap (Result ()) m
{-# INLINE mapOptimizedStreamT #-}

{- | Map a monad-independent morphism of streams to optimized streams.
In contrast to 'handleOptimized', the stream morphism must be independent of the monad.
-}
withOptimized :: (Monad n) => (forall m. (Monad m) => StreamT m a -> StreamT m b) -> OptimizedStreamT n a -> OptimizedStreamT n b
withOptimized f stream = Stateful $ f $ toStreamT stream

{- | Map a morphism of streams to optimized streams.
In contrast to 'withOptimized', the monad type is allowed to change.
-}
handleOptimized :: (Functor m) => (StreamT m a -> StreamT n b) -> OptimizedStreamT m a -> OptimizedStreamT n b
handleOptimized f stream = Stateful $ f $ toStreamT stream

{- | Run a stream with trivial output.
See 'Data.Stream.reactimate'.
-}
reactimate :: (Monad m) => OptimizedStreamT m () -> m void
reactimate (Stateful !stream) = StreamT.reactimate stream
reactimate (Stateless !f) = go
where
go = f *> go
{-# INLINE reactimate #-}

{- | A stateless stream.
This function is typically preferable over 'Data.Stream.constM',
since the optimized version doesn't create a state type.
-}
constM :: m a -> OptimizedStreamT m a
constM = Stateless

-- | Perform one step of a stream, resulting in an updated stream and an output value.
stepOptimizedStream :: (Functor m) => OptimizedStreamT m a -> m (Result (OptimizedStreamT m a) a)
stepOptimizedStream (Stateful stream) = mapResultState Stateful <$> stepStream stream
stepOptimizedStream oa@(Stateless m) = Result oa <$> m
{-# INLINE stepOptimizedStream #-}

{- | Translate to the final encoding of streams.
This will typically be a performance penalty.
-}
toFinal :: (Functor m) => OptimizedStreamT m a -> Final m a
toFinal (Stateful stream) = Final.toFinal stream
toFinal (Stateless f) = go
where
go = Final $ Result go <$> f
{-# INLINE toFinal #-}

{- | Translate a stream from final encoding to stateful, initial encoding.
The internal state is the stream itself.
-}
fromFinal :: Final m a -> OptimizedStreamT m a
fromFinal = Stateful . Final.fromFinal
{-# INLINE fromFinal #-}

-- | See 'Data.Stream.concatS'.
concatS :: (Monad m) => OptimizedStreamT m [a] -> OptimizedStreamT m a
concatS stream = Stateful $ StreamT.concatS $ toStreamT stream
{-# INLINE concatS #-}

-- | See 'Data.Stream.exceptS'.
exceptS :: (Monad m) => OptimizedStreamT (ExceptT e m) b -> OptimizedStreamT m (Either e b)
exceptS stream = Stateful $ StreamT.exceptS $ toStreamT stream
{-# INLINE exceptS #-}

-- | See 'Data.Stream.applyExcept'.
applyExcept :: (Monad m) => OptimizedStreamT (ExceptT (e1 -> e2) m) a -> OptimizedStreamT (ExceptT e1 m) a -> OptimizedStreamT (ExceptT e2 m) a
applyExcept streamF streamA = Stateful $ StreamT.applyExcept (toStreamT streamF) (toStreamT streamA)
{-# INLINE applyExcept #-}

-- | See 'Data.Stream.selectExcept'.
selectExcept :: (Monad m) => OptimizedStreamT (ExceptT (Either e1 e2) m) a -> OptimizedStreamT (ExceptT (e1 -> e2) m) a -> OptimizedStreamT (ExceptT e2 m) a
selectExcept streamE streamF = Stateful $ StreamT.selectExcept (toStreamT streamE) (toStreamT streamF)
{-# INLINE selectExcept #-}
44 changes: 44 additions & 0 deletions automaton/src/Data/Stream/Result.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,44 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE StrictData #-}

module Data.Stream.Result where

-- base
import Data.Bifunctor (Bifunctor (..))

-- automaton
import Data.Stream.Internal

{- | A tuple that is strict in its first argument.
This type is used in streams and automata to encode the result of a state transition.
The new state should always be strict to avoid space leaks.
-}
data Result s a = Result {resultState :: s, output :: ~a}
deriving (Functor)

instance Bifunctor Result where
second = fmap
first = mapResultState

-- | Apply a function to the state of a 'Result'.
mapResultState :: (s1 -> s2) -> Result s1 a -> Result s2 a
mapResultState f Result {resultState, output} = Result {resultState = f resultState, output}
{-# INLINE mapResultState #-}

-- | Analogous to 'Applicative''s '(<*>)'.
apResult :: Result s1 (a -> b) -> Result s2 a -> Result (JointState s1 s2) b
apResult (Result resultStateA outputF) (Result resultStateB outputA) = Result (JointState resultStateA resultStateB) $ outputF outputA
{-# INLINE apResult #-}

-- | A state transformer with 'Result' instead of a standard tuple as its result.
newtype ResultStateT s m a = ResultStateT {getResultStateT :: s -> m (Result s a)}
deriving (Functor)

instance (Monad m) => Applicative (ResultStateT s m) where
pure output = ResultStateT (\resultState -> pure Result {resultState, output})

ResultStateT mf <*> ResultStateT ma = ResultStateT $ \s -> do
Result s' f <- mf s
Result s'' a <- ma s'
pure (Result s'' (f a))
91 changes: 91 additions & 0 deletions automaton/test/Automaton.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,91 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Automaton where

-- base
import Control.Applicative (Alternative (..))
import Control.Arrow
import Data.Functor.Identity (runIdentity)
import Data.List (uncons)
import Data.Maybe (maybeToList)

-- transformers
import Control.Monad.State.Strict

-- selective
import Control.Selective ((<*?))

-- tasty
import Test.Tasty (testGroup)

-- tasty-quickcheck
import Test.Tasty.QuickCheck

-- tasty-hunit
import Test.Tasty.HUnit (testCase, (@?=))

-- automaton
import Automaton.Except
import Data.Automaton
import Data.Automaton.Final
import Data.Automaton.Trans.Maybe

tests =
testGroup
"Automaton"
[ testGroup
"Alternative"
[ testGroup
"<|>"
[ testProperty "has same semantics as final" $
\(input :: [(Maybe Int, Maybe Int)]) ->
embed ((arr fst >>> inMaybe) <|> (arr snd >>> inMaybe)) input
=== embed (fromFinal $ (arr fst >>> toFinal inMaybe) <|> (arr snd >>> toFinal inMaybe)) input
]
, testGroup
"some"
[ testCase "Maybe" $ embed (some $ arrM id) [Nothing] @?= (Nothing :: Maybe [[()]])
, testCase "Parser" $ runParser (embed (some $ constM aChar) [(), ()]) "hi" @?= [(["h", "i"], "")]
]
, testGroup
"many"
[ testCase "Maybe" $ embed (many $ arrM id) [Nothing] @?= (Just [[]] :: Maybe [[()]])
, testCase "Parser" $ runParser (many (char 'h')) "hi" @?= [("h", "i"), ("", "hi")]
]
]
, testGroup
"parallely"
[ testCase "Outputs separate sums" $ runIdentity (embed (parallely sumN) [[], [], [1, 2], [10, 20], [100], [], [1000, 200]]) @?= [[], [], [1, 2], [11, 22], [111], [], [1111, 222]]
]
, testGroup
"Selective"
[ testCase "selects second Automaton conditionally" $
runIdentity (embed (right sumN <*? arr (const (* 2))) [Right 1, Right 2, Left 10, Right 3, Left 20]) @?= [1, 3, 20, 6, 40]
]
, testCase "count" $ runIdentity (embed count [(), (), ()]) @?= [1, 2, 3]
, testCase "delay" $ runIdentity (embed (count >>> delay 0) [(), (), ()]) @?= [0, 1, 2]
, testCase "sumS" $ runIdentity (embed (arr (const (1 :: Float)) >>> sumS) [(), (), ()]) @?= [1, 2, 3]
, testCase "sumN" $ runIdentity (embed (arr (const (1 :: Integer)) >>> sumN) [(), (), ()]) @?= [1, 2, 3]
, Automaton.Except.tests
]

inMaybe :: Automaton Maybe (Maybe a) a
inMaybe = hoistS (runIdentity . runMaybeT) inMaybeT

-- * Parser helper type to test many & some

newtype Parser a = Parser {getParser :: StateT String [] a}
deriving (Functor, Applicative, Monad, Alternative)

runParser :: Parser a -> String -> [(a, String)]
runParser = runStateT . getParser

aChar :: Parser Char
aChar = Parser $ StateT $ maybeToList . uncons

char :: Char -> Parser Char
char c = do
c' <- aChar
guard $ c == c'
return c
16 changes: 16 additions & 0 deletions automaton/test/Automaton/Except.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,16 @@
module Automaton.Except where

-- base
import Control.Monad.Identity (Identity (runIdentity))

-- tasty
import Test.Tasty (testGroup)

-- tasty-hunit
import Test.Tasty.HUnit (testCase, (@?=))

-- rhine
import Data.Automaton (embed)
import Data.Automaton.Trans.Except (safe, safely, step)

tests = testGroup "Except" [testCase "step" $ runIdentity (embed (safely $ step (\a -> return (a, ())) >> safe 0) [1, 1, 1]) @?= [1, 0, 0]]
16 changes: 16 additions & 0 deletions automaton/test/Main.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,16 @@
module Main where

-- tasty
import Test.Tasty

-- automaton
import Automaton
import Stream

main =
defaultMain $
testGroup
"Main"
[ Automaton.tests
, Stream.tests
]
31 changes: 31 additions & 0 deletions automaton/test/Stream.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,31 @@
module Stream where

-- base
import Control.Monad.Identity (Identity (..))

-- selective
import Control.Selective

-- tasty
import Test.Tasty (testGroup)

-- tasty-hunit
import Test.Tasty.HUnit (testCase, (@?=))

-- automaton
import Automaton
import Data.Stream (streamToList, unfold)
import Data.Stream.Result

tests =
testGroup
"Stream"
[ Automaton.tests
, testGroup
"Selective"
[ testCase "Selects second stream based on first stream" $
let automaton1 = unfold 0 (\n -> Result (n + 1) (if even n then Right n else Left n))
automaton2 = pure (* 10)
in take 10 (runIdentity (streamToList (automaton1 <*? automaton2))) @?= [0, 10, 2, 30, 4, 50, 6, 70, 8, 90]
]
]
2 changes: 1 addition & 1 deletion flake.nix
Original file line number Diff line number Diff line change
@@ -45,6 +45,6 @@ outputs = { self, nixpkgs, flake-utils, haskell-flake-utils, flake-compat, ... }
};

name = "rhine";
packageNames = [ "rhine-gloss" "rhine-terminal" "rhine-examples" "rhine-bayes" ];
packageNames = [ "automaton" "rhine-gloss" "rhine-terminal" "rhine-examples" "rhine-bayes" ];
};
}
46 changes: 18 additions & 28 deletions rhine-bayes/app/Main.hs
Original file line number Diff line number Diff line change
@@ -39,8 +39,8 @@ import Control.Monad.Bayes.Class hiding (posterior, prior)
import Control.Monad.Bayes.Population hiding (hoist)
import Control.Monad.Bayes.Sampler.Strict

-- dunai
import Control.Monad.Trans.MSF.Except
-- automaton
import Data.Automaton.Trans.Except

-- rhine
import FRP.Rhine
@@ -171,7 +171,7 @@ emptyResult =

-- | The number of particles used in the filter. Change according to available computing power.
nParticles :: Int
nParticles = 100
nParticles = 400

-- * Visualization

@@ -239,21 +239,11 @@ drawParticleTemperature = proc (temperature, probability) -> do
arrMCl paintIO -< toThermometer $ translate 0 (double2Float temperature * thermometerScale) $ color (withAlpha (double2Float $ exp $ 0.2 * ln probability) white) $ rectangleSolid thermometerWidth 2

drawParticles :: BehaviourF App td [(Pos, Log Double)] ()
drawParticles = proc particlesPosition -> do
case particlesPosition of
[] -> returnA -< ()
p : ps -> do
drawParticle -< p
drawParticles -< ps
drawParticles = traverseS_ drawParticle

-- FIXME abstract using a library
drawParticlesTemperature :: BehaviourF App td [(Temperature, Log Double)] ()
drawParticlesTemperature = proc particlesPosition -> do
case particlesPosition of
[] -> returnA -< ()
p : ps -> do
drawParticleTemperature -< p
drawParticlesTemperature -< ps
drawParticlesTemperature = traverseS_ drawParticleTemperature

glossSettings :: GlossSettings
glossSettings =
@@ -398,19 +388,19 @@ userTemperature = tagS >>> arr (selector >>> fmap Product) >>> mappendS >>> arr
-}
inference :: Rhine (GlossConcT IO) (LiftClock IO GlossConcT Busy) (Temperature, (Sensor, Pos)) Result
inference = hoistClSF sampleIOGloss inferenceBehaviour @@ liftClock Busy
where
inferenceBehaviour :: (MonadDistribution m, Diff td ~ Double, MonadIO m) => BehaviourF m td (Temperature, (Sensor, Pos)) Result
inferenceBehaviour = proc (temperature, (measured, latent)) -> do
positionsAndTemperatures <- runPopulationCl nParticles resampleSystematic posteriorTemperatureProcess -< measured
returnA
-<
Result
{ temperature
, measured
, latent
, particlesPosition = first snd <$> positionsAndTemperatures
, particlesTemperature = first fst <$> positionsAndTemperatures
}

inferenceBehaviour :: (MonadDistribution m, Diff td ~ Double, MonadIO m) => BehaviourF m td (Temperature, (Sensor, Pos)) Result
inferenceBehaviour = proc (temperature, (measured, latent)) -> do
positionsAndTemperatures <- runPopulationCl nParticles resampleSystematic posteriorTemperatureProcess -< measured
returnA
-<
Result
{ temperature
, measured
, latent
, particlesPosition = first snd <$> positionsAndTemperatures
, particlesTemperature = first fst <$> positionsAndTemperatures
}

-- | Visualize the current 'Result' at a rate controlled by the @gloss@ backend, usually 30 FPS.
visualisationRhine :: Rhine (GlossConcT IO) (GlossClockUTC GlossSimClockIO) Result ()
7 changes: 4 additions & 3 deletions rhine-bayes/rhine-bayes.cabal
Original file line number Diff line number Diff line change
@@ -30,11 +30,12 @@ source-repository this

library
exposed-modules: FRP.Rhine.Bayes
other-modules: Data.MonadicStreamFunction.Bayes
other-modules: Data.Automaton.Bayes
build-depends:
automaton,
base >=4.11 && <4.18,
dunai ^>=0.12.2,
log-domain >=0.12,
mmorph ^>=1.2,
monad-bayes ^>=1.2,
rhine ==1.2,
transformers >=0.5
@@ -64,8 +65,8 @@ executable rhine-bayes-gloss
main-is: Main.hs
hs-source-dirs: app
build-depends:
automaton,
base >=4.11 && <4.18,
dunai,
log-domain,
mmorph,
monad-bayes,
67 changes: 67 additions & 0 deletions rhine-bayes/src/Data/Automaton/Bayes.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,67 @@
{-# LANGUAGE NamedFieldPuns #-}

module Data.Automaton.Bayes where

-- base
import Control.Arrow

-- transformers
import Control.Monad.Trans.Reader (ReaderT (..))

-- log-domain
import Numeric.Log hiding (sum)

-- monad-bayes
import Control.Monad.Bayes.Population (PopulationT (..), fromWeightedList, runPopulationT)

-- mmorph
import Control.Monad.Morph (hoist)

-- automaton
import Data.Automaton (Automaton (..), handleAutomaton)
import Data.Stream (StreamT (..))
import Data.Stream.Result (Result (..))

-- | Run the Sequential Monte Carlo algorithm continuously on an 'Automaton'
runPopulationS ::
forall m a b.
(Monad m) =>
-- | Number of particles
Int ->
-- | Resampler
(forall x. PopulationT m x -> PopulationT m x) ->
Automaton (PopulationT m) a b ->
-- FIXME Why not Automaton m a (PopulationT b)
Automaton m a [(b, Log Double)]
runPopulationS nParticles resampler =
handleAutomaton
( runPopulationStream
(commuteReaderPopulation . hoist resampler . commuteReaderPopulationBack)
. hoist commuteReaderPopulation
)
where
commuteReaderPopulation :: forall m r a. (Monad m) => ReaderT r (PopulationT m) a -> PopulationT (ReaderT r m) a
commuteReaderPopulation = fromWeightedList . ReaderT . fmap runPopulationT . runReaderT

commuteReaderPopulationBack :: forall m r a. (Monad m) => PopulationT (ReaderT r m) a -> ReaderT r (PopulationT m) a
commuteReaderPopulationBack = ReaderT . fmap fromWeightedList . runReaderT . runPopulationT

runPopulationStream ::
forall m b.
(Monad m) =>
(forall x. PopulationT m x -> PopulationT m x) ->
StreamT (PopulationT m) b ->
StreamT m [(b, Log Double)]
runPopulationStream resampler StreamT {step, state} =
StreamT
{ state = replicate nParticles (state, 1 / fromIntegral nParticles)
, step = \states -> do
resultsAndProbabilities <- runPopulationT $ normalize $ resampler $ do
state <- fromWeightedList $ pure states
step state
return $! Result (first resultState <$> resultsAndProbabilities) (first output <$> resultsAndProbabilities)
}

-- FIXME see PR re-adding this to monad-bayes
normalize :: (Monad m) => PopulationT m a -> PopulationT m a
normalize = fromWeightedList . fmap (\particles -> second (/ (sum $ snd <$> particles)) <$> particles) . runPopulationT
53 changes: 0 additions & 53 deletions rhine-bayes/src/Data/MonadicStreamFunction/Bayes.hs

This file was deleted.

14 changes: 7 additions & 7 deletions rhine-bayes/src/FRP/Rhine/Bayes.hs
Original file line number Diff line number Diff line change
@@ -10,11 +10,11 @@ import Numeric.Log hiding (sum)
import Control.Monad.Bayes.Class
import Control.Monad.Bayes.Population

-- dunai
import qualified Control.Monad.Trans.MSF.Reader as DunaiReader
-- automaton
import qualified Data.Automaton.Trans.Reader as AutomatonReader

-- dunai-bayes
import qualified Data.MonadicStreamFunction.Bayes as DunaiBayes
-- rhine-bayes
import qualified Data.Automaton.Bayes as AutomatonBayes

-- rhine
import FRP.Rhine
@@ -24,18 +24,18 @@ import FRP.Rhine
-- | Run the Sequential Monte Carlo algorithm continuously on a 'ClSF'.
runPopulationCl ::
forall m cl a b.
(Monad m) =>
(Monad m, MonadDistribution m) =>
-- | Number of particles
Int ->
-- | Resampler (see 'Control.Monad.Bayes.PopulationT' for some standard choices)
(forall x. PopulationT m x -> PopulationT m x) ->
(forall x m. (MonadDistribution m) => PopulationT m x -> PopulationT m x) ->
-- | A signal function modelling the stochastic process on which to perform inference.
-- @a@ represents observations upon which the model should condition, using e.g. 'score'.
-- It can also additionally contain hyperparameters.
-- @b@ is the type of estimated current state.
ClSF (PopulationT m) cl a b ->
ClSF m cl a [(b, Log Double)]
runPopulationCl nParticles resampler = DunaiReader.readerS . DunaiBayes.runPopulationS nParticles resampler . DunaiReader.runReaderS
runPopulationCl nParticles resampler = AutomatonReader.readerS . AutomatonBayes.runPopulationS nParticles resampler . AutomatonReader.runReaderS

-- * Short standard library of stochastic processes

2 changes: 1 addition & 1 deletion rhine-examples/src/Ball.hs
Original file line number Diff line number Diff line change
@@ -56,7 +56,7 @@ falling v0 = proc _ -> do
throwMaybe -< guard $ height < 0
returnA -< pos

ballModes :: ClSFExcept IO SimClock (Maybe BallVel) Ball void
ballModes :: ClSFExcept SimClock (Maybe BallVel) Ball IO void
ballModes = do
v0 <- try waiting
once_ $ putStrLn "Catch!"
1 change: 1 addition & 0 deletions rhine-gloss/Main.hs
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}

-- | Example application for the @gloss@ wrapper.
3 changes: 2 additions & 1 deletion rhine-gloss/rhine-gloss.cabal
Original file line number Diff line number Diff line change
@@ -37,8 +37,8 @@ library
FRP.Rhine.Gloss.Pure.Combined

build-depends:
automaton,
base >=4.14 && <4.18,
dunai ^>=0.12.2,
gloss >=1.12,
mmorph >=1.1,
monad-schedule >=0.1,
@@ -61,6 +61,7 @@ executable rhine-gloss-gears
rhine-gloss

default-language: Haskell2010
default-extensions: TypeOperators
ghc-options:
-W
-threaded
1 change: 0 additions & 1 deletion rhine-gloss/src/FRP/Rhine/Gloss.hs
Original file line number Diff line number Diff line change
@@ -17,7 +17,6 @@ import Control.Arrow as X
import FRP.Rhine as X

-- rhine-gloss

import FRP.Rhine.Gloss.Common as X
import FRP.Rhine.Gloss.IO as X
import FRP.Rhine.Gloss.Pure as X
24 changes: 12 additions & 12 deletions rhine-gloss/src/FRP/Rhine/Gloss/Pure.hs
Original file line number Diff line number Diff line change
@@ -30,16 +30,16 @@ import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Writer.Strict

-- dunai
import Control.Monad.Trans.MSF (performOnFirstSample)
import qualified Control.Monad.Trans.MSF.Reader as MSFReader
import qualified Control.Monad.Trans.MSF.Writer as MSFWriter
import Data.MonadicStreamFunction.InternalCore

-- monad-schedule
import Control.Monad.Schedule.Class
import Control.Monad.Schedule.Yield

-- automaton
import Data.Automaton.Trans.Except (performOnFirstSample)
import qualified Data.Automaton.Trans.Reader as AutomatonReader
import qualified Data.Automaton.Trans.Writer as AutomatonWriter
import Data.Stream.Result (Result (..))

-- rhine
import FRP.Rhine

@@ -114,7 +114,7 @@ flowGlossClSF ::
IO ()
flowGlossClSF settings clsf = flowGloss settings $ clsf >-> arrMCl paintAll @@ GlossClock

type WorldMSF = MSF Identity ((Float, Maybe Event), ()) (Picture, Maybe ())
type WorldAutomaton = Automaton Identity ((Float, Maybe Event), ()) (Picture, Maybe ())

-- | The main function that will start the @gloss@ backend and run the 'Rhine'
flowGloss ::
@@ -123,12 +123,12 @@ flowGloss ::
Rhine GlossM cl () () ->
IO ()
flowGloss GlossSettings {..} rhine =
play display backgroundColor stepsPerSecond (worldMSF, Blank) getPic handleEvent simStep
play display backgroundColor stepsPerSecond (worldAutomaton, Blank) getPic handleEvent simStep
where
worldMSF :: WorldMSF
worldMSF = MSFWriter.runWriterS $ MSFReader.runReaderS $ morphS (runYieldT . unGlossM) $ performOnFirstSample $ eraseClock rhine
stepWith :: (Float, Maybe Event) -> (WorldMSF, Picture) -> (WorldMSF, Picture)
stepWith (diff, eventMaybe) (msf, _) = let ((picture, _), msf') = runIdentity $ unMSF msf ((diff, eventMaybe), ()) in (msf', picture)
worldAutomaton :: WorldAutomaton
worldAutomaton = AutomatonWriter.runWriterS $ AutomatonReader.runReaderS $ hoistS (runYieldT . unGlossM) $ performOnFirstSample $ eraseClock rhine
stepWith :: (Float, Maybe Event) -> (WorldAutomaton, Picture) -> (WorldAutomaton, Picture)
stepWith (diff, eventMaybe) (automaton, _) = let Result automaton' (picture, _) = runIdentity $ stepAutomaton automaton ((diff, eventMaybe), ()) in (automaton', picture)
getPic (_, pic) = pic
handleEvent event = stepWith (0, Just event)
simStep diff = stepWith (diff, Nothing)
1 change: 0 additions & 1 deletion rhine-terminal/rhine-terminal.cabal
Original file line number Diff line number Diff line change
@@ -28,7 +28,6 @@ library
exposed-modules: FRP.Rhine.Terminal
build-depends:
base >=4.11 && <4.18,
dunai ^>=0.12.2,
exceptions >=0.10.4,
monad-schedule >=0.1.2,
rhine ==1.2,
9 changes: 9 additions & 0 deletions rhine/ChangeLog.md
Original file line number Diff line number Diff line change
@@ -1,5 +1,14 @@
# Revision history for rhine

## 1.3

* Dropped `dunai` dependency in favour of state automata.
See [the versions readme](./versions.md) for details.
* Moved the monad argument `m` in `ClSFExcept`:
It is now `ClSFExcept cl a b m e` instead of `ClSFExcept m cl a b e`.
The advantage is that now the type is an instance of `MonadTrans` and `MFunctor`.
Analogous changes have been made to `BehaviourFExcept`.

## 1.2.1

* Added `FRP.Rhine.Clock.Realtime.Never` (clock that never ticks)
3 changes: 2 additions & 1 deletion rhine/bench/Main.hs
Original file line number Diff line number Diff line change
@@ -2,7 +2,8 @@
import Criterion.Main

-- rhine
import Sum
import WordCount

main :: IO ()
main = defaultMain [WordCount.benchmarks]
main = defaultMain [WordCount.benchmarks, Sum.benchmarks]
73 changes: 73 additions & 0 deletions rhine/bench/Sum.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,73 @@
{-# 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 "dunai" Data.MonadicStreamFunction as Dunai

import "automaton" Data.Stream as Stream (StreamT (..))
import "automaton" Data.Stream.Optimized (OptimizedStreamT (Stateful))
import "automaton" Data.Stream.Result (Result (..))
import "rhine" FRP.Rhine as Rhine

nMax :: Int
nMax = 1_000_000

benchmarks :: Benchmark
benchmarks =
bgroup
"Sum"
[ bench "rhine" $ nf rhine nMax
, bench "rhine flow" $ nf rhineFlow nMax
, bench "dunai" $ nf dunai nMax
, bench "automaton" $ nf automaton nMax
, bench "direct" $ nf direct nMax
, bench "direct monad" $ nf directM nMax
]

rhine :: Int -> Int
rhine n = sum $ runIdentity $ Rhine.embed Rhine.count $ replicate n ()

-- FIXME separate ticket to improve performance of this
rhineFlow :: Int -> Int
rhineFlow n =
either id absurd $
flow $
(@@ Trivial) $ proc () -> do
k <- Rhine.count -< ()
s <- Rhine.sumN -< k
if k < n
then returnA -< ()
else arrMCl Left -< s

dunai :: Int -> Int
dunai n = sum $ runIdentity $ Dunai.embed Dunai.count $ replicate n ()

automaton :: Int -> Int
automaton n = sum $ runIdentity $ Rhine.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]
19 changes: 16 additions & 3 deletions rhine/bench/Test.hs
Original file line number Diff line number Diff line change
@@ -1,3 +1,6 @@
-- rhine

import Sum
import WordCount

-- tasty
@@ -14,7 +17,17 @@ main :: IO ()
main =
defaultMain $
testGroup
"WordCount"
[ testCase "rhine" $ rhineWordCount >>= (@?= wordCount)
, testCase "dunai" $ dunaiWordCount >>= (@?= wordCount)
"Benchmark tests"
[ testGroup
"WordCount"
[ testCase "rhine" $ rhineWordCount >>= (@?= wordCount)
, testCase "dunai" $ dunaiWordCount >>= (@?= wordCount)
]
, testGroup
"Sum"
[ testCase "rhine" $ Sum.rhine Sum.nMax @?= Sum.direct Sum.nMax
, testCase "dunai" $ Sum.dunai 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
]
]
53 changes: 37 additions & 16 deletions rhine/bench/WordCount.hs
Original file line number Diff line number Diff line change
@@ -23,11 +23,13 @@ import Data.Text.Lazy.IO (hGetContents)
import Criterion.Main

-- dunai
import Control.Monad.Trans.MSF.Except qualified as Dunai
import Data.MonadicStreamFunction qualified as Dunai

-- rhine
-- automaton
import Data.Automaton.Trans.Except qualified as Automaton

import Control.Monad.Trans.MSF.Except qualified as Dunai
-- rhine
import FRP.Rhine
import FRP.Rhine.Clock.Except (
DelayIOError,
@@ -44,6 +46,7 @@ benchmarks =
"WordCount"
[ bench "rhine" $ nfIO rhineWordCount
, bench "dunai" $ nfIO dunaiWordCount
, bench "automaton" $ nfIO automatonWordCount
, bgroup
"Text"
[ bench "IORef" $ nfIO textWordCount
@@ -71,18 +74,37 @@ withInput action = do
-- | Idiomatic Rhine implementation with a single clock
rhineWordCount :: IO Int
rhineWordCount = do
Left (Right count) <- withInput $ runExceptT $ flow $ wc @@ delayIOError (ExceptClock StdinClock) Left
return count
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 -< ()
words <- mappendS -< either (const 0) (Sum . length . words) lineOrStop
throwOn' -< (either isEOFError (const False) lineOrStop, Right $ getSum words)
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

{- | Idiomatic dunai implementation.
Compared to Rhine, this doesn't have the overhead of clocks and exception handling.
Compared to Rhine, this doesn't have the overhead of clocks,
but it's implemented with continuations and not explicit state machines.
-}
dunaiWordCount :: IO Int
dunaiWordCount = do
@@ -95,16 +117,15 @@ dunaiWordCount = do
case lineOrEOF of
Right _ -> returnA -< ()
Left e ->
if isEOFError e
then Dunai.throwS -< Right $ getSum nWords
else Dunai.throwS -< Left e
Dunai.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.
This is what 'rhineWordCount' would reduce to roughly, if all possible optimizations kick in,
except for the way the IORef is handled.
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
@@ -129,11 +150,11 @@ textWordCountNoIORef :: IO Int
textWordCountNoIORef = do
withInput $ go 0
where
step n = do
processLine n = do
line <- getLine
return $ Right $ n + length (words line)
go n = do
n' <- catch (step n) $
n' <- catch (processLine n) $
\(e :: IOError) ->
if isEOFError e
then return $ Left n
@@ -144,5 +165,5 @@ textWordCountNoIORef = do
textLazy :: IO Int
textLazy = do
inputFileName <- testFile
handle <- openFile inputFileName ReadMode
length . Lazy.words <$> hGetContents handle
h <- openFile inputFileName ReadMode
length . Lazy.words <$> hGetContents h
28 changes: 27 additions & 1 deletion rhine/rhine.cabal
Original file line number Diff line number Diff line change
@@ -46,10 +46,13 @@ source-repository this

common opts
build-depends:
automaton ^>=0.1.0.0,
base >=4.14 && <4.18,
monad-schedule ^>=0.1.2,
mtl >=2.2 && <2.4,
selective ^>=0.7,
text >=1.2 && <2.1,
time >=1.8,
transformers >=0.5,
vector-sized >=1.4,

@@ -78,8 +81,10 @@ common opts

common test-deps
build-depends:
QuickCheck ^>=2.14,
tasty ^>=1.4,
tasty-hunit ^>=0.10,
tasty-quickcheck ^>=0.10,

common bench-deps
build-depends:
@@ -140,10 +145,12 @@ library
MonadRandom >=0.5,
containers >=0.5,
deepseq >=1.4,
dunai ^>=0.12.2,
free >=5.1,
mmorph ^>=1.2,
profunctors ^>=5.6,
random >=1.1,
simple-affine-space ^>=0.2,
sop-core ^>=0.5,
text >=1.2 && <2.1,
time >=1.8,
time-domain ^>=0.1.0.2,
@@ -162,6 +169,7 @@ test-suite test
Clock.Except
Clock.FixedStep
Clock.Millisecond
Except
Paths_rhine
Schedule
Util
@@ -182,12 +190,24 @@ benchmark benchmark
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
@@ -196,9 +216,15 @@ test-suite benchmark-test
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
7 changes: 3 additions & 4 deletions rhine/src/FRP/Rhine.hs
Original file line number Diff line number Diff line change
@@ -12,12 +12,11 @@ main = flow \$ constMCl (putStrLn \"Hello World!\") \@\@ (waitClock :: Milliseco
-}
module FRP.Rhine (module X) where

-- dunai
import Data.MonadicStreamFunction as X hiding ((>>>^), (^>>>))
import Data.VectorSpace as X
-- automaton
import Data.Automaton as X

-- rhine

import Data.VectorSpace as X
import FRP.Rhine.ClSF as X
import FRP.Rhine.Clock as X
import FRP.Rhine.Clock.Proxy as X
2 changes: 1 addition & 1 deletion rhine/src/FRP/Rhine/ClSF.hs
Original file line number Diff line number Diff line change
@@ -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),
14 changes: 7 additions & 7 deletions rhine/src/FRP/Rhine/ClSF/Core.hs
Original file line number Diff line number Diff line change
@@ -22,8 +22,8 @@ import Control.Arrow
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader (ReaderT, mapReaderT, withReaderT)

-- dunai
import Data.MonadicStreamFunction as X hiding ((>>>^), (^>>>))
-- automaton
import Data.Automaton as X

-- rhine
import FRP.Rhine.Clock
@@ -34,7 +34,7 @@ import FRP.Rhine.Clock
with the additional side effect of being time-aware,
that is, reading the current 'TimeInfo' of the clock @cl@.
-}
type ClSF m cl a b = MSF (ReaderT (TimeInfo cl) m) a b
type ClSF m cl a b = Automaton (ReaderT (TimeInfo cl) m) a b

{- | A clocked signal is a 'ClSF' with no input required.
It produces its output on its own.
@@ -67,7 +67,7 @@ hoistClSF ::
(forall c. m1 c -> m2 c) ->
ClSF m1 cl a b ->
ClSF m2 cl a b
hoistClSF hoist = morphS $ mapReaderT hoist
hoistClSF hoist = hoistS $ mapReaderT hoist

-- | Hoist a 'ClSF' and its clock along a monad morphism.
hoistClSFAndClock ::
@@ -76,7 +76,7 @@ hoistClSFAndClock ::
ClSF m1 cl a b ->
ClSF m2 (HoistClock m1 m2 cl) a b
hoistClSFAndClock hoist =
morphS $ withReaderT (retag id) . mapReaderT hoist
hoistS $ withReaderT (retag id) . mapReaderT hoist

-- | Lift a 'ClSF' into a monad transformer.
liftClSF ::
@@ -95,8 +95,8 @@ 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
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
49 changes: 24 additions & 25 deletions rhine/src/FRP/Rhine/ClSF/Except.hs
Original file line number Diff line number Diff line change
@@ -5,7 +5,7 @@
{- | This module provides exception handling, and thus control flow,
to synchronous signal functions.
The API presented here closely follows dunai's 'Control.Monad.Trans.MSF.Except',
The API presented here closely follows @automaton@'s 'Data.Automaton.Trans.Except',
and reexports everything needed from there.
-}
module FRP.Rhine.ClSF.Except (
@@ -14,7 +14,7 @@ module FRP.Rhine.ClSF.Except (
safe,
safely,
exceptS,
runMSFExcept,
runAutomatonExcept,
currentInput,
)
where
@@ -27,12 +27,9 @@ import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except as X
import Control.Monad.Trans.Reader

-- dunai
import Control.Monad.Trans.MSF.Except hiding (once, once_, throwOn, throwOn', throwS, try)
import Data.MonadicStreamFunction

-- TODO Find out whether there is a cleverer way to handle exports
import Control.Monad.Trans.MSF.Except qualified as MSFE
-- automaton
import Data.Automaton.Trans.Except hiding (once, once_, throwOn, throwOn', throwS, try)
import Data.Automaton.Trans.Except qualified as AutomatonE

-- rhine
import FRP.Rhine.ClSF.Core
@@ -46,11 +43,11 @@ throwS :: (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.
@@ -89,54 +86,56 @@ throwMaybe = proc me -> case me of

-- * Monad interface

-- FIXME docs

{- | A synchronous exception-throwing signal function.
It is based on a @newtype@ from Dunai, 'MSFExcept',
It is based on a @newtype@ from Dunai, '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
* @e@: The type of exceptions that can be thrown
-}
type ClSFExcept m cl a b e = MSFExcept (ReaderT (TimeInfo cl) m) a b e
type ClSFExcept cl a b m e = AutomatonExcept a b (ReaderT (TimeInfo cl) m) e

{- | A clock polymorphic 'ClSFExcept',
or equivalently an exception-throwing behaviour.
Any clock with time domain @time@ may occur.
-}
type BehaviourFExcept m time a b e =
forall cl. (time ~ Time cl) => ClSFExcept m cl a b e
type BehaviourFExcept time a b m e =
forall cl. (time ~ Time cl) => ClSFExcept cl a b m e

-- | Compatibility to U.S. american spelling.
type BehaviorFExcept m time a b e = BehaviourFExcept m time a b e
type BehaviorFExcept time a b m e = BehaviourFExcept time a b m e

-- | Leave the monad context, to use the 'ClSFExcept' as an 'Arrow'.
runClSFExcept :: (Monad m) => ClSFExcept m cl a b e -> ClSF (ExceptT e m) cl a b
runClSFExcept = morphS commuteExceptReader . runMSFExcept
runClSFExcept :: (Monad m) => ClSFExcept cl a b m e -> ClSF (ExceptT e m) cl a b
runClSFExcept = hoistS commuteExceptReader . runAutomatonExcept

{- | Enter the monad context in the exception
for 'ClSF's in the 'ExceptT' monad.
The 'ClSF' will be run until it encounters an exception.
-}
try :: (Monad m) => ClSF (ExceptT e m) cl a b -> ClSFExcept m cl a b e
try = MSFE.try . morphS commuteReaderExcept
try :: (Monad m) => ClSF (ExceptT e m) cl a b -> ClSFExcept cl a b m e
try = AutomatonE.try . hoistS commuteReaderExcept

{- | Within the same tick, perform a monadic action,
and immediately throw the value as an exception.
-}
once :: (Monad m) => (a -> m e) -> ClSFExcept m cl a b e
once f = MSFE.once $ lift . f
once :: (Monad m) => (a -> m e) -> ClSFExcept cl a b m e
once f = AutomatonE.once $ lift . f

-- | A variant of 'once' without input.
once_ :: (Monad m) => m e -> ClSFExcept m cl a b e
once_ :: (Monad m) => m e -> ClSFExcept cl a b m e
once_ = once . const

{- | Advances a single tick with the given Kleisli arrow,
and then throws an exception.
-}
step :: (Monad m) => (a -> m (b, e)) -> ClSFExcept m cl a b e
step f = MSFE.step $ lift . f
step :: (Monad m) => (a -> m (b, e)) -> ClSFExcept cl a b m e
step f = AutomatonE.step $ lift . f
14 changes: 7 additions & 7 deletions rhine/src/FRP/Rhine/ClSF/Random.hs
Original file line number Diff line number Diff line change
@@ -3,8 +3,8 @@

{- | Create 'ClSF's with randomness without 'IO'.
Uses the @MonadRandom@ package.
This module copies the API from @dunai@'s
'Control.Monad.Trans.MSF.Random'.
This module copies the API from @automaton@'s
'Data.Automaton.Trans.Random'.
-}
module FRP.Rhine.ClSF.Random (
module FRP.Rhine.ClSF.Random,
@@ -18,10 +18,10 @@ import Control.Monad.IO.Class
-- MonadRandom
import Control.Monad.Random

-- dunai
import Control.Monad.Trans.MSF.Except (performOnFirstSample)
import Control.Monad.Trans.MSF.Random as X hiding (evalRandS, getRandomRS, getRandomRS_, getRandomS, runRandS)
import Control.Monad.Trans.MSF.Random qualified as MSF
-- automaton
import Data.Automaton.Trans.Except (performOnFirstSample)
import Data.Automaton.Trans.Random as X hiding (evalRandS, getRandomRS, getRandomRS_, getRandomS, runRandS)
import Data.Automaton.Trans.Random qualified as Automaton

-- rhine
import FRP.Rhine.ClSF.Core
@@ -36,7 +36,7 @@ runRandS ::
-- | The initial random seed
g ->
ClSF m cl a (g, b)
runRandS clsf = MSF.runRandS (morphS commuteReaderRand clsf)
runRandS clsf = Automaton.runRandS (hoistS commuteReaderRand clsf)

-- | Updates the generator every step but discards the generator.
evalRandS ::
12 changes: 8 additions & 4 deletions rhine/src/FRP/Rhine/ClSF/Reader.hs
Original file line number Diff line number Diff line change
@@ -13,8 +13,8 @@ import Data.Tuple (swap)
-- transformers
import Control.Monad.Trans.Reader

-- dunai
import Control.Monad.Trans.MSF.Reader qualified as MSF
-- automaton
import Data.Automaton.Trans.Reader qualified as Automaton

-- rhine
import FRP.Rhine.ClSF.Core
@@ -23,6 +23,7 @@ import FRP.Rhine.ClSF.Core
commuteReaders :: ReaderT r1 (ReaderT r2 m) a -> ReaderT r2 (ReaderT r1 m) a
commuteReaders a =
ReaderT $ \r1 -> ReaderT $ \r2 -> runReaderT (runReaderT a r2) r1
{-# INLINE commuteReaders #-}

{- | Create ("wrap") a 'ReaderT' layer in the monad stack of a behaviour.
Each tick, the 'ReaderT' side effect is performed
@@ -33,7 +34,8 @@ readerS ::
ClSF m cl (a, r) b ->
ClSF (ReaderT r m) cl a b
readerS behaviour =
morphS commuteReaders $ MSF.readerS $ arr swap >>> behaviour
hoistS commuteReaders $ Automaton.readerS $ arr swap >>> behaviour
{-# INLINE readerS #-}

{- | Remove ("run") a 'ReaderT' layer from the monad stack
by making it an explicit input to the behaviour.
@@ -43,7 +45,8 @@ runReaderS ::
ClSF (ReaderT r m) cl a b ->
ClSF m cl (a, r) b
runReaderS behaviour =
arr swap >>> MSF.runReaderS (morphS commuteReaders behaviour)
arr swap >>> Automaton.runReaderS (hoistS commuteReaders behaviour)
{-# INLINE runReaderS #-}

-- | Remove a 'ReaderT' layer by passing the readonly environment explicitly.
runReaderS_ ::
@@ -52,3 +55,4 @@ runReaderS_ ::
r ->
ClSF m cl a b
runReaderS_ behaviour r = arr (,r) >>> runReaderS behaviour
{-# INLINE runReaderS_ #-}
14 changes: 7 additions & 7 deletions rhine/src/FRP/Rhine/ClSF/Upsample.hs
Original file line number Diff line number Diff line change
@@ -7,22 +7,22 @@
module FRP.Rhine.ClSF.Upsample where

-- dunai
import Control.Monad.Trans.MSF.Reader
import Data.Automaton.Trans.Reader

-- rhine
import FRP.Rhine.ClSF.Core
import FRP.Rhine.Clock
import FRP.Rhine.Schedule

{- | An 'MSF' can be given arbitrary other arguments
{- | An 'Automaton' can be given arbitrary other arguments
that cause it to tick without doing anything
and replicating the last output.
-}
upsampleMSF :: (Monad m) => b -> MSF m a b -> MSF m (Either arbitrary a) b
upsampleMSF b msf = right msf >>> accumulateWith (<>) (Right b) >>> arr fromRight
upsampleAutomaton :: (Monad m) => b -> Automaton m a b -> Automaton m (Either arbitrary a) b
upsampleAutomaton b automaton = right automaton >>> accumulateWith (<>) (Right b) >>> arr fromRight
where
fromRight (Right b') = b'
fromRight (Left _) = error "fromRight: This case never occurs in upsampleMSF."
fromRight (Left _) = error "fromRight: This case never occurs in upsampleAutomaton."

-- Note that the Semigroup instance of Either a arbitrary
-- updates when the first argument is Right.
@@ -37,7 +37,7 @@ upsampleR ::
b ->
ClSF m clR a b ->
ClSF m (ParallelClock clL clR) a b
upsampleR b clsf = readerS $ arr remap >>> upsampleMSF b (runReaderS clsf)
upsampleR b clsf = readerS $ arr remap >>> upsampleAutomaton b (runReaderS clsf)
where
remap (TimeInfo {tag = Left tag}, _) = Left tag
remap (TimeInfo {tag = Right tag, ..}, a) = Right (TimeInfo {..}, a)
@@ -52,7 +52,7 @@ upsampleL ::
b ->
ClSF m clL a b ->
ClSF m (ParallelClock clL clR) a b
upsampleL b clsf = readerS $ arr remap >>> upsampleMSF b (runReaderS clsf)
upsampleL b clsf = readerS $ arr remap >>> upsampleAutomaton b (runReaderS clsf)
where
remap (TimeInfo {tag = Right tag}, _) = Left tag
remap (TimeInfo {tag = Left tag, ..}, a) = Right (TimeInfo {..}, a)
10 changes: 4 additions & 6 deletions rhine/src/FRP/Rhine/ClSF/Util.hs
Original file line number Diff line number Diff line change
@@ -26,9 +26,7 @@ import Data.Sequence
import Control.Monad.Trans.Reader (ask, asks)

-- dunai
import Control.Monad.Trans.MSF.Reader (readerS)
import Data.MonadicStreamFunction.Instances.Num ()
import Data.MonadicStreamFunction.Instances.VectorSpace ()
import Data.Automaton.Trans.Reader (readerS)

-- simple-affine-space
import Data.VectorSpace
@@ -178,7 +176,7 @@ derivativeFrom ::
v ->
BehaviorF m td v v
derivativeFrom v0 = proc v -> do
vLast <- iPre v0 -< v
vLast <- delay v0 -< v
TimeInfo {..} <- timeInfo -< ()
returnA -< (v ^-^ vLast) ^/ sinceLast

@@ -205,7 +203,7 @@ threePointDerivativeFrom ::
BehaviorF m td v v
threePointDerivativeFrom v0 = proc v -> do
dv <- derivativeFrom v0 -< v
dv' <- iPre zeroVector -< dv
dv' <- delay zeroVector -< dv
returnA -< (dv ^+^ dv') ^/ 2

{- | Like 'threePointDerivativeFrom',
@@ -441,5 +439,5 @@ scaledTimer diff = timer diff >>> arr (/ diff)
{- | Remembers the last 'Just' value,
defaulting to the given initialisation value.
-}
lastS :: (Monad m) => a -> MSF m (Maybe a) a
lastS :: (Monad m) => a -> Automaton m (Maybe a) a
lastS a = arr Last >>> mappendFrom (Last (Just a)) >>> arr (getLast >>> fromJust)
17 changes: 8 additions & 9 deletions rhine/src/FRP/Rhine/Clock.hs
Original file line number Diff line number Diff line change
@@ -22,14 +22,15 @@ module FRP.Rhine.Clock (
where

-- base
import Control.Arrow
import Control.Category qualified as Category

-- transformers
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Class (MonadTrans, lift)

-- dunai
import Data.MonadicStreamFunction as X hiding ((>>>^), (^>>>))
-- automaton
import Data.Automaton (Automaton, arrM, hoistS)

-- time-domain
import Data.TimeDomain as X
@@ -41,7 +42,7 @@ A clock creates a stream of time stamps and additional information,
possibly together with side effects in a monad 'm'
that cause the environment to wait until the specified time is reached.
-}
type RunningClock m time tag = MSF m () (time, tag)
type RunningClock m time tag = Automaton m () (time, tag)

{- |
When initialising a clock, the initial time is measured
@@ -109,11 +110,11 @@ type Rescaling cl time = Time cl -> time
-}
type RescalingM m cl time = Time cl -> m time

{- | An effectful, stateful morphism of time domains is an 'MSF'
{- | An effectful, stateful morphism of time domains is an 'Automaton'
that uses side effects to rescale a point in one time domain
into another one.
-}
type RescalingS m cl time tag = MSF m (Time cl, Tag cl) (time, tag)
type RescalingS m cl time tag = Automaton m (Time cl, Tag cl) (time, tag)

{- | Like 'RescalingS', but allows for an initialisation
of the rescaling morphism, together with the initial time.
@@ -128,7 +129,7 @@ rescaleMToSInit ::
(Monad m) =>
(time1 -> m time2) ->
time1 ->
m (MSF m (time1, tag) (time2, tag), time2)
m (Automaton m (time1, tag) (time2, tag), time2)
rescaleMToSInit rescaling time1 = (arrM rescaling *** Category.id,) <$> rescaling time1

-- ** Applying rescalings to clocks
@@ -241,10 +242,8 @@ instance
type Tag (HoistClock m1 m2 cl) = Tag cl
initClock HoistClock {..} = do
(runningClock, initialTime) <- monadMorphism $ initClock unhoistedClock
let hoistMSF = morphS
-- TODO Look out for API changes in dunai here
return
( hoistMSF monadMorphism runningClock
( hoistS monadMorphism runningClock
, initialTime
)

18 changes: 8 additions & 10 deletions rhine/src/FRP/Rhine/Clock/Except.hs
Original file line number Diff line number Diff line change
@@ -8,20 +8,18 @@ import Control.Monad ((<=<))
import Data.Functor ((<&>))
import Data.Void

-- transformers
import Control.Monad.Trans.MSF.Except

-- time
import Data.Time (UTCTime, getCurrentTime)

-- mtl
import Control.Monad.Error.Class
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.MSF qualified as MSFExcept

-- dunai
import Control.Monad.Trans.MSF.Reader (readerS, runReaderS)
import Data.MonadicStreamFunction (morphS)
-- 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)
@@ -54,7 +52,7 @@ instance (Exception e, Clock IO cl, MonadIO eio, MonadError e eio) => Clock eio
ioerror $
Exception.try $
initClock getExceptClock
<&> first (morphS (ioerror . Exception.try))
<&> first (hoistS (ioerror . Exception.try))
where
ioerror :: (MonadError e eio, MonadIO eio) => IO (Either e a) -> eio a
ioerror = liftEither <=< liftIO
@@ -81,7 +79,7 @@ instance (Time cl1 ~ Time cl2, Clock (ExceptT e m) cl1, Clock m cl2, Monad m) =>
case tryToInit of
Right (runningClock, initTime) -> do
let catchingClock = safely $ do
e <- MSFExcept.try runningClock
e <- AutomatonExcept.try runningClock
let cl2 = handler e
(runningClock', _) <- once_ $ initClock cl2
safe $ runningClock' >>> arr (second Left)
@@ -136,7 +134,7 @@ instance (TimeDomain time, MonadError e m) => Clock m (Single m time tag e) wher
type Tag (Single m time tag e) = tag
initClock Single {singleTag, getTime, exception} = do
initTime <- getTime
let runningClock = morphS (errorT . runExceptT) $ runMSFExcept $ do
let runningClock = hoistS (errorT . runExceptT) $ runAutomatonExcept $ do
step_ (initTime, singleTag)
return exception
errorT :: (MonadError e m) => m (Either e a) -> m a
4 changes: 4 additions & 0 deletions rhine/src/FRP/Rhine/Clock/FixedStep.hs
Original file line number Diff line number Diff line change
@@ -12,6 +12,7 @@ and a deterministic schedule for such clocks.
module FRP.Rhine.Clock.FixedStep where

-- base
import Control.Arrow
import Data.Functor (($>))
import Data.Maybe (fromMaybe)
import GHC.TypeLits
@@ -23,6 +24,9 @@ import Data.Vector.Sized (Vector, fromList)
import Control.Monad.Schedule.Class
import Control.Monad.Schedule.Trans (ScheduleT, wait)

-- automaton
import Data.Automaton (accumulateWith, arrM)

-- rhine
import FRP.Rhine.Clock
import FRP.Rhine.Clock.Proxy
21 changes: 6 additions & 15 deletions rhine/src/FRP/Rhine/Clock/Periodic.hs
Original file line number Diff line number Diff line change
@@ -15,16 +15,16 @@ The time differences are supplied at the type level.
module FRP.Rhine.Clock.Periodic (Periodic (Periodic)) where

-- base
import Control.Arrow
import Data.List.NonEmpty hiding (unfold)
import Data.Maybe (fromMaybe)
import GHC.TypeLits (KnownNat, Nat, natVal)

-- dunai
import Data.MonadicStreamFunction

-- monad-schedule
import Control.Monad.Schedule.Trans

-- automaton
import Data.Automaton (Automaton (..), accumulateWith, concatS, withSideEffect)

-- rhine
import FRP.Rhine.Clock
import FRP.Rhine.Clock.Proxy
@@ -80,15 +80,6 @@ instance

-- * 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
12 changes: 7 additions & 5 deletions rhine/src/FRP/Rhine/Clock/Realtime/Audio.hs
Original file line number Diff line number Diff line change
@@ -21,15 +21,17 @@ module FRP.Rhine.Clock.Realtime.Audio (
where

-- base
import Control.Arrow
import Data.Time.Clock
import GHC.Float (double2Float)
import GHC.TypeLits (KnownNat, Nat, natVal)

-- transformers
import Control.Monad.IO.Class

-- dunai
import Control.Monad.Trans.MSF.Except hiding (step)
-- automaton
import Data.Automaton
import Data.Automaton.Trans.Except hiding (step)

-- rhine
import FRP.Rhine.Clock
@@ -100,11 +102,11 @@ instance
initClock audioClock = do
let
step =
picosecondsToDiffTime $ -- The only sufficiently precise conversion function
round (10 ^ (12 :: Integer) / theRateNum audioClock :: Double)
picosecondsToDiffTime $
round (10 ^ (12 :: Integer) / theRateNum audioClock :: Double) -- The only sufficiently precise conversion function
bufferSize = theBufferSize audioClock

runningClock :: (MonadIO m) => UTCTime -> Maybe Double -> MSF m () (UTCTime, Maybe Double)
runningClock :: (MonadIO m) => UTCTime -> Maybe Double -> Automaton m () (UTCTime, Maybe Double)
runningClock initialTime maybeWasLate = safely $ do
bufferFullTime <- try $ proc () -> do
n <- count -< ()
4 changes: 4 additions & 0 deletions rhine/src/FRP/Rhine/Clock/Realtime/Busy.hs
Original file line number Diff line number Diff line change
@@ -5,11 +5,15 @@
module FRP.Rhine.Clock.Realtime.Busy where

-- base
import Control.Arrow
import Control.Monad.IO.Class

-- time
import Data.Time.Clock

-- automaton
import Data.Automaton (constM)

-- rhine
import FRP.Rhine.Clock
import FRP.Rhine.Clock.Proxy
2 changes: 1 addition & 1 deletion rhine/src/FRP/Rhine/Clock/Realtime/Event.hs
Original file line number Diff line number Diff line change
@@ -66,7 +66,7 @@ Ideally, this action is run _outside_ of 'flow',
e.g. @runEventChanT $ flow myRhine@.
This way, exactly one channel is created.

Caution: Don't use this with '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'.
8 changes: 7 additions & 1 deletion rhine/src/FRP/Rhine/Clock/Realtime/Millisecond.hs
Original file line number Diff line number Diff line change
@@ -9,15 +9,21 @@ Provides a clock that ticks at every multiple of a fixed number of milliseconds.
module FRP.Rhine.Clock.Realtime.Millisecond where

-- base
import Control.Arrow
import Control.Concurrent (threadDelay)
import Control.Monad.IO.Class (liftIO)
import Data.Maybe (fromMaybe)
import Data.Time.Clock
import GHC.TypeLits

-- time
import Data.Time.Clock

-- vector-sized
import Data.Vector.Sized (Vector, fromList)

-- automaton
import Data.Automaton (arrM)

-- rhine
import FRP.Rhine.Clock
import FRP.Rhine.Clock.FixedStep
7 changes: 4 additions & 3 deletions rhine/src/FRP/Rhine/Clock/Realtime/Never.hs
Original file line number Diff line number Diff line change
@@ -7,18 +7,19 @@ 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

-- transformers
import Control.Monad.IO.Class

-- | A clock that never ticks.
data Never = Never

3 changes: 3 additions & 0 deletions rhine/src/FRP/Rhine/Clock/Realtime/Stdin.hs
Original file line number Diff line number Diff line change
@@ -19,6 +19,9 @@ import Control.Monad.IO.Class
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
17 changes: 9 additions & 8 deletions rhine/src/FRP/Rhine/Clock/Select.hs
Original file line number Diff line number Diff line change
@@ -14,16 +14,17 @@ that ticks only on certain subevents.
-}
module FRP.Rhine.Clock.Select where

-- base
import Control.Arrow
import Data.Maybe (maybeToList)

-- automaton
import Data.Automaton (Automaton, concatS)

-- rhine
import FRP.Rhine.Clock
import FRP.Rhine.Clock.Proxy

-- dunai
import Data.MonadicStreamFunction.Async (concatS)

-- base
import Data.Maybe (maybeToList)

{- | A clock that selects certain subevents of type 'a',
from the tag of a main clock.

@@ -66,8 +67,8 @@ instance (Monad m, Clock m cl) => Clock m (SelectClock cl a) where

instance GetClockProxy (SelectClock cl a)

{- | Helper function that runs an 'MSF' with 'Maybe' output
{- | Helper function that runs an 'Automaton' with 'Maybe' output
until it returns a value.
-}
filterS :: (Monad m) => MSF m () (Maybe b) -> MSF m () b
filterS :: (Monad m) => Automaton m () (Maybe b) -> Automaton m () b
filterS = concatS . (>>> arr maybeToList)
6 changes: 5 additions & 1 deletion rhine/src/FRP/Rhine/Clock/Unschedule.hs
Original file line number Diff line number Diff line change
@@ -5,12 +5,16 @@
module FRP.Rhine.Clock.Unschedule where

-- base
import Control.Arrow
import Control.Concurrent qualified as Concurrent (yield)
import Control.Monad.IO.Class

-- monad-schedule
import Control.Monad.Schedule.Trans

-- automaton
import Data.Automaton (hoistS)

-- rhine
import FRP.Rhine.Clock

@@ -29,7 +33,7 @@ unyieldClock cl = UnscheduleClock cl $ const $ liftIO Concurrent.yield
instance (Clock (ScheduleT (Diff (Time cl)) m) cl, Monad m) => Clock m (UnscheduleClock m cl) where
type Tag (UnscheduleClock _ cl) = Tag cl
type Time (UnscheduleClock _ cl) = Time cl
initClock UnscheduleClock {scheduleClock, scheduleWait} = run $ first (morphS run) <$> initClock scheduleClock
initClock UnscheduleClock {scheduleClock, scheduleWait} = run $ first (hoistS run) <$> initClock scheduleClock
where
run :: ScheduleT (Diff (Time cl)) m a -> m a
run = runScheduleT scheduleWait
10 changes: 8 additions & 2 deletions rhine/src/FRP/Rhine/Clock/Util.hs
Original file line number Diff line number Diff line change
@@ -3,9 +3,15 @@

module FRP.Rhine.Clock.Util where

-- base
import Control.Arrow

-- time-domain
import Data.TimeDomain

-- automaton
import Data.Automaton (Automaton, delay)

-- rhine
import FRP.Rhine.Clock
import FRP.Rhine.Clock.Proxy
@@ -19,9 +25,9 @@ genTimeInfo ::
(Monad m, Clock m cl) =>
ClockProxy cl ->
Time cl ->
MSF m (Time cl, Tag cl) (TimeInfo cl)
Automaton m (Time cl, Tag cl) (TimeInfo cl)
genTimeInfo _ initialTime = proc (absolute, tag) -> do
lastTime <- iPre initialTime -< absolute
lastTime <- delay initialTime -< absolute
returnA
-<
TimeInfo
27 changes: 21 additions & 6 deletions rhine/src/FRP/Rhine/Reactimation.hs
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE GADTs #-}

{- |
@@ -6,9 +7,6 @@ as main loops.
-}
module FRP.Rhine.Reactimation where

-- dunai
import Data.MonadicStreamFunction.InternalCore

-- rhine
import FRP.Rhine.ClSF.Core
import FRP.Rhine.Clock
@@ -56,10 +54,26 @@ flow ::
, Time cl ~ Time (Out cl)
) =>
Rhine m cl () () ->
m ()
m void
flow rhine = do
msf <- eraseClock rhine
reactimate $ msf >>> arr (const ())
!automaton <- eraseClock rhine
reactimate $ automaton >>> arr (const ())
{-# INLINE flow #-}

{- | Like 'flow', but with the type signature specialized to @m ()@.

This is sometimes useful when dealing with ambiguous types.
-}
flow_ ::
( Monad m
, Clock m cl
, GetClockProxy cl
, Time cl ~ Time (In cl)
, Time cl ~ Time (Out cl)
) =>
Rhine m cl () () ->
m ()
flow_ = flow

{- | Run a synchronous 'ClSF' with its clock as a main loop,
similar to Yampa's, or Dunai's, 'reactimate'.
@@ -75,3 +89,4 @@ reactimateCl ::
ClSF m cl () () ->
m ()
reactimateCl cl clsf = flow $ clsf @@ cl
{-# INLINE reactimateCl #-}
33 changes: 17 additions & 16 deletions rhine/src/FRP/Rhine/Reactimation/ClockErasure.hs
Original file line number Diff line number Diff line change
@@ -3,8 +3,7 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TupleSections #-}

{- |
Translate clocked signal processing components to stream functions without explicit clock types.
{- | Translate clocked signal processing components to stream functions without explicit clock types.

This module is not meant to be used externally,
and is thus not exported from 'FRP.Rhine'.
@@ -14,12 +13,11 @@ module FRP.Rhine.Reactimation.ClockErasure where
-- base
import Control.Monad (join)

-- dunai
import Control.Monad.Trans.MSF.Reader
import Data.MonadicStreamFunction
-- automaton
import Data.Automaton.Trans.Reader
import Data.Stream.Result (Result (..))

-- rhine

import FRP.Rhine.ClSF hiding (runReaderS)
import FRP.Rhine.Clock
import FRP.Rhine.Clock.Proxy
@@ -35,10 +33,11 @@ eraseClockClSF ::
ClockProxy cl ->
Time cl ->
ClSF m cl a b ->
MSF m (Time cl, Tag cl, a) b
Automaton m (Time cl, Tag cl, a) b
eraseClockClSF proxy initialTime clsf = proc (time, tag, a) -> do
timeInfo <- genTimeInfo proxy initialTime -< (time, tag)
runReaderS clsf -< (timeInfo, a)
{-# INLINE eraseClockClSF #-}

{- | Run a signal network as a monadic stream function.

@@ -53,7 +52,7 @@ 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)
Automaton m (Time cl, Tag cl, Maybe a) (Maybe b)
-- A synchronous signal network is run by erasing the clock from the clocked signal function.
eraseClockSN initialTime sn@(Synchronous clsf) = proc (time, tag, Just a) -> do
b <- eraseClockClSF (toClockProxy sn) initialTime clsf -< (time, tag, a)
@@ -100,25 +99,25 @@ eraseClockSN initialTime (Precompose clsf sn) =
proc (time, tag, aMaybe) -> do
bMaybe <- mapMaybeS $ eraseClockClSF (inProxy proxy) initialTime clsf -< (time,,) <$> inTag proxy tag <*> aMaybe
eraseClockSN initialTime sn -< (time, tag, bMaybe)
eraseClockSN initialTime (Feedback buf0 sn) =
eraseClockSN initialTime (Feedback ResamplingBuffer {buffer, put, get} sn) =
let
proxy = toClockProxy sn
in
feedback buf0 $ proc ((time, tag, aMaybe), buf) -> do
feedback buffer $ proc ((time, tag, aMaybe), buf) -> do
(cMaybe, buf') <- case inTag proxy tag of
Nothing -> do
returnA -< (Nothing, buf)
Just tagIn -> do
timeInfo <- genTimeInfo (inProxy proxy) initialTime -< (time, tagIn)
(c, buf') <- arrM $ uncurry get -< (buf, timeInfo)
Result buf' c <- arrM $ uncurry get -< (timeInfo, buf)
returnA -< (Just c, buf')
bdMaybe <- eraseClockSN initialTime sn -< (time, tag, (,) <$> aMaybe <*> cMaybe)
case (,) <$> outTag proxy tag <*> bdMaybe of
Nothing -> do
returnA -< (Nothing, buf')
Just (tagOut, (b, d)) -> do
timeInfo <- genTimeInfo (outProxy proxy) initialTime -< (time, tagOut)
buf'' <- arrM $ uncurry $ uncurry put -< ((buf', timeInfo), d)
buf'' <- arrM $ uncurry $ uncurry put -< ((timeInfo, d), buf')
returnA -< (Just b, buf'')
eraseClockSN initialTime (FirstResampling sn buf) =
let
@@ -133,6 +132,7 @@ eraseClockSN initialTime (FirstResampling sn buf) =
_ -> Nothing
dMaybe <- mapMaybeS $ eraseClockResBuf (inProxy proxy) (outProxy proxy) initialTime buf -< resBufInput
returnA -< (,) <$> bMaybe <*> join dMaybe
{-# INLINE eraseClockSN #-}

{- | Translate a resampling buffer into a monadic stream function.

@@ -149,14 +149,15 @@ eraseClockResBuf ::
ClockProxy cl2 ->
Time cl1 ->
ResBuf m cl1 cl2 a b ->
MSF m (Either (Time cl1, Tag cl1, a) (Time cl2, Tag cl2)) (Maybe b)
eraseClockResBuf proxy1 proxy2 initialTime resBuf0 = feedback resBuf0 $ proc (input, resBuf) -> do
Automaton m (Either (Time cl1, Tag cl1, a) (Time cl2, Tag cl2)) (Maybe b)
eraseClockResBuf proxy1 proxy2 initialTime ResamplingBuffer {buffer, put, get} = feedback buffer $ proc (input, resBuf) -> do
case input of
Left (time1, tag1, a) -> do
timeInfo1 <- genTimeInfo proxy1 initialTime -< (time1, tag1)
resBuf' <- arrM (uncurry $ uncurry put) -< ((resBuf, timeInfo1), a)
resBuf' <- arrM (uncurry $ uncurry put) -< ((timeInfo1, a), resBuf)
returnA -< (Nothing, resBuf')
Right (time2, tag2) -> do
timeInfo2 <- genTimeInfo proxy2 initialTime -< (time2, tag2)
(b, resBuf') <- arrM (uncurry get) -< (resBuf, timeInfo2)
Result resBuf' b <- arrM (uncurry get) -< (timeInfo2, resBuf)
returnA -< (Just b, resBuf')
{-# INLINE eraseClockResBuf #-}
1 change: 1 addition & 0 deletions rhine/src/FRP/Rhine/Reactimation/Combinators.hs
Original file line number Diff line number Diff line change
@@ -44,6 +44,7 @@ infix 5 @@
cl ->
Rhine m cl a b
(@@) = Rhine . Synchronous
{-# INLINE (@@) #-}

{- | A purely syntactical convenience construction
enabling quadruple syntax for sequential composition, as described below.
Loading