diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,217 +1,231 @@ +2023-06-07 Ivan Perez + * Version bump (0.14.3) (#269). + * Improve readability of CHANGELOGs (#261). + * Conformance with style guide (#266). + * Reflect new contribution process in README (#265). + 2023-04-07 Ivan Perez - * Yampa.cabal: Version bump (0.14.2) (#259). - * src/: Conformance with style guide (#255). - * examples/: Conformance with style guide (#255), move example to - yampa-test library (#257). - * README: Add game to list of games and apps in README (#254). + * Version bump (0.14.2) (#259). + * Conformance with style guide (#255). + * Move example to yampa-test library (#257). + * Add game to list of games and apps in README (#254). 2023-02-07 Ivan Perez - * Yampa.cabal: Version bump (0.14.1) (#251). - * src/: Replace broken links (#253), fix typo (#252). + * Version bump (0.14.1) (#251). + * Replace broken links (#253). + * Fix typo (#252). 2022-12-07 Ivan Perez - * Yampa.cabal: Version bump (0.14) (#242), bump version bounds of - dependency (#241). - * src/: Adjust to work with simple-affine-space-0.2 (#241). + * Version bump (0.14) (#242). + * Adjust to work with simple-affine-space-0.2 (#241). 2022-10-07 Ivan Perez - * Yampa.cabal: Version bump (0.13.7) (#238), add version bounds to - dependencies (#233). - * LICENSE: Update years, copyright holders (#235). - * src/: Update years, copyright holders (#235). - * .travis.yml: Update distribution to bionic (#236). + * Version bump (0.13.7) (#238). + * Add version bounds to dependencies (#233). + * Update years, copyright holders (#235). + * Update distribution to bionic (#236). 2022-08-07 Ivan Perez - * Yampa.cabal: Version bump (0.13.6) (#232). - * src/: Fix typos in documentation (#224), replace AFRP with Yampa - (#223), simplify implementation of mapFilterE (#221). - * README: Re-structure README, add content, TOC (#227), fix typo - (#230). - * Replace funding link (#231). - * Thanks to @architsinghal-mriirs. + * Version bump (0.13.6) (#232). + * Fix typos in documentation (#224). + * Replace AFRP with Yampa (#223). + * Simplify implementation of mapFilterE (#221). + * Re-structure README, add content, TOC (#227). + * Fix typo (#230). + * Replace funding link (#231). + * Thanks to @architsinghal-mriirs. 2022-06-07 Ivan Perez - * Yampa.cabal: Version bump (0.13.5) (#220). - * src/: Remove vim modeline settings (#209), remove unnecessary - comments from module export lists (#210), style consistency of - separators (#211), adjust format of export lists (#212), align - lists, tuples, records by leading comma (#213), compress multiple - empty lines (#214), adjust indentation to two spaces (#215), make - arrows less prominent in descriptions (#183), remove unnecessary - import (#222). - * examples/: Replace tabs with spaces (#205), format module header to - conform to style guide (#207), style consistency of separators - (#211), adjust format of export lists (#212), align lists, tuples, - records by leading comma (#213), compress multiple empty lines - (#214), adjust indentation to two spaces (#215). - * tests/: Style consistency of separators (#211). - * README: make arrows less prominent in descriptions (#183). + * Version bump (0.13.5) (#220). + * Remove vim modeline settings (#209). + * Remove unnecessary comments from module export lists (#210). + * Style consistency of separators (#211). + * Adjust format of export lists (#212). + * Align lists, tuples, records by leading comma (#213). + * Compress multiple empty lines (#214). + * Adjust indentation to two spaces (#215). + * Make arrows less prominent in descriptions (#183). + * Remove unnecessary import (#222). + * Replace tabs with spaces (#205). + * Format module header to conform to style guide (#207). 2022-04-07 Ivan Perez - * Yampa.cabal: Version bump (0.13.4) (#203), syntax rules (#196), - remove regression tests (#201). - * src/: Remove unused extensions (#199), syntax rules (#200), remove - commented code and notes (#202). - * tests/: Rename tests (#195), remove regression tests (#201). - * README: Add new game (#197). + * Version bump (0.13.4) (#203). + * Syntax rules (#196). + * Remove regression tests (#201). + * Remove unused extensions (#199). + * Syntax rules (#200). + * Remove commented code and notes (#202). + * Rename tests (#195). + * Add new game (#197). 2021-10-07 Ivan Perez - * Yampa.cabal: Version bump (0.13.3) (#193), add modules missing from - other modules (#181). - * src/: Code cleaning and style fixes (#190, #191, #192). - * README.md: Restructure documentation (#184), fix installation - instructions (#186), add new games (#188), remove note (#189). + * Version bump (0.13.3) (#193). + * Add modules missing from other-modules in Cabal file (#181). + * Limit line length to 80 characters (#190). + * Standardize pragma style (#191). + * Correct module/copyright info in haddock documentation (#192). + * Restructure documentation in README (#184). + * Fix installation instructions in README (#186). + * Mention new games in README (#188). + * Remove note from README (#189). 2021-09-15 Ivan Perez - * Yampa.cabal: Version bump (0.13.2), change cabal-version, add - default language (#180). - * src/: Update links (#179). - * README.md: Update installation instructions (#177), links (#178), - pointers to other projects (#162, #160, #153) - * .travis.yml: Enable testing haddock documentation (#72). - * tests/: Avoid modules whose documentation haddock does not generated - even if present (#72). - * src/: Minor adaptations to imports to make tests work (#72), - minor haddock documentation fixes (#175), - complete missing haddock documentation (#72). + * Version bump (0.13.2), change cabal-version, add default language (#180). + * Update links in Haddock (#179). + * Update installation instructions in README (#177). + * Update links in README (#178). + * Update pointers to other projects in README (#162) + * Update pointers to other projects in README (#160) + * Update pointers to other projects in README (#153) + * Enable testing haddock documentation in CI (#72). + * Minor haddock documentation fixes (#175). 2019-10-15 Ivan Perez - * Yampa.cabal: Version bump (0.13.1), introduce examples - as executables, depend on fail if needed. - * README.md: Add Peoplemon. - * examples/: Fix errors due to module reorg. - * extensions/: Chnage testing to use tasty. - * .travis.yml: Compile with GHC8.8. - * src/: Support MonadFail proposal and GHC 8.8. - * Thanks to @sigrlami, @RyanGlScott and @CraigTreptow. + * Version bump (0.13.1). + * Introduce examples as executables in Cabal file. + * Add Peoplemon to README. + * Fix errors in examples due to module reorg. + * Change testing extension to use tasty. + * Compile with GHC8.8 in CI. + * Support MonadFail proposal and GHC 8.8. + * Thanks to @sigrlami, @RyanGlScott and @CraigTreptow. 2018-11-02 Ivan Perez - * Yampa.cabal: Version bump (0.13). - * README.md: Documents related projects. - * src/: Cleans API, removes deprecated constructs, moves - vector and points into separate library, hides Core, - eliminates Forceable and MergeableRecord, adds documentation. - * examples/: Adds Diagrams example. - * .travis.yml: Compile with GHC8.6 (allowing failures). + * Version bump (0.13). + * Document related projects. + * Clean API, remove deprecated constructs, move vector and point into + separate library, hide Core. + * Eliminate Forceable and MergeableRecord. + * Add documentation. + * Add Diagrams example. + * Compile with GHC8.6 in CI (allowing failures). 2018-10-21 Ivan Perez - * Yampa.cabal: Version bump (0.12). - * README.md: Documents testing. - * src/: Introduces FutureSF, needed for testing. - * extensions/test/: Introduces testing library. - * Thanks to @chriz-keera. + * Version bump (0.12). + * Document testing in README. + * Introduce FutureSF, needed for testing. + * Introduce testing library. + * Thanks to @chriz-keera. 2018-08-11 Ivan Perez - * Yampa.cabal: Version bump (0.11.1). - * README.md: Documents papers. - * src/: Fixes leak. - * Thanks to @tresormuta, @chriz-keera. + * Version bump (0.11.1). + * Document papers in README. + * Fix leak. + * Thanks to @tresormuta, @chriz-keera. 2018-04-05 Ivan Perez - * Yampa.cabal: Version bump (0.11). - * src/: Adds documentation; makes type synonym a newtype. - * tests/: Removes deprecated import. - * .travis.yml: Tests on travis with GHC 7.6 to 8.4. - * Thanks to @ptvirgo, @thalerjonathan, @turion. + * Version bump (0.11). + * Add documentation; makes type synonym a newtype. + * Remove deprecated import in tests. + * Test on travis with GHC 7.6 to 8.4. + * Thanks to @ptvirgo, @thalerjonathan, @turion. 2017-12-17 Ivan Perez - * Yampa.cabal: Version bump (0.10.7), adds flag to expose core, - adds flag descriptions, fixes missing modules. - * README.md: Adds images to descriptions. - * doc/: New HCAR including iOS release. - * src/: Exposes new function, removes unused extensions, - simplifies code, adds documentation, fixes multiple bugs. - * stack.yaml: Fixes nix setup. - * tests/: Adapts to new API. - * examples/: Adapts to new API. - * Thanks to @chriz-keera, @suzumiyasmith, @meimisaki, - @RyanGlScott, @madjestic, @mgttlinger, @eapcochran, - @jonmouchou. + * Version bump (0.10.7). + * Add flag to cabal file to expose core. + * Add flag to descriptions. + * Fix missing modules in cabal file. + * Add images to descriptions in README. + * New HCAR entry including iOS release. + * Expose new function. + * Remove unused extensions. + * Simplify code. + * Add documentation. + * Fix multiple bugs. + * Fix nix setup. + * Adapt tests to new API. + * Adapt examples to new API. + * Thanks to @chriz-keera, @suzumiyasmith, @meimisaki, @RyanGlScott, + @madjestic, @mgttlinger, @eapcochran, @jonmouchou. 2017-08-28 Ivan Perez - * Yampa.cabal: Version bump (0.10.6.2), fixes issue with dependencies. - * stack.yaml: Includes minimal stack configuration. + * Version bump (0.10.6.2). + * Fix issue with dependencies in Cabal file. + * Include minimal stack configuration. 2017-08-17 Ivan Perez - * Yampa.cabal: Version bump (0.10.6.1). - * examples/: new examples, using wiimote. - * src/: Minor improvements to documentation. + * Version bump (0.10.6.1). + * New examples, using wiimote. + * Minor improvements to documentation. 2017-05-05 Ivan Perez - * Yampa.cabal: Version bump (0.10.6). - * tests/: do not warn if they contain tabs. - * src/: Includes combinators to deal with collections, - to iterate over time (for custom/discrete integration), - implements ArrowChoice. + * Version bump (0.10.6). + * Do not warn if tests contain tabs. + * Include combinators to deal with collections. + * Include combinators to iterate over time (for custom/discrete + integration). + * Implement ArrowChoice. 2017-04-26 Ivan Perez - * .travis.yml: Instruct TravisCI upload package to hackage. - * Yampa.cabal: Version bump (0.10.5.1). + * Version bump (0.10.5.1). + * Instruct TravisCI upload package to hackage. 2016-05-23 Ivan Perez - * src/: Adds new -:> combinator. - * Yampa.cabal: Version bump (0.10.5). + * Version bump (0.10.5). + * Add new -:> combinator. 2015-11-14 Ivan Perez - * tests/: Include haddock. Regression tests now exit with proper exit - code. - * src/: Includes more documentation. - * Yampa.cabal: Include haddock and regression test suites. - Version bump (0.10.4). + * Version bump (0.10.4). + * Include haddock in tests. + * Regression tests now exit with proper exit code. + * Include more documentation. + * Include haddock and regression test suites. 2015-10-02 Ivan Perez - * src/: Event instances of Applicative and Alternative. - * Yampa.cabal: Version bump (0.10.3). + * Version bump (0.10.3). + * Event instances of Applicative and Alternative. 2015-06-19 Ivan Perez - * src:/ instances of DeepSeq (see #5). - * Yampa.cabal: Deepseq added to dependencies. Version bump (0.10.2). + * Version bump (0.10.2). + * Instances of DeepSeq (#5). 2015-05-06 Ivan Perez - * Yampa.cabal: disables tests by default. Version bump (0.10.1.1). + * Version bump (0.10.1.1). + * Disable tests by default in Cabal file. 2015-05-05 Ivan Perez - * Yampa.cabal: exposes internal modules for documentation purposes. - Version bump (0.10.1) + * Version bump (0.10.1). + * Expose internal modules for documentation purposes. 2015-05-05 Ivan Perez - * src/: Reorders code. Marks modules as deprecated. Removes useless functions. - * Yampa.cabal: version bump (0.10.0) + * Version bump (0.10.0). + * Reorder code. + * Mark modules as deprecated. + * Remove useless functions. 2015-05-05 Ivan Perez - * src/FRP/Yampa.hs: documentation. Removes tabs. - * README.md: links to games, related projects, documentation. - * Yampa.cabal: version bump (0.9.7) + * Version bump (0.9.7). + * Documentation added to FRP.Yampa. + * Remove tabs from FRP.Yampa. + * Link to games, related projects, documentation in README. 2015-03-30 Ivan Perez - * src/FRP/Yampa/Task.hs: Adds Functor and Applicative instances, - for compatibility with base >= 4.8 (issue #7, pull request by - Ryan Scott). - * Yampa.cabal: version bump (0.9.6.1). + * Version bump (0.9.6.1). + * Add Functor and Applicative instances for Tasks for compatibility with + base >= 4.8 (#7). + * Thanks to Ryan Scott. 2015-03-04 Ivan Perez - * src/: Coding style improvements. + * Coding style improvements. 2014-08-29 Ivan Perez - - * Yampa.cabal: version bump (0.9.6). - * src/: Adds a substantial amount of documentation. - * src/FRP/Yampa.hs: Adds a new pause combinator. + * Version bump (0.9.6). + * Add a substantial amount of documentation. + * Add a new pause combinator. 2014-06-04 Ivan Perez - - * Adds project to hudson-backed continuous integration server. + * Add project to hudson-backed continuous integration server. 2014-04-26 Ivan Perez - - * Yampa.cabal: version bump (0.9.5). - * Adds CHANGELOG to cabal file. + * Version bump (0.9.5). + * Add CHANGELOG to cabal file. 2014-04-07 Ivan Perez - - * Yampa.cabal: new maintainer, version bump (0.9.4). - * src/: documentation is exposed so that Haddock can process it. - * No interface changes. + * Version bump (0.9.4). + * New maintainer. + * Documentation is exposed so that Haddock can process it. + * No interface changes. Copyright (c) 2003, Henrik Nilsson, Antony Courtney and Yale University. All rights reserved. diff --git a/Yampa.cabal b/Yampa.cabal --- a/Yampa.cabal +++ b/Yampa.cabal @@ -30,7 +30,7 @@ build-type: Simple name: Yampa -version: 0.14.2 +version: 0.14.3 author: Henrik Nilsson, Antony Courtney maintainer: Ivan Perez (ivan.perez@keera.co.uk) homepage: https://github.com/ivanperez-keera/Yampa/ diff --git a/src/FRP/Yampa.hs b/src/FRP/Yampa.hs --- a/src/FRP/Yampa.hs +++ b/src/FRP/Yampa.hs @@ -237,13 +237,13 @@ -- ** Parallel composition and switching -- *** Parallel composition and switching with broadcasting , parB - , pSwitchB,dpSwitchB - , rpSwitchB,drpSwitchB + , pSwitchB, dpSwitchB + , rpSwitchB, drpSwitchB -- *** Parallel composition and switching with general routing , par - , pSwitch, dpSwitch - , rpSwitch,drpSwitch + , pSwitch, dpSwitch + , rpSwitch, drpSwitch -- * Discrete to continuous-time signal functions -- ** Wave-form generation @@ -317,13 +317,18 @@ -- Reverse function composition and arrow plumbing aids , dup - -- Re-exported module, classes, and types + -- * Re-exported module, classes, and types , module Control.Arrow , module Data.VectorSpace ) where -import FRP.Yampa.InternalCore +-- External modules +import Control.Arrow +import Data.VectorSpace + +-- Internal modules +import FRP.Yampa.Arrow (dup) import FRP.Yampa.Basic import FRP.Yampa.Conditional import FRP.Yampa.Delays @@ -331,13 +336,10 @@ import FRP.Yampa.EventS import FRP.Yampa.Hybrid import FRP.Yampa.Integration +import FRP.Yampa.InternalCore import FRP.Yampa.Loop -import FRP.Yampa.Arrow (dup) import FRP.Yampa.Random import FRP.Yampa.Scan import FRP.Yampa.Simulation import FRP.Yampa.Switches import FRP.Yampa.Time - -import Control.Arrow -import Data.VectorSpace diff --git a/src/FRP/Yampa/Arrow.hs b/src/FRP/Yampa/Arrow.hs --- a/src/FRP/Yampa/Arrow.hs +++ b/src/FRP/Yampa/Arrow.hs @@ -1,14 +1,14 @@ -- | --- Module : FRP.Yampa.Arrow --- Copyright : (c) Ivan Perez, 2014-2022 --- (c) George Giorgidze, 2007-2012 --- (c) Henrik Nilsson, 2005-2006 --- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 --- License : BSD-style (see the LICENSE file in the distribution) +-- Module : FRP.Yampa.Arrow +-- Copyright : (c) Ivan Perez, 2014-2022 +-- (c) George Giorgidze, 2007-2012 +-- (c) Henrik Nilsson, 2005-2006 +-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 +-- License : BSD-style (see the LICENSE file in the distribution) -- --- Maintainer : ivan.perez@keera.co.uk --- Stability : provisional --- Portability : portable +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : portable -- -- Arrow helper functions. module FRP.Yampa.Arrow @@ -24,28 +24,29 @@ ) where -import Control.Arrow +-- External imports +import Control.Arrow (Arrow, arr) -- * Arrow plumbing aids -- | Duplicate an input. -dup :: a -> (a,a) -dup x = (x,x) +dup :: a -> (a, a) +dup x = (x, x) -- * Liftings --- | Lift a binary function onto an arrow +-- | Lift a binary function onto an arrow. arr2 :: Arrow a => (b -> c -> d) -> a (b, c) d arr2 = arr . uncurry --- | Lift a 3-ary function onto an arrow +-- | Lift a 3-ary function onto an arrow. arr3 :: Arrow a => (b -> c -> d -> e) -> a (b, c, d) e arr3 = arr . \h (b, c, d) -> h b c d --- | Lift a 4-ary function onto an arrow +-- | Lift a 4-ary function onto an arrow. arr4 :: Arrow a => (b -> c -> d -> e -> f) -> a (b, c, d, e) f arr4 = arr . \h (b, c, d, e) -> h b c d e --- | Lift a 5-ary function onto an arrow +-- | Lift a 5-ary function onto an arrow. arr5 :: Arrow a => (b -> c -> d -> e -> f -> g) -> a (b, c, d, e, f) g arr5 = arr . \h (b, c, d, e, f) -> h b c d e f diff --git a/src/FRP/Yampa/Basic.hs b/src/FRP/Yampa/Basic.hs --- a/src/FRP/Yampa/Basic.hs +++ b/src/FRP/Yampa/Basic.hs @@ -1,14 +1,14 @@ -- | --- Module : FRP.Yampa.Basic --- Copyright : (c) Ivan Perez, 2014-2022 --- (c) George Giorgidze, 2007-2012 --- (c) Henrik Nilsson, 2005-2006 --- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 --- License : BSD-style (see the LICENSE file in the distribution) +-- Module : FRP.Yampa.Basic +-- Copyright : (c) Ivan Perez, 2014-2022 +-- (c) George Giorgidze, 2007-2012 +-- (c) Henrik Nilsson, 2005-2006 +-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 +-- License : BSD-style (see the LICENSE file in the distribution) -- --- Maintainer : ivan.perez@keera.co.uk --- Stability : provisional --- Portability : non-portable (GHC extensions) +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) -- -- Defines basic signal functions, and elementary ways of altering them. -- @@ -16,8 +16,8 @@ -- functions. In particular, it defines ways of creating constant output -- producing SFs, and SFs that just pass the signal through unmodified. -- --- It also defines ways of altering the input and the output signal only --- by inserting one value in the signal, or by transforming it. +-- It also defines ways of altering the input and the output signal only by +-- inserting one value in the signal, or by transforming it. module FRP.Yampa.Basic ( -- * Basic signal functions @@ -34,6 +34,7 @@ ) where +-- Internal imports import FRP.Yampa.InternalCore (SF(..), SF'(..), sfConst, sfId) infixr 0 -->, -:>, >--, -=>, >=- @@ -61,40 +62,37 @@ -- | Initialization operator (cf. Lustre/Lucid Synchrone). -- --- The output at time zero is the first argument, and from --- that point on it behaves like the signal function passed as --- second argument. +-- The output at time zero is the first argument, and from that point on it +-- behaves like the signal function passed as second argument. (-->) :: b -> SF a b -> SF a b b0 --> (SF {sfTF = tf10}) = SF {sfTF = \a0 -> (fst (tf10 a0), b0)} -- | Output pre-insert operator. -- --- Insert a sample in the output, and from that point on, behave --- like the given sf. +-- Insert a sample in the output, and from that point on, behave like the given +-- sf. (-:>) :: b -> SF a b -> SF a b b0 -:> (SF {sfTF = tf10}) = SF {sfTF = \_a0 -> (ct, b0)} - where ct = SF' $ \_dt a0 -> tf10 a0 + where + ct = SF' $ \_dt a0 -> tf10 a0 -- | Input initialization operator. -- --- The input at time zero is the first argument, and from --- that point on it behaves like the signal function passed as --- second argument. +-- The input at time zero is the first argument, and from that point on it +-- behaves like the signal function passed as second argument. (>--) :: a -> SF a b -> SF a b a0 >-- (SF {sfTF = tf10}) = SF {sfTF = \_ -> tf10 a0} -- | Transform initial output value. -- --- Applies a transformation 'f' only to the first output value at --- time zero. +-- Applies a transformation 'f' only to the first output value at time zero. (-=>) :: (b -> b) -> SF a b -> SF a b f -=> (SF {sfTF = tf10}) = SF {sfTF = \a0 -> let (sf1, b0) = tf10 a0 in (sf1, f b0)} -- | Transform initial input value. -- --- Applies a transformation 'f' only to the first input value at --- time zero. +-- Applies a transformation 'f' only to the first input value at time zero. {-# ANN (>=-) "HLint: ignore Avoid lambda" #-} (>=-) :: (a -> a) -> SF a b -> SF a b f >=- (SF {sfTF = tf10}) = SF {sfTF = \a0 -> tf10 (f a0)} diff --git a/src/FRP/Yampa/Conditional.hs b/src/FRP/Yampa/Conditional.hs --- a/src/FRP/Yampa/Conditional.hs +++ b/src/FRP/Yampa/Conditional.hs @@ -1,28 +1,34 @@ -- | --- Module : FRP.Yampa --- Copyright : (c) Ivan Perez, 2014-2022 --- (c) George Giorgidze, 2007-2012 --- (c) Henrik Nilsson, 2005-2006 --- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 --- License : BSD-style (see the LICENSE file in the distribution) +-- Module : FRP.Yampa +-- Copyright : (c) Ivan Perez, 2014-2022 +-- (c) George Giorgidze, 2007-2012 +-- (c) Henrik Nilsson, 2005-2006 +-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 +-- License : BSD-style (see the LICENSE file in the distribution) -- --- Maintainer : ivan.perez@keera.co.uk --- Stability : provisional --- Portability : non-portable (GHC extensions) +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) -- -- Apply SFs only under certain conditions. module FRP.Yampa.Conditional - ( provided + ( + -- * Guards and automata-oriented combinators + provided + + -- * Variable pause , pause ) where -import Control.Arrow +-- External imports +import Control.Arrow ((&&&), (^>>)) -import FRP.Yampa.Basic -import FRP.Yampa.EventS +-- Internal imports +import FRP.Yampa.Basic (constant) +import FRP.Yampa.EventS (edge, snap) import FRP.Yampa.InternalCore (SF (..), SF' (..), Transition, sfTF') -import FRP.Yampa.Switches +import FRP.Yampa.Switches (switch) -- * Guards and automata-oriented combinators @@ -34,12 +40,10 @@ -- -- For example, the following integrates the incoming input numbers, using one -- integral if the numbers are even, and another if the input numbers are odd. --- Note how, every time we "switch", the old value of the integral is --- discarded. +-- Note how, every time we "switch", the old value of the integral is discarded. -- -- >>> embed (provided (even . round) integral integral) (deltaEncode 1 [1, 1, 1, 2, 2, 2, 1, 1, 1, 2, 2, 2 :: Double]) -- [0.0,1.0,2.0,0.0,2.0,4.0,0.0,1.0,2.0,0.0,2.0,4.0] - provided :: (a -> Bool) -> SF a b -> SF a b -> SF a b provided p sft sff = switch (constant undefined &&& snap) $ \a0 -> @@ -50,36 +54,39 @@ -- * Variable pause --- | Given a value in an accumulator (b), a predicate signal function (sfC), --- and a second signal function (sf), pause will produce the accumulator b --- if sfC input is True, and will transform the signal using sf otherwise. --- It acts as a pause with an accumulator for the moments when the --- transformation is paused. +-- | Given a value in an accumulator (b), a predicate signal function (sfC), and +-- a second signal function (sf), pause will produce the accumulator b if sfC +-- input is True, and will transform the signal using sf otherwise. It acts as +-- a pause with an accumulator for the moments when the transformation is +-- paused. pause :: b -> SF a Bool -> SF a b -> SF a b -pause b_init (SF { sfTF = tfP}) (SF {sfTF = tf10}) = SF {sfTF = tf0} +pause bInit (SF { sfTF = tfP}) (SF {sfTF = tf10}) = SF {sfTF = tf0} where - -- Initial transformation (no time delta): - -- If the condition is True, return the accumulator b_init) - -- Otherwise transform the input normally and recurse. + -- Initial transformation (no time delta): If the condition is True, return + -- the accumulator bInit) Otherwise transform the input normally and + -- recurse. tf0 a0 = case tfP a0 of - (c, True) -> (pauseInit b_init tf10 c, b_init) - (c, False) -> let (k, b0) = tf10 a0 - in (pause' b0 k c, b0) + (c, True) -> (pauseInit bInit tf10 c, bInit) + (c, False) -> (pause' b0 k c, b0) + where + (k, b0) = tf10 a0 -- Similar deal, but with a time delta pauseInit :: b -> (a -> Transition a b) -> SF' a Bool -> SF' a b - pauseInit b_init' tf10' c = SF' tf0' - where tf0' dt a = - case (sfTF' c) dt a of - (c', True) -> (pauseInit b_init' tf10' c', b_init') - (c', False) -> let (k, b0) = tf10' a - in (pause' b0 k c', b0) + pauseInit bInit' tf10' c = SF' tf0' + where + tf0' dt a = case (sfTF' c) dt a of + (c', True) -> (pauseInit bInit' tf10' c', bInit') + (c', False) -> (pause' b0 k c', b0) + where + (k, b0) = tf10' a -- Very same deal (almost alpha-renameable) pause' :: b -> SF' a b -> SF' a Bool -> SF' a b - pause' b_init' tf10' tfP' = SF' tf0' - where tf0' dt a = - case (sfTF' tfP') dt a of - (tfP'', True) -> (pause' b_init' tf10' tfP'', b_init') - (tfP'', False) -> let (tf10'', b0') = (sfTF' tf10') dt a - in (pause' b0' tf10'' tfP'', b0') + pause' bInit' tf10' tfP' = SF' tf0' + where + tf0' dt a = case (sfTF' tfP') dt a of + (tfP'', True) -> (pause' bInit' tf10' tfP'', bInit') + (tfP'', False) -> (pause' b0' tf10'' tfP'', b0') + where + (tf10'', b0') = (sfTF' tf10') dt a diff --git a/src/FRP/Yampa/Delays.hs b/src/FRP/Yampa/Delays.hs --- a/src/FRP/Yampa/Delays.hs +++ b/src/FRP/Yampa/Delays.hs @@ -1,14 +1,14 @@ -- | --- Module : FRP.Yampa.Delays --- Copyright : (c) Ivan Perez, 2014-2022 --- (c) George Giorgidze, 2007-2012 --- (c) Henrik Nilsson, 2005-2006 --- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 --- License : BSD-style (see the LICENSE file in the distribution) +-- Module : FRP.Yampa.Delays +-- Copyright : (c) Ivan Perez, 2014-2022 +-- (c) George Giorgidze, 2007-2012 +-- (c) Henrik Nilsson, 2005-2006 +-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 +-- License : BSD-style (see the LICENSE file in the distribution) -- --- Maintainer : ivan.perez@keera.co.uk --- Stability : provisional --- Portability : non-portable (GHC extensions) +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) -- -- SF primitives and combinators to delay signals, introducing new values in -- them. @@ -24,12 +24,14 @@ ) where -import Control.Arrow +-- External imports +import Control.Arrow ((>>>)) -import FRP.Yampa.Basic -import FRP.Yampa.Diagnostics +-- Internal imports +import FRP.Yampa.Basic (identity, (-->)) +import FRP.Yampa.Diagnostics (usrErr) import FRP.Yampa.InternalCore (SF (..), SF' (..), Time) -import FRP.Yampa.Scan +import FRP.Yampa.Scan (sscanPrim) infixr 0 `fby` @@ -37,8 +39,8 @@ -- | Uninitialized delay operator. -- --- The output has an infinitesimal delay (1 sample), and the value at time --- zero is undefined. +-- The output has an infinitesimal delay (1 sample), and the value at time zero +-- is undefined. pre :: SF a a pre = sscanPrim f uninit uninit where @@ -48,17 +50,16 @@ -- | Initialized delay operator. -- -- Creates an SF that delays the input signal, introducing an infinitesimal --- delay (one sample), using the given argument to fill in the initial output --- at time zero. - +-- delay (one sample), using the given argument to fill in the initial output at +-- time zero. iPre :: a -> SF a a iPre = (--> pre) -- | Lucid-Synchrone-like initialized delay (read "followed by"). -- --- Initialized delay combinator, introducing an infinitesimal delay (one --- sample) in given 'SF', using the given argument to fill in the initial --- output at time zero. +-- Initialized delay combinator, introducing an infinitesimal delay (one sample) +-- in given 'SF', using the given argument to fill in the initial output at time +-- zero. -- -- The difference with 'iPre' is that 'fby' takes an 'SF' as argument. fby :: b -> SF a b -> SF a b @@ -66,37 +67,35 @@ -- * Timed delays --- | Delay a signal by a fixed time 't', using the second parameter --- to fill in the initial 't' seconds. +-- | Delay a signal by a fixed time 't', using the second parameter to fill in +-- the initial 't' seconds. delay :: Time -> a -> SF a a -delay q a_init | q < 0 = usrErr "Yampa" "delay" "Negative delay." - | q == 0 = identity - | otherwise = SF {sfTF = tf0} +delay q aInit | q < 0 = usrErr "Yampa" "delay" "Negative delay." + | q == 0 = identity + | otherwise = SF {sfTF = tf0} where - tf0 a0 = (delayAux [] [(q, a0)] 0 a_init, a_init) + tf0 a0 = (delayAux [] [(q, a0)] 0 aInit, aInit) -- Invariants: - -- t_diff measure the time since the latest output sample ideally - -- should have been output. Whenever that equals or exceeds the - -- time delta for the next buffered sample, it is time to output a - -- new sample (although not necessarily the one first in the queue: - -- it might be necessary to "catch up" by discarding samples. - -- 0 <= t_diff < bdt, where bdt is the buffered time delta for the - -- sample on the front of the buffer queue. + -- tDiff measure the time since the latest output sample ideally should have + -- been output. Whenever that equals or exceeds the time delta for the next + -- buffered sample, it is time to output a new sample (although not + -- necessarily the one first in the queue: it might be necessary to "catch + -- up" by discarding samples. 0 <= tDiff < bdt, where bdt is the buffered + -- time delta for the sample on the front of the buffer queue. -- -- Sum of time deltas in the queue >= q. delayAux _ [] _ _ = undefined - delayAux rbuf buf@((bdt, ba) : buf') t_diff a_prev = SF' tf -- True + delayAux rbuf buf@((bdt, ba) : buf') tDiff aPrev = SF' tf -- True where - tf dt a | t_diff' < bdt = - (delayAux rbuf' buf t_diff' a_prev, a_prev) - | otherwise = nextSmpl rbuf' buf' (t_diff' - bdt) ba + tf dt a | tDiff' < bdt = (delayAux rbuf' buf tDiff' aPrev, aPrev) + | otherwise = nextSmpl rbuf' buf' (tDiff' - bdt) ba where - t_diff' = t_diff + dt - rbuf' = (dt, a) : rbuf + tDiff' = tDiff + dt + rbuf' = (dt, a) : rbuf - nextSmpl rbuf [] t_diff a = - nextSmpl [] (reverse rbuf) t_diff a - nextSmpl rbuf buf@((bdt, ba) : buf') t_diff a - | t_diff < bdt = (delayAux rbuf buf t_diff a, a) - | otherwise = nextSmpl rbuf buf' (t_diff-bdt) ba + nextSmpl rbuf [] tDiff a = + nextSmpl [] (reverse rbuf) tDiff a + nextSmpl rbuf buf@((bdt, ba) : buf') tDiff a + | tDiff < bdt = (delayAux rbuf buf tDiff a, a) + | otherwise = nextSmpl rbuf buf' (tDiff - bdt) ba diff --git a/src/FRP/Yampa/Diagnostics.hs b/src/FRP/Yampa/Diagnostics.hs --- a/src/FRP/Yampa/Diagnostics.hs +++ b/src/FRP/Yampa/Diagnostics.hs @@ -1,17 +1,21 @@ -- | --- Module : FRP.Yampa.Diagnostics --- Copyright : (c) Ivan Perez, 2014-2022 --- (c) George Giorgidze, 2007-2012 --- (c) Henrik Nilsson, 2005-2006 --- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 --- License : BSD-style (see the LICENSE file in the distribution) +-- Module : FRP.Yampa.Diagnostics +-- Copyright : (c) Ivan Perez, 2014-2022 +-- (c) George Giorgidze, 2007-2012 +-- (c) Henrik Nilsson, 2005-2006 +-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 +-- License : BSD-style (see the LICENSE file in the distribution) -- --- Maintainer : ivan.perez@keera.co.uk --- Stability : provisional --- Portability : portable +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : portable -- --- Standardized error-reporting for Yampa -module FRP.Yampa.Diagnostics where +-- Standardized error-reporting for Yampa. +module FRP.Yampa.Diagnostics + ( usrErr + , intErr + ) + where -- | Reports an error due to a violation of Yampa's preconditions/requirements. usrErr :: String -> String -> String -> a diff --git a/src/FRP/Yampa/Event.hs b/src/FRP/Yampa/Event.hs --- a/src/FRP/Yampa/Event.hs +++ b/src/FRP/Yampa/Event.hs @@ -13,9 +13,9 @@ -- Portability : portable -- -- Events in Yampa represent discrete time-signals, meaning those that do not --- change continuously. Examples of event-carrying signals would be mouse --- clicks (in between clicks it is assumed that there is no click), some --- keyboard events, button presses on wiimotes or window-manager events. +-- change continuously. Examples of event-carrying signals would be mouse clicks +-- (in between clicks it is assumed that there is no click), some keyboard +-- events, button presses on wiimotes or window-manager events. -- -- The type 'Event' is isomorphic to 'Maybe' (@Event a = NoEvent | Event a@) -- but, semantically, a 'Maybe'-carrying signal could change continuously, @@ -27,13 +27,56 @@ -- -- Events are essential for many other Yampa constructs, like switches (see -- 'FRP.Yampa.Switches.switch' for details). -module FRP.Yampa.Event where +module FRP.Yampa.Event + ( + -- * The Event type + Event(..) + , noEvent + , noEventFst + , noEventSnd -import Control.Applicative + -- * Internal utilities for event construction + , maybeToEvent + + -- * Utility functions similar to those available for Maybe + , event + , fromEvent + , isEvent + , isNoEvent + + -- * Event tagging + , tag + , tagWith + , attach + + -- * Event merging (disjunction) and joining (conjunction) + , lMerge + , rMerge + , merge + , mergeBy + , mapMerge + , mergeEvents + , catEvents + , joinE + , splitE + + -- * Event filtering + , filterE + , mapFilterE + , gate + ) + where + +-- External imports +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative (Applicative (..), (<$>)) +#endif +import Control.Applicative (Alternative (..)) import Control.DeepSeq (NFData (..)) import qualified Control.Monad.Fail as Fail -import FRP.Yampa.Diagnostics +-- Internal imports +import FRP.Yampa.Diagnostics (usrErr) infixl 8 `tag`, `attach`, `gate` infixl 7 `joinE` @@ -41,8 +84,8 @@ -- * The Event type --- | A single possible event occurrence, that is, a value that may or may --- not occur. Events are used to represent values that are not produced +-- | A single possible event occurrence, that is, a value that may or may not +-- occur. Events are used to represent values that are not produced -- continuously, such as mouse clicks (only produced when the mouse is clicked, -- as opposed to mouse positions, which are always defined). data Event a = NoEvent | Event a deriving (Show) @@ -60,16 +103,16 @@ noEventSnd :: (a, Event b) -> (a, Event c) noEventSnd (a, _) = (a, NoEvent) --- | Eq instance (equivalent to derived instance) +-- | Eq instance (equivalent to derived instance). instance Eq a => Eq (Event a) where -- | Equal if both NoEvent or both Event carrying equal values. NoEvent == NoEvent = True (Event x) == (Event y) = x == y _ == _ = False --- | Ord instance (equivalent to derived instance) +-- | Ord instance (equivalent to derived instance). instance Ord a => Ord (Event a) where - -- | NoEvent is smaller than Event, Event x < Event y if x < y + -- | NoEvent is smaller than Event, Event x < Event y if x < y. compare NoEvent NoEvent = EQ compare NoEvent (Event _) = LT compare (Event _) NoEvent = GT @@ -89,37 +132,36 @@ NoEvent <*> _ = NoEvent Event f <*> x = f <$> x --- | Monad instance +-- | Monad instance. instance Monad Event where - -- | Combine events, return 'NoEvent' if any value in the - -- sequence is 'NoEvent'. + -- | Combine events, return 'NoEvent' if any value in the sequence is + -- 'NoEvent'. (Event x) >>= k = k x - NoEvent >>= _ = NoEvent + NoEvent >>= _ = NoEvent (>>) = (*>) -- | See 'pure'. - return = pure + return = pure #if !(MIN_VERSION_base(4,13,0)) -- | Fail with 'NoEvent'. - fail = Fail.fail + fail = Fail.fail #endif instance Fail.MonadFail Event where -- | Fail with 'NoEvent'. - fail _ = NoEvent + fail _ = NoEvent --- | Alternative instance +-- | Alternative instance. instance Alternative Event where -- | An empty alternative carries no event, so it is ignored. empty = NoEvent - -- | Merge favouring the left event ('NoEvent' only if both are - -- 'NoEvent'). + -- | Merge favouring the left event ('NoEvent' only if both are 'NoEvent'). NoEvent <|> r = r l <|> _ = l --- | NFData instance +-- | NFData instance. instance NFData a => NFData (Event a) where -- | Evaluate value carried by event. rnf NoEvent = () @@ -127,8 +169,8 @@ -- * Internal utilities for event construction --- These utilities are to be considered strictly internal to Yampa for the --- time being. +-- These utilities are to be considered strictly internal to Yampa for the time +-- being. -- | Convert a maybe value into a event ('Event' is isomorphic to 'Maybe'). maybeToEvent :: Maybe a -> Event a @@ -160,16 +202,14 @@ -- | Tags an (occurring) event with a value ("replacing" the old value). -- --- Applicative-based definition: --- tag = ($>) +-- Applicative-based definition: tag = ($>) tag :: Event a -> b -> Event b e `tag` b = fmap (const b) e --- | Tags an (occurring) event with a value ("replacing" the old value). Same --- as 'tag' with the arguments swapped. +-- | Tags an (occurring) event with a value ("replacing" the old value). Same as +-- 'tag' with the arguments swapped. -- --- Applicative-based definition: --- tagWith = (<$) +-- Applicative-based definition: tagWith = (<$) tagWith :: b -> Event a -> Event b tagWith = flip tag @@ -201,10 +241,10 @@ mergeBy _ NoEvent re@(Event _) = re mergeBy resolve (Event l) (Event r) = Event (resolve l r) --- | A generic event merge-map utility that maps event occurrences, --- merging the results. The first three arguments are mapping functions, --- the third of which will only be used when both events are present. --- Therefore, 'mergeBy' = 'mapMerge' 'id' 'id' +-- | A generic event merge-map utility that maps event occurrences, merging the +-- results. The first three arguments are mapping functions, the third of which +-- will only be used when both events are present. Therefore, 'mergeBy' = +-- 'mapMerge' 'id' 'id'. -- -- Applicative-based definition: -- mapMerge lf rf lrf le re = (f <$> le <*> re) <|> (lf <$> le) <|> (rf <$> re) @@ -233,20 +273,20 @@ [] -> NoEvent as -> Event as --- | Join (conjunction) of two events. Only produces an event --- if both events exist. +-- | Join (conjunction) of two events. Only produces an event if both events +-- exist. -- -- Applicative-based definition: -- joinE = liftA2 (,) -joinE :: Event a -> Event b -> Event (a,b) +joinE :: Event a -> Event b -> Event (a, b) joinE NoEvent _ = NoEvent joinE _ NoEvent = NoEvent -joinE (Event l) (Event r) = Event (l,r) +joinE (Event l) (Event r) = Event (l, r) -- | Split event carrying pairs into two events. -splitE :: Event (a,b) -> (Event a, Event b) -splitE NoEvent = (NoEvent, NoEvent) -splitE (Event (a,b)) = (Event a, Event b) +splitE :: Event (a, b) -> (Event a, Event b) +splitE NoEvent = (NoEvent, NoEvent) +splitE (Event (a, b)) = (Event a, Event b) -- * Event filtering diff --git a/src/FRP/Yampa/EventS.hs b/src/FRP/Yampa/EventS.hs --- a/src/FRP/Yampa/EventS.hs +++ b/src/FRP/Yampa/EventS.hs @@ -1,14 +1,14 @@ -- | --- Module : FRP.Yampa.EventS --- Copyright : (c) Ivan Perez, 2014-2022 --- (c) George Giorgidze, 2007-2012 --- (c) Henrik Nilsson, 2005-2006 --- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 --- License : BSD-style (see the LICENSE file in the distribution) +-- Module : FRP.Yampa.EventS +-- Copyright : (c) Ivan Perez, 2014-2022 +-- (c) George Giorgidze, 2007-2012 +-- (c) Henrik Nilsson, 2005-2006 +-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 +-- License : BSD-style (see the LICENSE file in the distribution) -- --- Maintainer : ivan.perez@keera.co.uk --- Stability : provisional --- Portability : non-portable (GHC extensions) +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) -- -- Event Signal Functions and SF combinators. -- @@ -54,16 +54,18 @@ ) where -import Control.Arrow +-- External imports +import Control.Arrow (arr, (&&&), (>>>), (>>^)) -import FRP.Yampa.Arrow -import FRP.Yampa.Basic -import FRP.Yampa.Diagnostics -import FRP.Yampa.Event -import FRP.Yampa.Hybrid +-- Internal imports +import FRP.Yampa.Arrow (dup) +import FRP.Yampa.Basic (identity, initially, (-->), (>--)) +import FRP.Yampa.Diagnostics (usrErr) +import FRP.Yampa.Event (Event (..), maybeToEvent, tag) +import FRP.Yampa.Hybrid (accumBy) import FRP.Yampa.InternalCore (SF (..), SF' (..), Time, sfConst) -import FRP.Yampa.Scan -import FRP.Yampa.Switches +import FRP.Yampa.Scan (sscanPrim) +import FRP.Yampa.Switches (dSwitch, switch) infixr 5 `andThen` @@ -77,8 +79,8 @@ sfNever :: SF' a (Event b) sfNever = sfConst NoEvent --- | Event source with a single occurrence at time 0. The value of the event --- is given by the function argument. +-- | Event source with a single occurrence at time 0. The value of the event is +-- given by the function argument. now :: b -> SF a (Event b) now b0 = Event b0 --> never @@ -87,32 +89,32 @@ after :: Time -- ^ The time /q/ after which the event should be produced -> b -- ^ Value to produce at that time -> SF a (Event b) -after q x = afterEach [(q,x)] +after q x = afterEach [(q, x)] -- | Event source with repeated occurrences with interval q. --- Note: If the interval is too short w.r.t. the sampling intervals, --- the result will be that events occur at every sample. However, no more --- than one event results from any sampling interval, thus avoiding an --- "event backlog" should sampling become more frequent at some later --- point in time. +-- +-- Note: If the interval is too short w.r.t. the sampling intervals, the result +-- will be that events occur at every sample. However, no more than one event +-- results from any sampling interval, thus avoiding an "event backlog" should +-- sampling become more frequent at some later point in time. repeatedly :: Time -> b -> SF a (Event b) -repeatedly q x | q > 0 = afterEach qxs +repeatedly q x | q > 0 = afterEach qxs | otherwise = usrErr "Yampa" "repeatedly" "Non-positive period." where - qxs = (q,x):qxs + qxs = (q, x) : qxs --- | Event source with consecutive occurrences at the given intervals. --- Should more than one event be scheduled to occur in any sampling interval, --- only the first will in fact occur to avoid an event backlog. -afterEach :: [(Time,b)] -> SF a (Event b) +-- | Event source with consecutive occurrences at the given intervals. Should +-- more than one event be scheduled to occur in any sampling interval, only the +-- first will in fact occur to avoid an event backlog. +afterEach :: [(Time, b)] -> SF a (Event b) afterEach qxs = afterEachCat qxs >>> arr (fmap head) --- | Event source with consecutive occurrences at the given intervals. --- Should more than one event be scheduled to occur in any sampling interval, --- the output list will contain all events produced during that interval. -afterEachCat :: [(Time,b)] -> SF a (Event [b]) +-- | Event source with consecutive occurrences at the given intervals. Should +-- more than one event be scheduled to occur in any sampling interval, the +-- output list will contain all events produced during that interval. +afterEachCat :: [(Time, b)] -> SF a (Event [b]) afterEachCat [] = never -afterEachCat ((q,x):qxs) +afterEachCat ((q, x) : qxs) | q < 0 = usrErr "Yampa" "afterEachCat" "Negative period." | otherwise = SF {sfTF = tf0} where @@ -121,12 +123,13 @@ else (awaitNextEvent (-q) x qxs, NoEvent) emitEventsScheduleNext _ xs [] = (sfNever, Event (reverse xs)) - emitEventsScheduleNext t xs ((q,x):qxs) + emitEventsScheduleNext t xs ((q, x) : qxs) | q < 0 = usrErr "Yampa" "afterEachCat" "Negative period." | t' >= 0 = emitEventsScheduleNext t' (x:xs) qxs | otherwise = (awaitNextEvent t' x qxs, Event (reverse xs)) where t' = t - q + awaitNextEvent t x qxs = SF' tf -- False where tf dt _ | t' >= 0 = emitEventsScheduleNext t' [x] qxs @@ -161,71 +164,70 @@ , NoEvent ) - -- t_next is the present time w.r.t. the next scheduled event. - -- t_last is the present time w.r.t. the last scheduled event. + -- tNext is the present time w.r.t. the next scheduled event. + -- tLast is the present time w.r.t. the last scheduled event. -- In the event queues, events are associated with their time -- w.r.t. to preceding event (positive). - pendingEvents t_last rqxs qxs t_next x = SF' tf -- True + pendingEvents tLast rqxs qxs tNext x = SF' tf -- True where tf dt e - | t_next' >= 0 - = emitEventsScheduleNext e t_last' rqxs qxs t_next' [x] + | tNext' >= 0 + = emitEventsScheduleNext e tLast' rqxs qxs tNext' [x] | otherwise - = (pendingEvents t_last'' rqxs' qxs t_next' x, NoEvent) + = (pendingEvents tLast'' rqxs' qxs tNext' x, NoEvent) where - t_next' = t_next + dt - t_last' = t_last + dt - (t_last'', rqxs') = + tNext' = tNext + dt + tLast' = tLast + dt + (tLast'', rqxs') = case e of - NoEvent -> (t_last', rqxs) - Event x' -> (-q, (t_last'+q,x') : rqxs) + NoEvent -> (tLast', rqxs) + Event x' -> (-q, (tLast' + q, x') : rqxs) - -- t_next is the present time w.r.t. the *scheduled* time of the - -- event that is about to be emitted (i.e. >= 0). - -- The time associated with any event at the head of the event - -- queue is also given w.r.t. the event that is about to be emitted. - -- Thus, t_next - q' is the present time w.r.t. the event at the head - -- of the event queue. + -- tNext is the present time w.r.t. the *scheduled* time of the event that + -- is about to be emitted (i.e. >= 0). + -- The time associated with any event at the head of the event queue is also + -- given w.r.t. the event that is about to be emitted. Thus, tNext - q' is + -- the present time w.r.t. the event at the head of the event queue. emitEventsScheduleNext e _ [] [] _ rxs = ( case e of NoEvent -> noPendingEvent Event x -> pendingEvents (-q) [] [] (-q) x , Event (reverse rxs) ) - emitEventsScheduleNext e t_last rqxs [] t_next rxs = - emitEventsScheduleNext e t_last [] (reverse rqxs) t_next rxs - emitEventsScheduleNext e t_last rqxs ((q', x') : qxs') t_next rxs - | q' > t_next = ( case e of - NoEvent -> - pendingEvents t_last - rqxs - qxs' - (t_next - q') - x' - Event x'' -> - pendingEvents (-q) - ((t_last+q, x'') : rqxs) - qxs' - (t_next - q') - x' + emitEventsScheduleNext e tLast rqxs [] tNext rxs = + emitEventsScheduleNext e tLast [] (reverse rqxs) tNext rxs + emitEventsScheduleNext e tLast rqxs ((q', x') : qxs') tNext rxs + | q' > tNext = ( case e of + NoEvent -> + pendingEvents tLast + rqxs + qxs' + (tNext - q') + x' + Event x'' -> + pendingEvents (-q) + ((tLast + q, x'') : rqxs) + qxs' + (tNext - q') + x' , Event (reverse rxs) ) - | otherwise = emitEventsScheduleNext e - t_last - rqxs - qxs' - (t_next - q') - (x' : rxs) + | otherwise = emitEventsScheduleNext e + tLast + rqxs + qxs' + (tNext - q') + (x' : rxs) --- | A rising edge detector. Useful for things like detecting key presses. --- It is initialised as /up/, meaning that events occurring at time 0 will --- not be detected. +-- | A rising edge detector. Useful for things like detecting key presses. It is +-- initialised as /up/, meaning that events occurring at time 0 will not be +-- detected. edge :: SF Bool (Event ()) edge = iEdge True --- | A rising edge detector that can be initialized as up ('True', meaning --- that events occurring at time 0 will not be detected) or down --- ('False', meaning that events occurring at time 0 will be detected). +-- | A rising edge detector that can be initialized as up ('True', meaning that +-- events occurring at time 0 will not be detected) or down ('False', meaning +-- that events occurring at time 0 will be detected). iEdge :: Bool -> SF Bool (Event ()) iEdge b = sscanPrim f (if b then 2 else 0) NoEvent where @@ -242,8 +244,8 @@ edgeTag :: a -> SF Bool (Event a) edgeTag a = edge >>> arr (`tag` a) --- | Edge detector particularized for detecting transitions --- on a 'Maybe' signal from 'Nothing' to 'Just'. +-- | Edge detector particularized for detecting transitions on a 'Maybe' signal +-- from 'Nothing' to 'Just'. edgeJust :: SF (Maybe a) (Event a) edgeJust = edgeBy isJustEdge (Just undefined) where @@ -253,16 +255,16 @@ isJustEdge (Just _) Nothing = Nothing -- | Edge detector parameterized on the edge detection function and initial --- state, i.e., the previous input sample. The first argument to the --- edge detection function is the previous sample, the second the current one. +-- state, i.e., the previous input sample. The first argument to the edge +-- detection function is the previous sample, the second the current one. edgeBy :: (a -> a -> Maybe b) -> a -> SF a (Event b) -edgeBy isEdge a_init = SF {sfTF = tf0} +edgeBy isEdge aInit = SF {sfTF = tf0} where - tf0 a0 = (ebAux a0, maybeToEvent (isEdge a_init a0)) + tf0 a0 = (ebAux a0, maybeToEvent (isEdge aInit a0)) - ebAux a_prev = SF' tf -- True + ebAux aPrev = SF' tf -- True where - tf _ a = (ebAux a, maybeToEvent (isEdge a_prev a)) + tf _ a = (ebAux a, maybeToEvent (isEdge aPrev a)) -- * Stateful event suppression @@ -281,7 +283,7 @@ -- | Suppress first n events. dropEvents :: Int -> SF (Event a) (Event a) -dropEvents n | n <= 0 = identity +dropEvents n | n <= 0 = identity dropEvents n = -- Here dSwitch or switch does not really matter. dSwitch (never &&& identity) @@ -298,24 +300,23 @@ switch (never &&& (identity &&& now () >>^ \(a, e) -> e `tag` a)) now -- | Event source with a single occurrence at or as soon after (local) time --- @t_ev@ as possible. The value of the event is obtained by sampling the input --- a that time. +-- @tEv@ as possible. The value of the event is obtained by sampling the input a +-- that time. snapAfter :: Time -> SF a (Event a) -snapAfter t_ev = - switch (never &&& (identity &&& after t_ev () >>^ \(a, e) -> e `tag` a)) now +snapAfter tEv = + switch (never &&& (identity &&& after tEv () >>^ \(a, e) -> e `tag` a)) now -- | Sample a signal at regular intervals. sample :: Time -> SF a (Event a) -sample p_ev = identity &&& repeatedly p_ev () >>^ \(a, e) -> e `tag` a +sample pEv = identity &&& repeatedly pEv () >>^ \(a, e) -> e `tag` a --- | Window sampling +-- | Window sampling. -- -- First argument is the window length wl, second is the sampling interval t. --- The output list should contain (min (truncate (T/t) wl)) samples, where --- T is the time the signal function has been running. This requires some --- care in case of sparse sampling. In case of sparse sampling, the --- current input value is assumed to have been present at all points where --- sampling was missed. +-- The output list should contain (min (truncate (T/t) wl)) samples, where T is +-- the time the signal function has been running. This requires some care in +-- case of sparse sampling. In case of sparse sampling, the current input value +-- is assumed to have been present at all points where sampling was missed. sampleWindow :: Int -> Time -> SF a (Event [a]) sampleWindow wl q = identity &&& afterEachCat (repeat (q, ())) @@ -323,14 +324,15 @@ >>> accumBy updateWindow [] where updateWindow w as = drop (max (length w' - wl) 0) w' - where w' = w ++ as + where + w' = w ++ as -- * Repetition and switching -- | Makes an event source recurring by restarting it as soon as it has an -- occurrence. recur :: SF a (Event b) -> SF a (Event b) -recur sfe = switch (never &&& sfe) $ \b -> Event b --> (recur (NoEvent-->sfe)) +recur sfe = switch (never &&& sfe) $ \b -> Event b --> recur (NoEvent --> sfe) -- | Apply the first SF until it produces an event, and, afterwards, switch to -- the second SF. This is just a convenience function, used to write what diff --git a/src/FRP/Yampa/Hybrid.hs b/src/FRP/Yampa/Hybrid.hs --- a/src/FRP/Yampa/Hybrid.hs +++ b/src/FRP/Yampa/Hybrid.hs @@ -1,14 +1,14 @@ -- | --- Module : FRP.Yampa.Hybrid --- Copyright : (c) Ivan Perez, 2014-2022 --- (c) George Giorgidze, 2007-2012 --- (c) Henrik Nilsson, 2005-2006 --- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 --- License : BSD-style (see the LICENSE file in the distribution) +-- Module : FRP.Yampa.Hybrid +-- Copyright : (c) Ivan Perez, 2014-2022 +-- (c) George Giorgidze, 2007-2012 +-- (c) Henrik Nilsson, 2005-2006 +-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 +-- License : BSD-style (see the LICENSE file in the distribution) -- --- Maintainer : ivan.perez@keera.co.uk --- Stability : provisional --- Portability : non-portable (GHC extensions) +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) -- -- Discrete to continuous-time signal functions. module FRP.Yampa.Hybrid @@ -30,34 +30,36 @@ ) where -import Control.Arrow +-- External imports +import Control.Arrow (arr, (>>>)) -import FRP.Yampa.Delays -import FRP.Yampa.Event +-- Internal imports +import FRP.Yampa.Delays (iPre) +import FRP.Yampa.Event (Event (..)) import FRP.Yampa.InternalCore (SF, epPrim) -- * Wave-form generation -- | Zero-order hold. -- --- Converts a discrete-time signal into a continuous-time signal, by holding --- the last value until it changes in the input signal. The given parameter --- may be used for time zero, and until the first event occurs in the input --- signal, so hold is always well-initialized. +-- Converts a discrete-time signal into a continuous-time signal, by holding the +-- last value until it changes in the input signal. The given parameter may be +-- used for time zero, and until the first event occurs in the input signal, so +-- hold is always well-initialized. -- -- >>> embed (hold 1) (deltaEncode 0.1 [NoEvent, NoEvent, Event 2, NoEvent, Event 3, NoEvent]) -- [1,1,2,2,3,3] hold :: a -> SF (Event a) a -hold a_init = epPrim f () a_init +hold aInit = epPrim f () aInit where f _ a = ((), a, a) -- | Zero-order hold with a delay. -- --- Converts a discrete-time signal into a continuous-time signal, by holding --- the last value until it changes in the input signal. The given parameter is --- used for time zero (until the first event occurs in the input signal), so --- 'dHold' shifts the discrete input by an infinitesimal delay. +-- Converts a discrete-time signal into a continuous-time signal, by holding the +-- last value until it changes in the input signal. The given parameter is used +-- for time zero (until the first event occurs in the input signal), so 'dHold' +-- shifts the discrete input by an infinitesimal delay. -- -- >>> embed (dHold 1) (deltaEncode 0.1 [NoEvent, NoEvent, Event 2, NoEvent, Event 3, NoEvent]) -- [1,1,1,2,2,3] @@ -67,47 +69,43 @@ -- | Tracks input signal when available, holding the last value when the input -- is 'Nothing'. -- --- This behaves similarly to 'hold', but there is a conceptual difference, as --- it takes a signal of input @Maybe a@ (for some @a@) and not @Event@. +-- This behaves similarly to 'hold', but there is a conceptual difference, as it +-- takes a signal of input @Maybe a@ (for some @a@) and not @Event@. -- -- >>> embed (trackAndHold 1) (deltaEncode 0.1 [Nothing, Nothing, Just 2, Nothing, Just 3, Nothing]) -- [1,1,2,2,3,3] trackAndHold :: a -> SF (Maybe a) a -trackAndHold a_init = arr (maybe NoEvent Event) >>> hold a_init +trackAndHold aInit = arr (maybe NoEvent Event) >>> hold aInit -- | Tracks input signal when available, holding the last value when the input -- is 'Nothing', with a delay. -- --- This behaves similarly to 'hold', but there is a conceptual difference, as --- it takes a signal of input @Maybe a@ (for some @a@) and not @Event@. +-- This behaves similarly to 'hold', but there is a conceptual difference, as it +-- takes a signal of input @Maybe a@ (for some @a@) and not @Event@. -- -- >>> embed (dTrackAndHold 1) (deltaEncode 0.1 [Nothing, Nothing, Just 2, Nothing, Just 3, Nothing]) -- [1,1,1,2,2,3] - dTrackAndHold :: a -> SF (Maybe a) a -dTrackAndHold a_init = trackAndHold a_init >>> iPre a_init +dTrackAndHold aInit = trackAndHold aInit >>> iPre aInit -- * Accumulators --- | Given an initial value in an accumulator, --- it returns a signal function that processes --- an event carrying transformation functions. --- Every time an 'Event' is received, the function --- inside it is applied to the accumulator, --- whose new value is outputted in an 'Event'. --- +-- | Given an initial value in an accumulator, it returns a signal function that +-- processes an event carrying transformation functions. Every time an 'Event' +-- is received, the function inside it is applied to the accumulator, whose new +-- value is outputted in an 'Event'. accum :: a -> SF (Event (a -> a)) (Event a) -accum a_init = epPrim f a_init NoEvent +accum aInit = epPrim f aInit NoEvent where - f a g = (a', Event a', NoEvent) -- Accumulator, output if Event, - -- output if no event + f a g = (a', Event a', NoEvent) -- Accumulator, output if Event, output if + -- no event where a' = g a --- | Zero-order hold accumulator (always produces the last outputted value --- until an event arrives). +-- | Zero-order hold accumulator (always produces the last outputted value until +-- an event arrives). accumHold :: a -> SF (Event (a -> a)) a -accumHold a_init = epPrim f a_init a_init +accumHold aInit = epPrim f aInit aInit where f a g = (a', a', a') -- Accumulator, output if Event, output if no event where @@ -117,11 +115,11 @@ -- the last outputted value until an event arrives, but the very initial output -- is always the given accumulator). dAccumHold :: a -> SF (Event (a -> a)) a -dAccumHold a_init = accumHold a_init >>> iPre a_init +dAccumHold aInit = accumHold aInit >>> iPre aInit -- | Accumulator parameterized by the accumulation function. accumBy :: (b -> a -> b) -> b -> SF (Event a) (Event b) -accumBy g b_init = epPrim f b_init NoEvent +accumBy g bInit = epPrim f bInit NoEvent where f b a = (b', Event b', NoEvent) where @@ -129,24 +127,24 @@ -- | Zero-order hold accumulator parameterized by the accumulation function. accumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b -accumHoldBy g b_init = epPrim f b_init b_init +accumHoldBy g bInit = epPrim f bInit bInit where f b a = (b', b', b') where b' = g b a --- | Zero-order hold accumulator parameterized by the accumulation function --- with delayed initialization (initial output sample is always the --- given accumulator). +-- | Zero-order hold accumulator parameterized by the accumulation function with +-- delayed initialization (initial output sample is always the given +-- accumulator). dAccumHoldBy :: (b -> a -> b) -> b -> SF (Event a) b -dAccumHoldBy f a_init = accumHoldBy f a_init >>> iPre a_init +dAccumHoldBy f aInit = accumHoldBy f aInit >>> iPre aInit -- | Accumulator parameterized by the accumulator function with filtering, --- possibly discarding some of the input events based on whether the second --- component of the result of applying the accumulation function is --- 'Nothing' or 'Just' x for some x. +-- possibly discarding some of the input events based on whether the second +-- component of the result of applying the accumulation function is 'Nothing' or +-- 'Just' x for some x. accumFilter :: (c -> a -> (c, Maybe b)) -> c -> SF (Event a) (Event b) -accumFilter g c_init = epPrim f c_init NoEvent +accumFilter g cInit = epPrim f cInit NoEvent where f c a = case g c a of (c', Nothing) -> (c', NoEvent, NoEvent) diff --git a/src/FRP/Yampa/Integration.hs b/src/FRP/Yampa/Integration.hs --- a/src/FRP/Yampa/Integration.hs +++ b/src/FRP/Yampa/Integration.hs @@ -1,14 +1,14 @@ -- | --- Module : FRP.Yampa.Integration --- Copyright : (c) Ivan Perez, 2014-2022 --- (c) George Giorgidze, 2007-2012 --- (c) Henrik Nilsson, 2005-2006 --- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 --- License : BSD-style (see the LICENSE file in the distribution) +-- Module : FRP.Yampa.Integration +-- Copyright : (c) Ivan Perez, 2014-2022 +-- (c) George Giorgidze, 2007-2012 +-- (c) Henrik Nilsson, 2005-2006 +-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 +-- License : BSD-style (see the LICENSE file in the distribution) -- --- Maintainer : ivan.perez@keera.co.uk --- Stability : provisional --- Portability : non-portable (GHC extensions) +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) -- -- Integration and derivation of input signals. -- @@ -41,14 +41,16 @@ ) where -import Control.Arrow -import Data.VectorSpace +-- External imports +import Control.Arrow ((***), (>>^)) +import Data.VectorSpace (VectorSpace, zeroVector, (*^), (^+^), (^-^), (^/)) -import FRP.Yampa.Event -import FRP.Yampa.Hybrid -import FRP.Yampa.InternalCore (SF(..), SF'(..), DTime) +-- Internal imports +import FRP.Yampa.Event (Event) +import FRP.Yampa.Hybrid (accumBy, accumHoldBy) +import FRP.Yampa.InternalCore (DTime, SF (..), SF' (..)) --- * Integration and differentiation +-- * Integration -- | Integration using the rectangle rule. {-# INLINE integral #-} @@ -57,39 +59,20 @@ where tf0 a0 = (integralAux igrl0 a0, igrl0) - igrl0 = zeroVector + igrl0 = zeroVector - integralAux igrl a_prev = SF' tf -- True + integralAux igrl aPrev = SF' tf -- True where tf dt a = (integralAux igrl' a, igrl') where - igrl' = igrl ^+^ realToFrac dt *^ a_prev + igrl' = igrl ^+^ realToFrac dt *^ aPrev --- | \"Immediate\" integration (using the function's value at the current time) +-- | \"Immediate\" integration (using the function's value at the current time). imIntegral :: (Fractional s, VectorSpace a s) => a -> SF a a -imIntegral = ((\ _ a' dt v -> v ^+^ realToFrac dt *^ a') `iterFrom`) - --- | Integrate using an auxiliary function that takes the current and the last --- input, the time between those samples, and the last output, and returns a --- new output. -iterFrom :: (a -> a -> DTime -> b -> b) -> b -> SF a b -f `iterFrom` b = SF (iterAux b) - where - iterAux b a = (SF' (\ dt a' -> iterAux (f a a' dt b) a'), b) - --- | A very crude version of a derivative. It simply divides the --- value difference by the time difference. Use at your own risk. -derivative :: (Fractional s, VectorSpace a s) => SF a a -derivative = SF {sfTF = tf0} - where - tf0 a0 = (derivativeAux a0, zeroVector) - - derivativeAux a_prev = SF' tf -- True - where - tf dt a = (derivativeAux a, (a ^-^ a_prev) ^/ realToFrac dt) +imIntegral = ((\_ a' dt v -> v ^+^ realToFrac dt *^ a') `iterFrom`) -- | Integrate the first input signal and add the /discrete/ accumulation (sum) --- of the second, discrete, input signal. +-- of the second, discrete, input signal. impulseIntegral :: (Fractional k, VectorSpace a k) => SF (a, Event a) a impulseIntegral = (integral *** accumHoldBy (^+^) zeroVector) >>^ uncurry (^+^) @@ -99,3 +82,24 @@ -- [Event 1,NoEvent,Event 2] count :: Integral b => SF (Event a) (Event b) count = accumBy (\n _ -> n + 1) 0 + +-- * Differentiation + +-- | A very crude version of a derivative. It simply divides the value +-- difference by the time difference. Use at your own risk. +derivative :: (Fractional s, VectorSpace a s) => SF a a +derivative = SF {sfTF = tf0} + where + tf0 a0 = (derivativeAux a0, zeroVector) + + derivativeAux aPrev = SF' tf -- True + where + tf dt a = (derivativeAux a, (a ^-^ aPrev) ^/ realToFrac dt) + +-- | Integrate using an auxiliary function that takes the current and the last +-- input, the time between those samples, and the last output, and returns a new +-- output. +iterFrom :: (a -> a -> DTime -> b -> b) -> b -> SF a b +f `iterFrom` b = SF (iterAux b) + where + iterAux b a = (SF' (\dt a' -> iterAux (f a a' dt b) a'), b) diff --git a/src/FRP/Yampa/InternalCore.hs b/src/FRP/Yampa/InternalCore.hs --- a/src/FRP/Yampa/InternalCore.hs +++ b/src/FRP/Yampa/InternalCore.hs @@ -1,21 +1,20 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} -- | --- Module : FRP.Yampa --- Copyright : (c) Ivan Perez, 2014-2022 --- (c) George Giorgidze, 2007-2012 --- (c) Henrik Nilsson, 2005-2006 --- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 --- License : BSD-style (see the LICENSE file in the distribution) --- --- Maintainer : ivan.perez@keera.co.uk --- Stability : provisional --- Portability : non-portable (GHC extensions) +-- Module : FRP.Yampa +-- Copyright : (c) Ivan Perez, 2014-2022 +-- (c) George Giorgidze, 2007-2012 +-- (c) Henrik Nilsson, 2005-2006 +-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 +-- License : BSD-style (see the LICENSE file in the distribution) -- +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) -- -- Domain-specific language embedded in Haskell for programming hybrid (mixed --- discrete-time and continuous-time) systems. Yampa is based on the concepts --- of Functional Reactive Programming (FRP) and is structured using arrow +-- discrete-time and continuous-time) systems. Yampa is based on the concepts of +-- Functional Reactive Programming (FRP) and is structured using arrow -- combinators. -- -- You can find examples, tutorials and documentation on Yampa here: @@ -30,19 +29,19 @@ -- real numbers and, computationally, a very dense approximation (Double) is -- used. -- --- * Events: 'Event'. Values that may or may not occur (and would probably --- occur rarely). It is often used for incoming network messages, mouse --- clicks, etc. Events are used as values carried by signals. +-- * Events: 'Event'. Values that may or may not occur (and would probably occur +-- rarely). It is often used for incoming network messages, mouse clicks, etc. +-- Events are used as values carried by signals. -- --- A complete Yampa system is defined as one Signal Function from some --- type @a@ to a type @b@. The execution of this signal transformer --- with specific input can be accomplished by means of two functions: --- 'reactimate' (which needs an initialization action, --- an input sensing action and an actuation/consumer action and executes --- until explicitly stopped), and 'react' (which executes only one cycle). +-- A complete Yampa system is defined as one Signal Function from some type @a@ +-- to a type @b@. The execution of this signal transformer with specific input +-- can be accomplished by means of two functions: 'reactimate' (which needs an +-- initialization action, an input sensing action and an actuation/consumer +-- action and executes until explicitly stopped), and 'react' (which executes +-- only one cycle). -- --- Apart from using normal functions and arrow syntax to define 'SF's, you --- can also use several combinators. See [<#g:4>] for basic signals combinators, +-- Apart from using normal functions and arrow syntax to define 'SF's, you can +-- also use several combinators. See [<#g:4>] for basic signals combinators, -- [<#g:11>] for ways of switching from one signal transformation to another, -- and [<#g:16>] for ways of transforming Event-carrying signals into continuous -- signals, [<#g:19>] for ways of delaying signals, and [<#g:21>] for ways to @@ -71,9 +70,6 @@ , sfConst , sfArrG - -- *** Scanning - , sfSScan - -- ** Function descriptions , FunDesc(..) , fdFun @@ -82,21 +78,26 @@ , arrPrim , arrEPrim , epPrim + + -- *** Scanning + , sfSScan ) where +-- External imports #if __GLASGOW_HASKELL__ < 710 import Control.Applicative (Applicative(..)) #endif -import Control.Arrow +import Control.Arrow (Arrow (..), ArrowChoice (..), ArrowLoop (..), (>>>)) #if __GLASGOW_HASKELL__ >= 610 import qualified Control.Category (Category(..)) #endif -import FRP.Yampa.Diagnostics -import FRP.Yampa.Event +-- Internal imports +import FRP.Yampa.Diagnostics (usrErr) +import FRP.Yampa.Event (Event (..)) -- * Basic type definitions with associated utilities @@ -113,34 +114,43 @@ -- | Signal function that transforms a signal carrying values of some type 'a' -- into a signal carrying values of some type 'b'. You can think of it as --- (Signal a -> Signal b). A signal is, conceptually, a --- function from 'Time' to value. +-- (Signal a -> Signal b). A signal is, conceptually, a function from 'Time' to +-- value. data SF a b = SF {sfTF :: a -> Transition a b} -- | Signal function in "running" state. -- --- It can also be seen as a Future Signal Function, meaning, --- an SF that, given a time delta or a time in the future, it will --- be an SF. +-- It can also be seen as a Future Signal Function, meaning, an SF that, given a +-- time delta or a time in the future, it will be an SF. data SF' a b where - SFArr :: !(DTime -> a -> Transition a b) -> !(FunDesc a b) -> SF' a b - -- The b is intentionally unstrict as the initial output sometimes - -- is undefined (e.g. when defining pre). In any case, it isn't - -- necessarily used and should thus not be forced. + SFArr :: !(DTime -> a -> Transition a b) -> !(FunDesc a b) -> SF' a b + + -- The b is intentionally unstrict as the initial output sometimes is + -- undefined (e.g. when defining pre). In any case, it isn't necessarily used + -- and should thus not be forced. SFSScan :: !(DTime -> a -> Transition a b) - -> !(c -> a -> Maybe (c, b)) -> !c -> b - -> SF' a b - SFEP :: !(DTime -> Event a -> Transition (Event a) b) - -> !(c -> a -> (c, b, b)) -> !c -> b - -> SF' (Event a) b + -> !(c -> a -> Maybe (c, b)) + -> !c + -> b + -> SF' a b + + SFEP :: !(DTime -> Event a -> Transition (Event a) b) + -> !(c -> a -> (c, b, b)) + -> !c + -> b + -> SF' (Event a) b + SFCpAXA :: !(DTime -> a -> Transition a d) - -> !(FunDesc a b) -> !(SF' b c) -> !(FunDesc c d) - -> SF' a d - SF' :: !(DTime -> a -> Transition a b) -> SF' a b + -> !(FunDesc a b) + -> !(SF' b c) + -> !(FunDesc c d) + -> SF' a d + SF' :: !(DTime -> a -> Transition a b) + -> SF' a b + -- | A transition is a pair of the next state (in the form of a future signal -- function) and the output at the present time step. - type Transition a b = (SF' a b, b) -- | Obtain the function that defines a running SF. @@ -174,8 +184,8 @@ sfArrE :: (Event a -> b) -> b -> SF' (Event a) b sfArrE f fne = sf where - sf = SFArr (\_ ea -> (sf, case ea of NoEvent -> fne ; _ -> f ea)) - (FDE f fne) + sf = SFArr (\_ ea -> (sf, case ea of NoEvent -> fne ; _ -> f ea)) + (FDE f fne) -- | SF constructor for a general function. sfArrG :: (a -> b) -> SF' a b @@ -183,47 +193,13 @@ where sf = SFArr (\_ a -> (sf, f a)) (FDG f) --- | Versatile zero-order hold SF' with folding. --- --- This function returns an SF that, if there is an input, runs it --- through the given function and returns part of its output and, if not, --- returns the last known output. --- --- The auxiliary function returns the value of the current output and --- the future held output, thus making it possible to have to distinct --- outputs for the present and the future. -epPrim :: (c -> a -> (c, b, b)) -> c -> b -> SF (Event a) b -epPrim f c bne = SF {sfTF = tf0} - where - tf0 NoEvent = (sfEP f c bne, bne) - tf0 (Event a) = let (c', b, bne') = f c a - in (sfEP f c' bne', b) - --- | Constructor for a zero-order hold SF' with folding. --- --- This function returns a running SF that, if there is an input, runs it --- through the given function and returns part of its output and, if not, --- returns the last known output. --- --- The auxiliary function returns the value of the current output and --- the future held output, thus making it possible to have to distinct --- outputs for the present and the future. -sfEP :: (c -> a -> (c, b, b)) -> c -> b -> SF' (Event a) b -sfEP f c bne = sf - where - sf = SFEP (\_ ea -> case ea of - NoEvent -> (sf, bne) - Event a -> let (c', b, bne') = f c a - in (sfEP f c' bne', b)) - f - c - bne +-- ** Function descriptions -- | Structured function definition. -- --- This type represents functions with a bit more structure, providing --- specific constructors for the identity, constant and event-based --- functions, helping optimise arrow combinators for special cases. +-- This type represents functions with a bit more structure, providing specific +-- constructors for the identity, constant and event-based functions, helping +-- optimise arrow combinators for special cases. data FunDesc a b where FDI :: FunDesc a a -- Identity function FDC :: b -> FunDesc a b -- Constant function @@ -254,7 +230,7 @@ fdComp (FDG f1) fd2 = FDG (fdFun fd2 . f1) -- | Parallel application of structured functions. -fdPar :: FunDesc a b -> FunDesc c d -> FunDesc (a,c) (b,d) +fdPar :: FunDesc a b -> FunDesc c d -> FunDesc (a, c) (b, d) fdPar FDI FDI = FDI fdPar FDI (FDC d) = FDG (\(~(a, _)) -> (a, d)) fdPar FDI fd2 = FDG (\(~(a, c)) -> (a, (fdFun fd2) c)) @@ -264,13 +240,13 @@ fdPar fd1 fd2 = FDG (\(~(a, c)) -> ((fdFun fd1) a, (fdFun fd2) c)) -- | Parallel application with broadcasting for structured functions. -fdFanOut :: FunDesc a b -> FunDesc a c -> FunDesc a (b,c) -fdFanOut FDI FDI = FDG (\a -> (a, a)) -fdFanOut FDI (FDC c) = FDG (\a -> (a, c)) -fdFanOut FDI fd2 = FDG (\a -> (a, (fdFun fd2) a)) -fdFanOut (FDC b) FDI = FDG (\a -> (b, a)) -fdFanOut (FDC b) (FDC c) = FDC (b, c) -fdFanOut (FDC b) fd2 = FDG (\a -> (b, (fdFun fd2) a)) +fdFanOut :: FunDesc a b -> FunDesc a c -> FunDesc a (b, c) +fdFanOut FDI FDI = FDG (\a -> (a, a)) +fdFanOut FDI (FDC c) = FDG (\a -> (a, c)) +fdFanOut FDI fd2 = FDG (\a -> (a, (fdFun fd2) a)) +fdFanOut (FDC b) FDI = FDG (\a -> (b, a)) +fdFanOut (FDC b) (FDC c) = FDC (b, c) +fdFanOut (FDC b) fd2 = FDG (\a -> (b, (fdFun fd2) a)) fdFanOut (FDE f1 f1ne) (FDE f2 f2ne) = FDE f1f2 f1f2ne where f1f2 NoEvent = f1f2ne @@ -281,12 +257,12 @@ FDG (\a -> ((fdFun fd1) a, (fdFun fd2) a)) -- | Verifies that the first argument is NoEvent. Returns the value of the --- second argument that is the case. Raises an error otherwise. --- Used to check that functions on events do not map NoEvent to Event --- wherever that assumption is exploited. +-- second argument that is the case. Raises an error otherwise. Used to check +-- that functions on events do not map NoEvent to Event wherever that assumption +-- is exploited. vfyNoEv :: Event a -> b -> b vfyNoEv NoEvent b = b -vfyNoEv _ _ = +vfyNoEv _ _ = usrErr "Yampa" "vfyNoEv" @@ -298,7 +274,7 @@ -- | Composition and identity for SFs. instance Control.Category.Category SF where (.) = flip compPrim - id = SF $ \x -> (sfId,x) + id = SF $ \x -> (sfId, x) #endif -- | Choice of which SF to run based on the value of a signal. @@ -345,7 +321,7 @@ in (choose sfCL sf', Right e) -- | Signal Functions as Arrows. See "The Yampa Arcade", by Courtney, Nilsson --- and Peterson. +-- and Peterson. instance Arrow SF where arr = arrPrim first = firstPrim @@ -355,7 +331,7 @@ #if __GLASGOW_HASKELL__ >= 610 #else - (>>>) = compPrim + (>>>) = compPrim #endif -- | Functor instance for applied SFs. @@ -365,8 +341,8 @@ -- | Applicative Functor instance (allows classic-frp style signals and -- composition using applicative style). instance Applicative (SF a) where - pure x = arr (const x) - f <*> x = (f &&& x) >>> arr (uncurry ($)) + pure x = arr (const x) + f <*> x = (f &&& x) >>> arr (uncurry ($)) -- * Lifting. @@ -381,9 +357,46 @@ arrEPrim :: (Event a -> b) -> SF (Event a) b arrEPrim f = SF {sfTF = \a -> (sfArrE f (f NoEvent), f a)} +-- | Versatile zero-order hold SF' with folding. +-- +-- This function returns an SF that, if there is an input, runs it through the +-- given function and returns part of its output and, if not, returns the last +-- known output. +-- +-- The auxiliary function returns the value of the current output and the future +-- held output, thus making it possible to have to distinct outputs for the +-- present and the future. +epPrim :: (c -> a -> (c, b, b)) -> c -> b -> SF (Event a) b +epPrim f c bne = SF {sfTF = tf0} + where + tf0 NoEvent = (sfEP f c bne, bne) + tf0 (Event a) = (sfEP f c' bne', b) + where + (c', b, bne') = f c a + +-- | Constructor for a zero-order hold SF' with folding. +-- +-- This function returns a running SF that, if there is an input, runs it +-- through the given function and returns part of its output and, if not, +-- returns the last known output. +-- +-- The auxiliary function returns the value of the current output and the future +-- held output, thus making it possible to have to distinct outputs for the +-- present and the future. +sfEP :: (c -> a -> (c, b, b)) -> c -> b -> SF' (Event a) b +sfEP f c bne = sf + where + sf = SFEP (\_ ea -> case ea of + NoEvent -> (sf, bne) + Event a -> let (c', b, bne') = f c a + in (sfEP f c' bne', b)) + f + c + bne + -- * Composition. --- | SF Composition +-- | SF Composition. -- -- The definition exploits the following identities: -- sf >>> identity = sf -- New @@ -410,19 +423,20 @@ -- event-processing (E). cpXX :: SF' a b -> SF' b c -> SF' a c -cpXX (SFArr _ fd1) sf2 = cpAX fd1 sf2 -cpXX sf1 (SFArr _ fd2) = cpXA sf1 fd2 +cpXX (SFArr _ fd1) sf2 = cpAX fd1 sf2 +cpXX sf1 (SFArr _ fd2) = cpXA sf1 fd2 cpXX (SFSScan _ f1 s1 b) (SFSScan _ f2 s2 c) = sfSScan f (s1, b, s2, c) c where f (s1, b, s2, c) a = - let (u, s1', b') = case f1 s1 a of - Nothing -> (True, s1, b) - Just (s1',b') -> (False, s1', b') - in case f2 s2 b' of - Nothing | u -> Nothing - | otherwise -> Just ((s1', b', s2, c), c) - Just (s2', c') -> Just ((s1', b', s2', c'), c') + case f2 s2 b' of + Nothing | u -> Nothing + | otherwise -> Just ((s1', b', s2, c), c) + Just (s2', c') -> Just ((s1', b', s2', c'), c') + where + (u, s1', b') = case f1 s1 a of + Nothing -> (True, s1, b) + Just (s1', b') -> (False, s1', b') cpXX (SFSScan _ f1 s1 eb) (SFEP _ f2 s2 cne) = sfSScan f (s1, eb, s2, cne) cne where @@ -443,29 +457,29 @@ sfSScan f (s1, bne, s2, c) c where f (s1, bne, s2, c) ea = - let (u, s1', b', bne') = case ea of - NoEvent -> (True, s1, bne, bne) - Event a -> let (s1', b, bne') = f1 s1 a - in (False, s1', b, bne') - in case f2 s2 b' of - Nothing | u -> Nothing - | otherwise -> Just (seq s1' (s1', bne', s2, c), c) - Just (s2', c') -> Just (seq s1' (s1', bne', s2', c'), c') + case f2 s2 b' of + Nothing | u -> Nothing + | otherwise -> Just (seq s1' (s1', bne', s2, c), c) + Just (s2', c') -> Just (seq s1' (s1', bne', s2', c'), c') + where + (u, s1', b', bne') = case ea of + NoEvent -> (True, s1, bne, bne) + Event a -> let (s1', b, bne') = f1 s1 a + in (False, s1', b, bne') cpXX (SFEP _ f1 s1 bne) (SFEP _ f2 s2 cne) = sfEP f (s1, s2, cne) (vfyNoEv bne cne) where - -- The function "f" is invoked whenever an event is to be processed. It - -- then computes the output, the new state, and the new NoEvent output. - -- However, when sequencing event processors, the ones in the latter - -- part of the chain may not get invoked since previous ones may decide - -- not to "fire". But a "new" NoEvent output still has to be produced, - -- i.e. the old one retained. Since it cannot be computed by invoking - -- the last event-processing function in the chain, it has to be - -- remembered. Since the composite event-processing function remains - -- constant/unchanged, the NoEvent output has to be part of the state. - -- An alternative would be to make the event-processing function take - -- an extra argument. But that is likely to make the simple case more - -- expensive. See note at sfEP. + -- The function "f" is invoked whenever an event is to be processed. It then + -- computes the output, the new state, and the new NoEvent output. However, + -- when sequencing event processors, the ones in the latter part of the + -- chain may not get invoked since previous ones may decide not to "fire". + -- But a "new" NoEvent output still has to be produced, i.e. the old one + -- retained. Since it cannot be computed by invoking the last + -- event-processing function in the chain, it has to be remembered. Since + -- the composite event-processing function remains constant/unchanged, the + -- NoEvent output has to be part of the state. An alternative would be to + -- make the event-processing function take an extra argument. But that is + -- likely to make the simple case more expensive. See note at sfEP. f (s1, s2, cne) a = case f1 s1 a of (s1', NoEvent, NoEvent) -> ((s1', s2, cne), cne, cne) @@ -481,8 +495,8 @@ cpXX (SFCpAXA _ fd11 sf12 (FDE f13 f13ne)) sf2@(SFEP{}) = cpXX (cpAX fd11 sf12) (cpEX f13 f13ne sf2) cpXX (SFCpAXA _ fd11 sf12 fd13) (SFCpAXA _ fd21 sf22 fd23) = - -- Termination: The first argument to cpXX is no larger than - -- the current first argument, and the second is smaller. + -- Termination: The first argument to cpXX is no larger than the current first + -- argument, and the second is smaller. cpAXA fd11 (cpXX (cpXA sf12 (fdComp fd13 fd21)) sf22) fd23 cpXX sf1 sf2 = SF' tf -- False where @@ -492,8 +506,8 @@ (sf2', c) = (sfTF' sf2) dt b cpAXA :: FunDesc a b -> SF' b c -> FunDesc c d -> SF' a d --- Termination: cpAX/cpXA, via cpCX, cpEX etc. only call cpAXA if sf2 --- is SFCpAXA, and then on the embedded sf and hence on a smaller arg. +-- Termination: cpAX/cpXA, via cpCX, cpEX etc. only call cpAXA if sf2 is +-- SFCpAXA, and then on the embedded sf and hence on a smaller arg. cpAXA FDI sf2 fd3 = cpXA sf2 fd3 cpAXA fd1 sf2 FDI = cpAX fd1 sf2 cpAXA (FDC b) sf2 fd3 = cpCXA b sf2 fd3 @@ -501,10 +515,14 @@ cpAXA fd1 sf2 fd3 = cpAXAAux fd1 (fdFun fd1) fd3 (fdFun fd3) sf2 where - -- Really: cpAXAAux :: SF' b c -> SF' a d - -- Note: Event cases are not optimized (EXA etc.) - cpAXAAux :: FunDesc a b -> (a -> b) -> FunDesc c d -> (c -> d) - -> SF' b c -> SF' a d + -- Really: cpAXAAux :: SF' b c -> SF' a d. Note: Event cases are not + -- optimized (EXA etc.) + cpAXAAux :: FunDesc a b + -> (a -> b) + -> FunDesc c d + -> (c -> d) + -> SF' b c + -> SF' a d cpAXAAux fd1 _ fd3 _ (SFArr _ fd2) = sfArr (fdComp (fdComp fd1 fd2) fd3) cpAXAAux fd1 _ fd3 _ sf2@(SFSScan {}) = @@ -535,9 +553,9 @@ -- The remaining signal function, if it is SF', later could turn into something -- else, like SFId. cpCX :: b -> SF' b c -> SF' a c -cpCX b (SFArr _ fd2) = sfConst ((fdFun fd2) b) -cpCX b (SFSScan _ f s c) = sfSScan (\s _ -> f s b) s c -cpCX b (SFEP _ _ _ cne) = sfConst (vfyNoEv b cne) +cpCX b (SFArr _ fd2) = sfConst ((fdFun fd2) b) +cpCX b (SFSScan _ f s c) = sfSScan (\s _ -> f s b) s c +cpCX b (SFEP _ _ _ cne) = sfConst (vfyNoEv b cne) cpCX b (SFCpAXA _ fd21 sf22 fd23) = cpCXA ((fdFun fd21) b) sf22 fd23 cpCX b sf2 = SFCpAXA tf (FDC b) sf2 FDI @@ -552,8 +570,12 @@ cpCXA b sf2 fd3 = cpCXAAux (FDC b) b fd3 (fdFun fd3) sf2 where -- Really: SF' b c -> SF' a d - cpCXAAux :: FunDesc a b -> b -> FunDesc c d -> (c -> d) - -> SF' b c -> SF' a d + cpCXAAux :: FunDesc a b + -> b + -> FunDesc c d + -> (c -> d) + -> SF' b c + -> SF' a d cpCXAAux _ b _ f3 (SFArr _ fd2) = sfConst (f3 ((fdFun fd2) b)) cpCXAAux _ b _ f3 (SFSScan _ f s c) = sfSScan f' s (f3 c) where @@ -574,12 +596,12 @@ where cpGXAux :: FunDesc a b -> (a -> b) -> SF' b c -> SF' a c cpGXAux fd1 _ (SFArr _ fd2) = sfArr (fdComp fd1 fd2) - -- We actually do know that (fdComp (FDG f1) fd21) is going to - -- result in an FDG. So we *could* call a cpGXA here. But the - -- price is "inlining" of part of fdComp. + -- We actually do know that (fdComp (FDG f1) fd21) is going to result in an + -- FDG. So we *could* call a cpGXA here. But the price is "inlining" of part + -- of fdComp. cpGXAux _ f1 (SFSScan _ f s c) = sfSScan (\s a -> f s (f1 a)) s c - -- We really shouldn't see an EP here, as that would mean - -- an arrow INTRODUCING events ... + -- We really shouldn't see an EP here, as that would mean an arrow + -- INTRODUCING events ... cpGXAux fd1 _ (SFCpAXA _ fd21 sf22 fd23) = cpAXA (fdComp fd1 fd21) sf22 fd23 cpGXAux fd1 f1 sf2 = SFCpAXA tf fd1 sf2 FDI @@ -599,11 +621,16 @@ f' s a = case f s a of Nothing -> Nothing Just (s', b') -> Just (s', f2 b') + cpXGAux _ f2 (SFEP _ f1 s bne) = sfEP f s (f2 bne) where - f s a = let (s', b, bne') = f1 s a in (s', f2 b, f2 bne') + f s a = (s', f2 b, f2 bne') + where + (s', b, bne') = f1 s a + cpXGAux fd2 _ (SFCpAXA _ fd11 sf12 fd22) = cpAXA fd11 sf12 (fdComp fd22 fd2) + cpXGAux fd2 f2 sf1 = SFCpAXA tf FDI sf1 fd2 where tf dt a = (cpXGAux fd2 f2 sf1', f2 b) @@ -613,11 +640,14 @@ cpEX :: (Event a -> b) -> b -> SF' b c -> SF' (Event a) c cpEX f1 f1ne sf2 = cpEXAux (FDE f1 f1ne) f1 f1ne sf2 where - cpEXAux :: FunDesc (Event a) b -> (Event a -> b) -> b - -> SF' b c -> SF' (Event a) c + cpEXAux :: FunDesc (Event a) b + -> (Event a -> b) + -> b + -> SF' b c + -> SF' (Event a) c cpEXAux fd1 _ _ (SFArr _ fd2) = sfArr (fdComp fd1 fd2) cpEXAux _ f1 _ (SFSScan _ f s c) = sfSScan (\s a -> f s (f1 a)) s c - -- We must not capture cne in the f closure since cne can change! See cpXX + -- We must not capture cne in the f closure since cne can change! See cpXX -- the SFEP/SFEP case for a similar situation. However, FDE represent a -- state-less signal function, so *its* NoEvent value never changes. Hence -- we only need to verify that it is NoEvent once. @@ -627,7 +657,10 @@ f scne@(s, cne) a = case f1 (Event a) of NoEvent -> (scne, cne, cne) - Event b -> let (s', c, cne') = f2 s b in ((s', cne'), c, cne') + Event b -> ((s', cne'), c, cne') + where + (s', c, cne') = f2 s b + cpEXAux fd1 _ _ (SFCpAXA _ fd21 sf22 fd23) = cpAXA (fdComp fd1 fd21) sf22 fd23 -- The rationale for the following is that the case analysis is typically @@ -646,8 +679,11 @@ cpXE :: SF' a (Event b) -> (Event b -> c) -> c -> SF' a c cpXE sf1 f2 f2ne = cpXEAux (FDE f2 f2ne) f2 f2ne sf1 where - cpXEAux :: FunDesc (Event b) c -> (Event b -> c) -> c - -> SF' a (Event b) -> SF' a c + cpXEAux :: FunDesc (Event b) c + -> (Event b -> c) + -> c + -> SF' a (Event b) + -> SF' a c cpXEAux fd2 _ _ (SFArr _ fd1) = sfArr (fdComp fd1 fd2) cpXEAux _ f2 f2ne (SFSScan _ f s eb) = sfSScan f' s (f2 eb) where @@ -677,23 +713,23 @@ -- * Widening. --- | Widening +-- | Widening. -- -- The definition exploits the following identities: -- first identity = identity -- New -- first (constant b) = arr (\(_, c) -> (b, c)) -- (first (arr f)) = arr (\(a, c) -> (f a, c)) -firstPrim :: SF a b -> SF (a,c) (b,c) +firstPrim :: SF a b -> SF (a, c) (b, c) firstPrim (SF {sfTF = tf10}) = SF {sfTF = tf0} where tf0 ~(a0, c0) = (fpAux sf1, (b0, c0)) where (sf1, b0) = tf10 a0 -fpAux :: SF' a b -> SF' (a,c) (b,c) -fpAux (SFArr _ FDI) = sfId -- New -fpAux (SFArr _ (FDC b)) = sfArrG (\(~(_, c)) -> (b, c)) -fpAux (SFArr _ fd1) = sfArrG (\(~(a, c)) -> ((fdFun fd1) a, c)) +fpAux :: SF' a b -> SF' (a, c) (b, c) +fpAux (SFArr _ FDI) = sfId -- New +fpAux (SFArr _ (FDC b)) = sfArrG (\(~(_, c)) -> (b, c)) +fpAux (SFArr _ fd1) = sfArrG (\(~(a, c)) -> ((fdFun fd1) a, c)) fpAux sf1 = SF' tf where tf dt ~(a, c) = (fpAux sf1', (b, c)) @@ -701,17 +737,17 @@ (sf1', b) = (sfTF' sf1) dt a -- Mirror image of first. -secondPrim :: SF a b -> SF (c,a) (c,b) +secondPrim :: SF a b -> SF (c, a) (c, b) secondPrim (SF {sfTF = tf10}) = SF {sfTF = tf0} where tf0 ~(c0, a0) = (spAux sf1, (c0, b0)) where (sf1, b0) = tf10 a0 -spAux :: SF' a b -> SF' (c,a) (c,b) -spAux (SFArr _ FDI) = sfId -- New -spAux (SFArr _ (FDC b)) = sfArrG (\(~(c, _)) -> (c, b)) -spAux (SFArr _ fd1) = sfArrG (\(~(c, a)) -> (c, (fdFun fd1) a)) +spAux :: SF' a b -> SF' (c, a) (c, b) +spAux (SFArr _ FDI) = sfId -- New +spAux (SFArr _ (FDC b)) = sfArrG (\(~(c, _)) -> (c, b)) +spAux (SFArr _ fd1) = sfArrG (\(~(c, a)) -> (c, (fdFun fd1) a)) spAux sf1 = SF' tf where tf dt ~(c, a) = (spAux sf1', (c, b)) @@ -728,7 +764,7 @@ -- constant b *** arr f2 = arr (\(_, c) -> (b, f2 c) -- arr f1 *** constant d = arr (\(a, _) -> (f1 a, d) -- arr f1 *** arr f2 = arr (\(a, b) -> (f1 a, f2 b) -parSplitPrim :: SF a b -> SF c d -> SF (a,c) (b,d) +parSplitPrim :: SF a b -> SF c d -> SF (a, c) (b, d) parSplitPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0} where tf0 ~(a0, c0) = (psXX sf1 sf2, (b0, d0)) @@ -741,14 +777,14 @@ -- A - arbitrary pure arrow -- C - constant arrow - psXX :: SF' a b -> SF' c d -> SF' (a,c) (b,d) - psXX (SFArr _ fd1) (SFArr _ fd2) = sfArr (fdPar fd1 fd2) - psXX (SFArr _ FDI) sf2 = spAux sf2 -- New - psXX (SFArr _ (FDC b)) sf2 = psCX b sf2 - psXX (SFArr _ fd1) sf2 = psAX (fdFun fd1) sf2 - psXX sf1 (SFArr _ FDI) = fpAux sf1 -- New - psXX sf1 (SFArr _ (FDC d)) = psXC sf1 d - psXX sf1 (SFArr _ fd2) = psXA sf1 (fdFun fd2) + psXX :: SF' a b -> SF' c d -> SF' (a, c) (b, d) + psXX (SFArr _ fd1) (SFArr _ fd2) = sfArr (fdPar fd1 fd2) + psXX (SFArr _ FDI) sf2 = spAux sf2 -- New + psXX (SFArr _ (FDC b)) sf2 = psCX b sf2 + psXX (SFArr _ fd1) sf2 = psAX (fdFun fd1) sf2 + psXX sf1 (SFArr _ FDI) = fpAux sf1 -- New + psXX sf1 (SFArr _ (FDC d)) = psXC sf1 d + psXX sf1 (SFArr _ fd2) = psXA sf1 (fdFun fd2) psXX sf1 sf2 = SF' tf where tf dt ~(a, c) = (psXX sf1' sf2', (b, d)) @@ -756,33 +792,33 @@ (sf1', b) = (sfTF' sf1) dt a (sf2', d) = (sfTF' sf2) dt c - psCX :: b -> SF' c d -> SF' (a,c) (b,d) - psCX b (SFArr _ fd2) = sfArr (fdPar (FDC b) fd2) - psCX b sf2 = SF' tf + psCX :: b -> SF' c d -> SF' (a, c) (b, d) + psCX b (SFArr _ fd2) = sfArr (fdPar (FDC b) fd2) + psCX b sf2 = SF' tf where tf dt ~(_, c) = (psCX b sf2', (b, d)) where (sf2', d) = (sfTF' sf2) dt c - psXC :: SF' a b -> d -> SF' (a,c) (b,d) - psXC (SFArr _ fd1) d = sfArr (fdPar fd1 (FDC d)) - psXC sf1 d = SF' tf + psXC :: SF' a b -> d -> SF' (a, c) (b, d) + psXC (SFArr _ fd1) d = sfArr (fdPar fd1 (FDC d)) + psXC sf1 d = SF' tf where tf dt ~(a, _) = (psXC sf1' d, (b, d)) where (sf1', b) = (sfTF' sf1) dt a - psAX :: (a -> b) -> SF' c d -> SF' (a,c) (b,d) - psAX f1 (SFArr _ fd2) = sfArr (fdPar (FDG f1) fd2) - psAX f1 sf2 = SF' tf + psAX :: (a -> b) -> SF' c d -> SF' (a, c) (b, d) + psAX f1 (SFArr _ fd2) = sfArr (fdPar (FDG f1) fd2) + psAX f1 sf2 = SF' tf where tf dt ~(a, c) = (psAX f1 sf2', (f1 a, d)) where (sf2', d) = (sfTF' sf2) dt c - psXA :: SF' a b -> (c -> d) -> SF' (a,c) (b,d) - psXA (SFArr _ fd1) f2 = sfArr (fdPar fd1 (FDG f2)) - psXA sf1 f2 = SF' tf + psXA :: SF' a b -> (c -> d) -> SF' (a, c) (b, d) + psXA (SFArr _ fd1) f2 = sfArr (fdPar fd1 (FDG f2)) + psXA sf1 f2 = SF' tf where tf dt ~(a, c) = (psXA sf1' f2, (b, f2 c)) where @@ -802,22 +838,22 @@ -- I - identity arrow -- C - constant arrow - pfoXX :: SF' a b -> SF' a c -> SF' a (b ,c) - pfoXX (SFArr _ fd1) (SFArr _ fd2) = sfArr(fdFanOut fd1 fd2) - pfoXX (SFArr _ FDI) sf2 = pfoIX sf2 - pfoXX (SFArr _ (FDC b)) sf2 = pfoCX b sf2 - pfoXX (SFArr _ fd1) sf2 = pfoAX (fdFun fd1) sf2 - pfoXX sf1 (SFArr _ FDI) = pfoXI sf1 - pfoXX sf1 (SFArr _ (FDC c)) = pfoXC sf1 c - pfoXX sf1 (SFArr _ fd2) = pfoXA sf1 (fdFun fd2) - pfoXX sf1 sf2 = SF' tf + pfoXX :: SF' a b -> SF' a c -> SF' a (b, c) + pfoXX (SFArr _ fd1) (SFArr _ fd2) = sfArr(fdFanOut fd1 fd2) + pfoXX (SFArr _ FDI) sf2 = pfoIX sf2 + pfoXX (SFArr _ (FDC b)) sf2 = pfoCX b sf2 + pfoXX (SFArr _ fd1) sf2 = pfoAX (fdFun fd1) sf2 + pfoXX sf1 (SFArr _ FDI) = pfoXI sf1 + pfoXX sf1 (SFArr _ (FDC c)) = pfoXC sf1 c + pfoXX sf1 (SFArr _ fd2) = pfoXA sf1 (fdFun fd2) + pfoXX sf1 sf2 = SF' tf where tf dt a = (pfoXX sf1' sf2', (b, c)) where (sf1', b) = (sfTF' sf1) dt a (sf2', c) = (sfTF' sf2) dt a - pfoIX :: SF' a c -> SF' a (a ,c) + pfoIX :: SF' a c -> SF' a (a, c) pfoIX (SFArr _ fd2) = sfArr (fdFanOut FDI fd2) pfoIX sf2 = SF' tf where @@ -825,7 +861,7 @@ where (sf2', c) = (sfTF' sf2) dt a - pfoXI :: SF' a b -> SF' a (b ,a) + pfoXI :: SF' a b -> SF' a (b, a) pfoXI (SFArr _ fd1) = sfArr (fdFanOut fd1 FDI) pfoXI sf1 = SF' tf where @@ -833,7 +869,7 @@ where (sf1', b) = (sfTF' sf1) dt a - pfoCX :: b -> SF' a c -> SF' a (b ,c) + pfoCX :: b -> SF' a c -> SF' a (b, c) pfoCX b (SFArr _ fd2) = sfArr (fdFanOut (FDC b) fd2) pfoCX b sf2 = SF' tf where @@ -841,7 +877,7 @@ where (sf2', c) = (sfTF' sf2) dt a - pfoXC :: SF' a b -> c -> SF' a (b ,c) + pfoXC :: SF' a b -> c -> SF' a (b, c) pfoXC (SFArr _ fd1) c = sfArr (fdFanOut fd1 (FDC c)) pfoXC sf1 c = SF' tf where @@ -849,7 +885,7 @@ where (sf1', b) = (sfTF' sf1) dt a - pfoAX :: (a -> b) -> SF' a c -> SF' a (b ,c) + pfoAX :: (a -> b) -> SF' a c -> SF' a (b, c) pfoAX f1 (SFArr _ fd2) = sfArr (fdFanOut (FDG f1) fd2) pfoAX f1 sf2 = SF' tf where @@ -857,7 +893,7 @@ where (sf2', c) = (sfTF' sf2) dt a - pfoXA :: SF' a b -> (a -> c) -> SF' a (b ,c) + pfoXA :: SF' a b -> (a -> c) -> SF' a (b, c) pfoXA (SFArr _ fd1) f2 = sfArr (fdFanOut fd1 (FDG f2)) pfoXA sf1 f2 = SF' tf where @@ -871,19 +907,19 @@ instance ArrowLoop SF where loop = loopPrim -loopPrim :: SF (a,c) (b,c) -> SF a b +loopPrim :: SF (a, c) (b, c) -> SF a b loopPrim (SF {sfTF = tf10}) = SF {sfTF = tf0} where tf0 a0 = (loopAux sf1, b0) where (sf1, (b0, c0)) = tf10 (a0, c0) - loopAux :: SF' (a,c) (b,c) -> SF' a b - loopAux (SFArr _ FDI) = sfId + loopAux :: SF' (a, c) (b, c) -> SF' a b + loopAux (SFArr _ FDI) = sfId loopAux (SFArr _ (FDC (b, _))) = sfConst b - loopAux (SFArr _ fd1) = - sfArrG (\a -> let (b,c) = (fdFun fd1) (a,c) in b) - loopAux sf1 = SF' tf + loopAux (SFArr _ fd1) = + sfArrG (\a -> let (b, c) = (fdFun fd1) (a, c) in b) + loopAux sf1 = SF' tf where tf dt a = (loopAux sf1', b) where @@ -893,14 +929,14 @@ -- | Constructor for a zero-order hold with folding. -- --- This function returns a running SF that takes an input, runs it through a --- function and, if there is an output, returns it, otherwise, returns the --- previous value. Additionally, an accumulator or folded value is kept --- internally. +-- This function returns a running SF that takes an input, runs it through a +-- function and, if there is an output, returns it, otherwise, returns the +-- previous value. Additionally, an accumulator or folded value is kept +-- internally. sfSScan :: (c -> a -> Maybe (c, b)) -> c -> b -> SF' a b sfSScan f c b = sf where - sf = SFSScan tf f c b + sf = SFSScan tf f c b tf _ a = case f c a of Nothing -> (sf, b) Just (c', b') -> (sfSScan f c' b', b') diff --git a/src/FRP/Yampa/Loop.hs b/src/FRP/Yampa/Loop.hs --- a/src/FRP/Yampa/Loop.hs +++ b/src/FRP/Yampa/Loop.hs @@ -1,17 +1,17 @@ -- | --- Module : FRP.Yampa.Loop --- Copyright : (c) Ivan Perez, 2014-2022 --- (c) George Giorgidze, 2007-2012 --- (c) Henrik Nilsson, 2005-2006 --- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 --- License : BSD-style (see the LICENSE file in the distribution) +-- Module : FRP.Yampa.Loop +-- Copyright : (c) Ivan Perez, 2014-2022 +-- (c) George Giorgidze, 2007-2012 +-- (c) Henrik Nilsson, 2005-2006 +-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 +-- License : BSD-style (see the LICENSE file in the distribution) -- --- Maintainer : ivan.perez@keera.co.uk --- Stability : provisional +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional -- --- Portability : non-portable -GHC extensions- +-- Portability : non-portable -GHC extensions- -- --- Well-initialised loops +-- Well-initialised loops. module FRP.Yampa.Loop ( -- * Loops with guaranteed well-defined feedback @@ -20,21 +20,22 @@ ) where -import Control.Arrow -import Data.VectorSpace +-- External imports +import Control.Arrow (loop, second, (>>>)) +import Data.VectorSpace (VectorSpace) -import FRP.Yampa.Delays -import FRP.Yampa.Integration +-- Internal imports +import FRP.Yampa.Delays (iPre) +import FRP.Yampa.Integration (integral) import FRP.Yampa.InternalCore (SF) -- * Loops with guaranteed well-defined feedback -- | Loop with an initial value for the signal being fed back. -loopPre :: c -> SF (a,c) (b,c) -> SF a b -loopPre c_init sf = loop (second (iPre c_init) >>> sf) +loopPre :: c -> SF (a, c) (b, c) -> SF a b +loopPre cInit sf = loop (second (iPre cInit) >>> sf) --- | Loop by integrating the second value in the pair and feeding the --- result back. Because the integral at time 0 is zero, this is always --- well defined. -loopIntegral :: (Fractional s, VectorSpace c s) => SF (a,c) (b,c) -> SF a b +-- | Loop by integrating the second value in the pair and feeding the result +-- back. Because the integral at time 0 is zero, this is always well defined. +loopIntegral :: (Fractional s, VectorSpace c s) => SF (a, c) (b, c) -> SF a b loopIntegral sf = loop (second integral >>> sf) diff --git a/src/FRP/Yampa/Random.hs b/src/FRP/Yampa/Random.hs --- a/src/FRP/Yampa/Random.hs +++ b/src/FRP/Yampa/Random.hs @@ -1,14 +1,14 @@ -- | --- Module : FRP.Yampa.Random --- Copyright : (c) Ivan Perez, 2014-2022 --- (c) George Giorgidze, 2007-2012 --- (c) Henrik Nilsson, 2005-2006 --- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 --- License : BSD-style (see the LICENSE file in the distribution) +-- Module : FRP.Yampa.Random +-- Copyright : (c) Ivan Perez, 2014-2022 +-- (c) George Giorgidze, 2007-2012 +-- (c) Henrik Nilsson, 2005-2006 +-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 +-- License : BSD-style (see the LICENSE file in the distribution) -- --- Maintainer : ivan.perez@keera.co.uk --- Stability : provisional --- Portability : non-portable (GHC extensions) +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) -- -- Signals and signal functions with noise and randomness. -- @@ -26,21 +26,23 @@ ) where +-- External imports import System.Random (Random (..), RandomGen (..)) -import FRP.Yampa.Diagnostics -import FRP.Yampa.Event +-- Internal imports +import FRP.Yampa.Diagnostics (intErr, usrErr) +import FRP.Yampa.Event (Event (..)) import FRP.Yampa.InternalCore (SF (..), SF' (..), Time) -- * Noise (i.e. random signal generators) and stochastic processes --- | Noise (random signal) with default range for type in question; --- based on "randoms". +-- | Noise (random signal) with default range for type in question; based on +-- "randoms". noise :: (RandomGen g, Random b) => g -> SF a b noise g0 = streamToSF (randoms g0) -- | Noise (random signal) with specified range; based on "randomRs". -noiseR :: (RandomGen g, Random b) => (b,b) -> g -> SF a b +noiseR :: (RandomGen g, Random b) => (b, b) -> g -> SF a b noiseR range g0 = streamToSF (randomRs range g0) streamToSF :: [b] -> SF a b @@ -55,29 +57,27 @@ where tf _ _ = (stsfAux bs, b) --- | Stochastic event source with events occurring on average once every t_avg +-- | Stochastic event source with events occurring on average once every tAvg -- seconds. However, no more than one event results from any one sampling --- interval in the case of relatively sparse sampling, thus avoiding an --- "event backlog" should sampling become more frequent at some later --- point in time. - +-- interval in the case of relatively sparse sampling, thus avoiding an "event +-- backlog" should sampling become more frequent at some later point in time. occasionally :: RandomGen g => g -> Time -> b -> SF a (Event b) -occasionally g t_avg x | t_avg > 0 = SF {sfTF = tf0} - | otherwise = usrErr "Yampa" "occasionally" - "Non-positive average interval." +occasionally g tAvg x | tAvg > 0 = SF {sfTF = tf0} + | otherwise = usrErr "Yampa" "occasionally" + "Non-positive average interval." where -- Generally, if events occur with an average frequency of f, the -- probability of at least one event occurring in an interval of t is given -- by (1 - exp (-f*t)). The goal in the following is to decide whether at - -- least one event occurred in the interval of size dt preceding the - -- current sample point. For the first point, we can think of the preceding - -- interval as being 0, implying no probability of an event occurring. + -- least one event occurred in the interval of size dt preceding the current + -- sample point. For the first point, we can think of the preceding interval + -- as being 0, implying no probability of an event occurring. tf0 _ = (occAux (randoms g :: [Time]), NoEvent) - occAux [] = undefined + occAux [] = undefined occAux (r:rs) = SF' tf -- True where - tf dt _ = let p = 1 - exp (-(dt/t_avg)) -- Probability for at least one - -- event. - in (occAux rs, if r < p then Event x else NoEvent) + tf dt _ = (occAux rs, if r < p then Event x else NoEvent) + where + p = 1 - exp (- (dt / tAvg)) -- Probability for at least one event. diff --git a/src/FRP/Yampa/Scan.hs b/src/FRP/Yampa/Scan.hs --- a/src/FRP/Yampa/Scan.hs +++ b/src/FRP/Yampa/Scan.hs @@ -1,19 +1,19 @@ -- | --- Module : FRP.Yampa.Scan --- Copyright : (c) Ivan Perez, 2014-2022 --- (c) George Giorgidze, 2007-2012 --- (c) Henrik Nilsson, 2005-2006 --- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 --- License : BSD-style (see the LICENSE file in the distribution) +-- Module : FRP.Yampa.Scan +-- Copyright : (c) Ivan Perez, 2014-2022 +-- (c) George Giorgidze, 2007-2012 +-- (c) Henrik Nilsson, 2005-2006 +-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 +-- License : BSD-style (see the LICENSE file in the distribution) -- --- Maintainer : ivan.perez@keera.co.uk --- Stability : provisional --- Portability : non-portable (GHC extensions) +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) -- -- Simple, stateful signal processing. -- --- Scanning implements elementary, step-based accumulating over signal --- functions by means of an auxiliary function applied to each input and to an +-- Scanning implements elementary, step-based accumulating over signal functions +-- by means of an auxiliary function applied to each input and to an -- accumulator. For comparison with other FRP libraries and with stream -- processing abstractions, think of fold. module FRP.Yampa.Scan @@ -22,6 +22,7 @@ ) where +-- Internal imports import FRP.Yampa.InternalCore (SF(..), sfSScan) -- ** Simple, stateful signal processing @@ -29,20 +30,22 @@ -- | Applies a function point-wise, using the last output as next input. This -- creates a well-formed loop based on a pure, auxiliary function. sscan :: (b -> a -> b) -> b -> SF a b -sscan f b_init = sscanPrim f' b_init b_init +sscan f bInit = sscanPrim f' bInit bInit where - f' b a = let b' = f b a in Just (b', b') + f' b a = Just (b', b') + where + b' = f b a --- | Generic version of 'sscan', in which the auxiliary function produces --- an internal accumulator and an "held" output. +-- | Generic version of 'sscan', in which the auxiliary function produces an +-- internal accumulator and an "held" output. -- --- Applies a function point-wise, using the last known 'Just' output to form --- the output, and next input accumulator. If the output is 'Nothing', the last --- known accumulators are used. This creates a well-formed loop based on a --- pure, auxiliary function. +-- Applies a function point-wise, using the last known 'Just' output to form the +-- output, and next input accumulator. If the output is 'Nothing', the last +-- known accumulators are used. This creates a well-formed loop based on a pure, +-- auxiliary function. sscanPrim :: (c -> a -> Maybe (c, b)) -> c -> b -> SF a b -sscanPrim f c_init b_init = SF {sfTF = tf0} +sscanPrim f cInit bInit = SF {sfTF = tf0} where - tf0 a0 = case f c_init a0 of - Nothing -> (sfSScan f c_init b_init, b_init) - Just (c', b') -> (sfSScan f c' b', b') + tf0 a0 = case f cInit a0 of + Nothing -> (sfSScan f cInit bInit, bInit) + Just (c', b') -> (sfSScan f c' b', b') diff --git a/src/FRP/Yampa/Simulation.hs b/src/FRP/Yampa/Simulation.hs --- a/src/FRP/Yampa/Simulation.hs +++ b/src/FRP/Yampa/Simulation.hs @@ -1,21 +1,21 @@ -- | --- Module : FRP.Yampa.Simulation --- Copyright : (c) Ivan Perez, 2014-2022 --- (c) George Giorgidze, 2007-2012 --- (c) Henrik Nilsson, 2005-2006 --- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 --- License : BSD-style (see the LICENSE file in the distribution) +-- Module : FRP.Yampa.Simulation +-- Copyright : (c) Ivan Perez, 2014-2022 +-- (c) George Giorgidze, 2007-2012 +-- (c) Henrik Nilsson, 2005-2006 +-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 +-- License : BSD-style (see the LICENSE file in the distribution) -- --- Maintainer : ivan.perez@keera.co.uk --- Stability : provisional --- Portability : non-portable (GHC extensions) +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) -- -- Execution/simulation of signal functions. -- -- SFs can be executed in two ways: by running them, feeding input samples one --- by one, obtained from a monadic environment (presumably, @IO@), or by --- passing an input stream and calculating an output stream. The former is --- called /reactimation/, and the latter is called /embedding/. +-- by one, obtained from a monadic environment (presumably, @IO@), or by passing +-- an input stream and calculating an output stream. The former is called +-- /reactimation/, and the latter is called /embedding/. -- -- * Running: -- Normally, to run an SF, you would use 'reactimate', providing input samples, @@ -58,11 +58,13 @@ ) where +-- External imports import Control.Monad (unless) -import Data.IORef +import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Maybe (fromMaybe) -import FRP.Yampa.Diagnostics +-- Internal imports +import FRP.Yampa.Diagnostics (intErr, usrErr) import FRP.Yampa.InternalCore (DTime, SF (..), SF' (..), sfTF') -- * Reactimation @@ -74,9 +76,9 @@ -- initial input for the signal transformer at time 0. -- -- Afterwards, an input sensing action is used to obtain new input (if any) and --- the time since the last iteration. The argument to the input sensing --- function indicates if it can block. If no new input is received, it is --- assumed to be the same as in the last iteration. +-- the time since the last iteration. The argument to the input sensing function +-- indicates if it can block. If no new input is received, it is assumed to be +-- the same as in the last iteration. -- -- After applying the signal function to the input, the actuation IO action is -- executed. The first argument indicates if the output has changed, the second @@ -89,7 +91,6 @@ -- also impose a sizeable constraint in larger projects in which different -- subparts run at different time steps. If you need to control the main loop -- yourself for these or other reasons, use 'reactInit' and 'react'. - reactimate :: Monad m => m a -- ^ Initialization action -> (Bool -> m (DTime, Maybe a)) -- ^ Input sensing action @@ -106,19 +107,19 @@ done <- actuate True b unless (a `seq` b `seq` done) $ do (dt, ma') <- sense False - let a' = fromMaybe a ma' + let a' = fromMaybe a ma' (sf', b') = (sfTF' sf) dt a' loop sf' a' b' --- An API for animating a signal function when some other library --- needs to own the top-level control flow: +-- An API for animating a signal function when some other library needs to own +-- the top-level control flow: -- reactimate's state, maintained across samples: data ReactState a b = ReactState { rsActuate :: ReactHandle a b -> Bool -> b -> IO Bool - , rsSF :: SF' a b - , rsA :: a - , rsB :: b + , rsSF :: SF' a b + , rsA :: a + , rsB :: b } -- | A reference to reactimate's state, maintained across samples. @@ -126,15 +127,15 @@ { reactHandle :: IORef (ReactState a b) } -- | Initialize a top-level reaction handle. -reactInit :: IO a -- init - -> (ReactHandle a b -> Bool -> b -> IO Bool) -- actuate - -> SF a b - -> IO (ReactHandle a b) +reactInit :: IO a -- init + -> (ReactHandle a b -> Bool -> b -> IO Bool) -- actuate + -> SF a b + -> IO (ReactHandle a b) reactInit init actuate (SF {sfTF = tf0}) = do a0 <- init - let (sf,b0) = tf0 a0 - -- TODO: really need to fix this interface, since right now we - -- just ignore termination at time 0: + let (sf, b0) = tf0 a0 + -- TODO: really need to fix this interface, since right now we just ignore + -- termination at time 0: r' <- newIORef (ReactState { rsActuate = actuate, rsSF = sf , rsA = a0, rsB = b0 } @@ -145,24 +146,23 @@ -- | Process a single input sample. react :: ReactHandle a b - -> (DTime,Maybe a) + -> (DTime, Maybe a) -> IO Bool -react rh (dt,ma') = do +react rh (dt, ma') = do rs <- readIORef (reactHandle rh) let ReactState {rsActuate = actuate, rsSF = sf, rsA = a, rsB = _b } = rs let a' = fromMaybe a ma' - (sf',b') = (sfTF' sf) dt a' - writeIORef (reactHandle rh) (rs {rsSF = sf',rsA = a',rsB = b'}) + (sf', b') = (sfTF' sf) dt a' + writeIORef (reactHandle rh) (rs {rsSF = sf', rsA = a', rsB = b'}) done <- actuate rh True b' return done -- * Embedding --- | Given a signal function and a pair with an initial --- input sample for the input signal, and a list of sampling --- times, possibly with new input samples at those times, --- it produces a list of output samples. +-- | Given a signal function and a pair with an initial input sample for the +-- input signal, and a list of sampling times, possibly with new input samples +-- at those times, it produces a list of output samples. -- -- This is a simplified, purely-functional version of 'reactimate'. embed :: SF a b -> (a, [(DTime, Maybe a)]) -> [b] @@ -171,10 +171,10 @@ (sf, b0) = (sfTF sf0) a0 loop _ _ [] = [] - loop a_prev sf ((dt, ma) : dtas) = + loop aPrev sf ((dt, ma) : dtas) = b : (a `seq` b `seq` loop a sf' dtas) where - a = fromMaybe a_prev ma + a = fromMaybe aPrev ma (sf', b) = (sfTF' sf) dt a -- | Synchronous embedding. The embedded signal function is run on the supplied @@ -188,28 +188,28 @@ tf0 _ = (esAux 0 (zip tts bbs), b) - esAux _ [] = intErr "Yampa" "embedSynch" "Empty list!" + esAux _ [] = intErr "Yampa" "embedSynch" "Empty list!" -- Invarying below since esAux [] is an error. - esAux tp_prev tbtbs = SF' tf -- True + esAux tpPrev tbtbs = SF' tf -- True where tf dt r | r < 0 = usrErr "Yampa" "embedSynch" "Negative ratio." - | otherwise = let tp = tp_prev + dt * r - (b, tbtbs') = advance tp tbtbs - in (esAux tp tbtbs', b) + | otherwise = (esAux tp tbtbs', b) + where + tp = tpPrev + dt * r + (b, tbtbs') = advance tp tbtbs - -- Advance the time stamped stream to the perceived time tp. Under the + -- Advance the time stamped stream to the perceived time tp. Under the -- assumption that the perceived time never goes backwards (non-negative - -- ratio), advance maintains the invariant that the perceived time is - -- always >= the first time stamp. + -- ratio), advance maintains the invariant that the perceived time is always + -- >= the first time stamp. advance _ tbtbs@[(_, b)] = (b, tbtbs) advance tp tbtbtbs@((_, b) : tbtbs@((t', _) : _)) | tp < t' = (b, tbtbtbs) | t' <= tp = advance tp tbtbs advance _ _ = undefined --- | Spaces a list of samples by a fixed time delta, avoiding --- unnecessary samples when the input has not changed since --- the last sample. +-- | Spaces a list of samples by a fixed time delta, avoiding unnecessary +-- samples when the input has not changed since the last sample. deltaEncode :: Eq a => DTime -> [a] -> (a, [(DTime, Maybe a)]) deltaEncode _ [] = usrErr "Yampa" "deltaEncode" "Empty input list." deltaEncode dt aas@(_:_) = deltaEncodeBy (==) dt aas @@ -219,59 +219,61 @@ deltaEncodeBy _ _ [] = usrErr "Yampa" "deltaEncodeBy" "Empty input list." deltaEncodeBy eq dt (a0:as) = (a0, zip (repeat dt) (debAux a0 as)) where - debAux _ [] = [] - debAux a_prev (a:as) | a `eq` a_prev = Nothing : debAux a as - | otherwise = Just a : debAux a as + debAux _ [] = [] + debAux aPrev (a:as) | a `eq` aPrev = Nothing : debAux a as + | otherwise = Just a : debAux a as -- * Debugging / Step by step simulation -- | A wrapper around an initialized SF (continuation), needed for testing and -- debugging purposes. --- newtype FutureSF a b = FutureSF { unsafeSF :: SF' a b } -- | Evaluate an SF, and return an output and an initialized SF. -- --- /WARN/: Do not use this function for standard simulation. This function is --- intended only for debugging/testing. Apart from being potentially slower --- and consuming more memory, it also breaks the FRP abstraction by making --- samples discrete and step based. +-- /WARN/: Do not use this function for standard simulation. This function is +-- intended only for debugging/testing. Apart from being potentially slower and +-- consuming more memory, it also breaks the FRP abstraction by making samples +-- discrete and step based. evalAtZero :: SF a b -> a -- ^ Input sample -> (b, FutureSF a b) -- ^ Output x Continuation evalAtZero (SF { sfTF = tf }) a = (b, FutureSF tf' ) - where (tf', b) = tf a + where + (tf', b) = tf a -- | Evaluate an initialized SF, and return an output and a continuation. -- --- /WARN/: Do not use this function for standard simulation. This function is --- intended only for debugging/testing. Apart from being potentially slower --- and consuming more memory, it also breaks the FRP abstraction by making --- samples discrete and step based. +-- /WARN/: Do not use this function for standard simulation. This function is +-- intended only for debugging/testing. Apart from being potentially slower and +-- consuming more memory, it also breaks the FRP abstraction by making samples +-- discrete and step based. evalAt :: FutureSF a b -> DTime -> a -- ^ Input sample -> (b, FutureSF a b) -- ^ Output x Continuation evalAt (FutureSF { unsafeSF = tf }) dt a = (b, FutureSF tf') - where (tf', b) = (sfTF' tf) dt a + where + (tf', b) = (sfTF' tf) dt a -- | Given a signal function and time delta, it moves the signal function into --- the future, returning a new uninitialized SF and the initial output. --- --- While the input sample refers to the present, the time delta refers to the --- future (or to the time between the current sample and the next sample). +-- the future, returning a new uninitialized SF and the initial output. -- --- /WARN/: Do not use this function for standard simulation. This function is --- intended only for debugging/testing. Apart from being potentially slower --- and consuming more memory, it also breaks the FRP abstraction by making --- samples discrete and step based. +-- While the input sample refers to the present, the time delta refers to the +-- future (or to the time between the current sample and the next sample). -- +-- /WARN/: Do not use this function for standard simulation. This function is +-- intended only for debugging/testing. Apart from being potentially slower and +-- consuming more memory, it also breaks the FRP abstraction by making samples +-- discrete and step based. evalFuture :: SF a b -> a -> DTime -> (b, SF a b) evalFuture sf a dt = (b, sf' dt) - where (b, sf') = evalStep sf a + where + (b, sf') = evalStep sf a -- | Steps the signal function into the future one step. It returns the current -- output, and a signal function that expects, apart from an input, a time -- between samples. evalStep :: SF a b -> a -> (b, DTime -> SF a b) evalStep (SF sf) a = (b, \dt -> SF (sfTF' sf' dt)) - where (sf', b) = sf a + where + (sf', b) = sf a diff --git a/src/FRP/Yampa/Switches.hs b/src/FRP/Yampa/Switches.hs --- a/src/FRP/Yampa/Switches.hs +++ b/src/FRP/Yampa/Switches.hs @@ -1,15 +1,15 @@ {-# LANGUAGE Rank2Types #-} -- | --- Module : FRP.Yampa.Switches --- Copyright : (c) Ivan Perez, 2014-2022 --- (c) George Giorgidze, 2007-2012 --- (c) Henrik Nilsson, 2005-2006 --- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 --- License : BSD-style (see the LICENSE file in the distribution) +-- Module : FRP.Yampa.Switches +-- Copyright : (c) Ivan Perez, 2014-2022 +-- (c) George Giorgidze, 2007-2012 +-- (c) Henrik Nilsson, 2005-2006 +-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 +-- License : BSD-style (see the LICENSE file in the distribution) -- --- Maintainer : ivan.perez@keera.co.uk --- Stability : provisional --- Portability : non-portable (GHC extensions) +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) -- -- Switches allow you to change the signal function being applied. -- @@ -21,10 +21,10 @@ -- -- @switch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b@ -- --- which indicates that it has two parameters: a signal function --- that produces an output and indicates, with an event, when it is time to --- switch, and a signal function that starts with the residual data left by the --- first SF in the event and continues onwards. +-- which indicates that it has two parameters: a signal function that produces +-- an output and indicates, with an event, when it is time to switch, and a +-- signal function that starts with the residual data left by the first SF in +-- the event and continues onwards. -- -- Switching occurs, at most, once. If you want something to switch repeatedly, -- in general, you need to loop, or to switch onto the same signal function @@ -36,22 +36,21 @@ -- Switches vary depending on a number of criteria: -- -- - /Decoupled/ vs normal switching /(d)/: when an SF is being applied and a --- different SF needs to be applied next, one question is which one is used --- for the time in which the switching takes place. In decoupled switching, the --- old SF is used for the time of switching, and the one SF is only used after --- that. In normal or instantaneous or coupled switching, the old SF is --- discarded immediately and a new SF is used for the output already from that --- point in time. +-- different SF needs to be applied next, one question is which one is used for +-- the time in which the switching takes place. In decoupled switching, the old +-- SF is used for the time of switching, and the one SF is only used after that. +-- In normal or instantaneous or coupled switching, the old SF is discarded +-- immediately and a new SF is used for the output already from that point in +-- time. -- -- - How the switching event is provided /( \/r\/k)/: normally, an 'Event' is -- used to indicate that a switching must take place. This event can be part of -- the argument SF (e.g., 'switch'), it can be part of the input (e.g., --- 'rSwitch'), or it can be determined by a second argument SF (e.g, --- 'kSwitch'). +-- 'rSwitch'), or it can be determined by a second argument SF (e.g, 'kSwitch'). -- -- - How many SFs are being handled /( \/p\/par)/: some combinators deal with --- only one SF, others handle collections, either in the form of a ---'Functor' or a list ('[]'). +-- only one SF, others handle collections, either in the form of a 'Functor' or +-- a list ('[]'). -- -- - How the input is router /(B\/Z\/ )/: when multiple SFs are being combined, -- a decision needs to be made about how the input is passed to the internal @@ -62,9 +61,9 @@ -- the collection. -- -- These gives a number of different combinations, some of which make no sense, --- and also helps determine the expected behaviour of a combinator by looking --- at its name. For example, 'drpSwitchB' is the decoupled (/d/), recurrent --- (/r/), parallel (/p/) switch with broadcasting (/B/). +-- and also helps determine the expected behaviour of a combinator by looking at +-- its name. For example, 'drpSwitchB' is the decoupled (/d/), recurrent (/r/), +-- parallel (/p/) switch with broadcasting (/B/). module FRP.Yampa.Switches ( -- * Basic switching @@ -75,13 +74,13 @@ -- * Parallel composition\/switching (collections) -- ** With broadcasting , parB - , pSwitchB,dpSwitchB - , rpSwitchB,drpSwitchB + , pSwitchB, dpSwitchB + , rpSwitchB, drpSwitchB -- ** With helper routing function , par - , pSwitch, dpSwitch - , rpSwitch,drpSwitch + , pSwitch, dpSwitch + , rpSwitch, drpSwitch -- * Parallel composition\/switching (lists) -- @@ -97,11 +96,13 @@ ) where -import Control.Arrow +-- External imports +import Control.Arrow (arr, first) -import FRP.Yampa.Basic -import FRP.Yampa.Diagnostics -import FRP.Yampa.Event +-- Internal imports +import FRP.Yampa.Basic (constant, (>=-)) +import FRP.Yampa.Diagnostics (usrErr) +import FRP.Yampa.Event (Event (..), noEventSnd) import FRP.Yampa.InternalCore (DTime, FunDesc (..), SF (..), SF' (..), fdFun, sfArrG, sfConst, sfTF') @@ -117,12 +118,10 @@ -- -- Important note: at the time of switching, the second signal function is -- applied immediately. If that second SF can also switch at time zero, then a --- double (nested) switch might take place. If the second SF refers to the --- first one, the switch might take place infinitely many times and never be --- resolved. +-- double (nested) switch might take place. If the second SF refers to the first +-- one, the switch might take place infinitely many times and never be resolved. -- --- Remember: The continuation is evaluated strictly at the time --- of switching! +-- Remember: The continuation is evaluated strictly at the time of switching! switch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b switch (SF {sfTF = tf10}) k = SF {sfTF = tf0} where @@ -158,35 +157,32 @@ -- -- By default, the first signal function is applied. -- --- Whenever the second value in the pair actually is an event, --- the value carried by the event is used to obtain a new signal --- function to be applied *at future times*. +-- Whenever the second value in the pair actually is an event, the value carried +-- by the event is used to obtain a new signal function to be applied *at future +-- times*. -- --- Until that happens, the first value in the pair is produced --- in the output signal. +-- Until that happens, the first value in the pair is produced in the output +-- signal. -- --- Important note: at the time of switching, the second --- signal function is used immediately, but the current --- input is fed by it (even though the actual output signal --- value at time 0 is discarded). +-- Important note: at the time of switching, the second signal function is used +-- immediately, but the current input is fed by it (even though the actual +-- output signal value at time 0 is discarded). -- --- If that second SF can also switch at time zero, then a --- double (nested) -- switch might take place. If the second SF refers to the --- first one, the switch might take place infinitely many times and never be --- resolved. +-- If that second SF can also switch at time zero, then a double (nested) switch +-- might take place. If the second SF refers to the first one, the switch might +-- take place infinitely many times and never be resolved. -- --- Remember: The continuation is evaluated strictly at the time --- of switching! +-- Remember: The continuation is evaluated strictly at the time of switching! dSwitch :: SF a (b, Event c) -> (c -> SF a b) -> SF a b dSwitch (SF {sfTF = tf10}) k = SF {sfTF = tf0} where - tf0 a0 = - let (sf1, (b0, ec0)) = tf10 a0 - in ( case ec0 of - NoEvent -> dSwitchAux sf1 k - Event c0 -> fst (sfTF (k c0) a0) - , b0 - ) + tf0 a0 = ( case ec0 of + NoEvent -> dSwitchAux sf1 k + Event c0 -> fst (sfTF (k c0) a0) + , b0 + ) + where + (sf1, (b0, ec0)) = tf10 a0 -- It would be nice to optimize further here. E.g. if it would be -- possible to observe the event source only. @@ -195,35 +191,35 @@ dSwitchAux (SFArr _ fd1) k = dSwitchAuxA1 (fdFun fd1) k dSwitchAux sf1 k = SF' tf where - tf dt a = - let (sf1', (b, ec)) = (sfTF' sf1) dt a - in ( case ec of - NoEvent -> dSwitchAux sf1' k - Event c -> fst (sfTF (k c) a) - , b - ) + tf dt a = ( case ec of + NoEvent -> dSwitchAux sf1' k + Event c -> fst (sfTF (k c) a) + , b + ) + where + (sf1', (b, ec)) = (sfTF' sf1) dt a -- Note: While dSwitch behaves as a stateless arrow at this point, that -- could change after a switch. Hence, SF' overall. dSwitchAuxA1 :: (a -> (b, Event c)) -> (c -> SF a b) -> SF' a b dSwitchAuxA1 f1 k = sf where - sf = SF' tf -- False - tf _ a = - let (b, ec) = f1 a - in ( case ec of - NoEvent -> sf - Event c -> fst (sfTF (k c) a) - , b - ) + sf = SF' tf -- False + tf _ a = ( case ec of + NoEvent -> sf + Event c -> fst (sfTF (k c) a) + , b + ) + where + (b, ec) = f1 a -- | Recurring switch. -- -- Uses the given SF until an event comes in the input, in which case the SF in -- the event is turned on, until the next event comes in the input, and so on. -- --- See for more --- information on how this switch works. +-- See for more information on how +-- this switch works. rSwitch :: SF a b -> SF (a, Event (SF a b)) b rSwitch sf = switch (first sf) ((noEventSnd >=-) . rSwitch) @@ -234,8 +230,8 @@ -- -- Uses decoupled switch ('dSwitch'). -- --- See for more --- information on how this switch works. +-- See for more information on how +-- this switch works. drSwitch :: SF a b -> SF (a, Event (SF a b)) b drSwitch sf = dSwitch (first sf) ((noEventSnd >=-) . drSwitch) @@ -245,33 +241,35 @@ -- passed to the second SF, produce an event, in which case the original SF and -- the event are used to build an new SF to switch into. -- --- See for more --- information on how this switch works. -kSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b +-- See for more information on how +-- this switch works. +kSwitch :: SF a b -> SF (a, b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b kSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0} where - tf0 a0 = - let (sf1, b0) = tf10 a0 - in case tfe0 (a0, b0) of - (sfe, NoEvent) -> (kSwitchAux sf1 sfe, b0) - (_, Event c0) -> sfTF (k sf10 c0) a0 + tf0 a0 = case tfe0 (a0, b0) of + (sfe, NoEvent) -> (kSwitchAux sf1 sfe, b0) + (_, Event c0) -> sfTF (k sf10 c0) a0 + where + (sf1, b0) = tf10 a0 + -- This is as best as we can align this function. Any other attempts at + -- aligning the arguments of the equal signs result in a more awkward style. kSwitchAux (SFArr _ (FDC b)) sfe = kSwitchAuxC1 b sfe kSwitchAux (SFArr _ fd1) sfe = kSwitchAuxA1 (fdFun fd1) sfe kSwitchAux sf1 (SFArr _ (FDC NoEvent)) = sf1 - kSwitchAux sf1 (SFArr _ fde) = kSwitchAuxAE sf1 (fdFun fde) - kSwitchAux sf1 sfe = SF' tf -- False + kSwitchAux sf1 (SFArr _ fde) = kSwitchAuxAE sf1 (fdFun fde) + kSwitchAux sf1 sfe = SF' tf -- False where - tf dt a = - let (sf1', b) = (sfTF' sf1) dt a - in case (sfTF' sfe) dt (a, b) of - (sfe', NoEvent) -> (kSwitchAux sf1' sfe', b) - (_, Event c) -> sfTF (k (freeze sf1 dt) c) a + tf dt a = case (sfTF' sfe) dt (a, b) of + (sfe', NoEvent) -> (kSwitchAux sf1' sfe', b) + (_, Event c) -> sfTF (k (freeze sf1 dt) c) a + where + (sf1', b) = (sfTF' sf1) dt a -- !!! Untested optimization! kSwitchAuxC1 b (SFArr _ (FDC NoEvent)) = sfConst b - kSwitchAuxC1 b (SFArr _ fde) = kSwitchAuxC1AE b (fdFun fde) - kSwitchAuxC1 b sfe = SF' tf -- False + kSwitchAuxC1 b (SFArr _ fde) = kSwitchAuxC1AE b (fdFun fde) + kSwitchAuxC1 b sfe = SF' tf -- False where tf dt a = case (sfTF' sfe) dt (a, b) of @@ -280,25 +278,25 @@ -- !!! Untested optimization! kSwitchAuxA1 f1 (SFArr _ (FDC NoEvent)) = sfArrG f1 - kSwitchAuxA1 f1 (SFArr _ fde) = kSwitchAuxA1AE f1 (fdFun fde) - kSwitchAuxA1 f1 sfe = SF' tf -- False + kSwitchAuxA1 f1 (SFArr _ fde) = kSwitchAuxA1AE f1 (fdFun fde) + kSwitchAuxA1 f1 sfe = SF' tf -- False where - tf dt a = - let b = f1 a - in case (sfTF' sfe) dt (a, b) of - (sfe', NoEvent) -> (kSwitchAuxA1 f1 sfe', b) - (_, Event c) -> sfTF (k (arr f1) c) a + tf dt a = case (sfTF' sfe) dt (a, b) of + (sfe', NoEvent) -> (kSwitchAuxA1 f1 sfe', b) + (_, Event c) -> sfTF (k (arr f1) c) a + where + b = f1 a -- !!! Untested optimization! - kSwitchAuxAE (SFArr _ (FDC b)) fe = kSwitchAuxC1AE b fe - kSwitchAuxAE (SFArr _ fd1) fe = kSwitchAuxA1AE (fdFun fd1) fe - kSwitchAuxAE sf1 fe = SF' tf -- False + kSwitchAuxAE (SFArr _ (FDC b)) fe = kSwitchAuxC1AE b fe + kSwitchAuxAE (SFArr _ fd1) fe = kSwitchAuxA1AE (fdFun fd1) fe + kSwitchAuxAE sf1 fe = SF' tf -- False where - tf dt a = - let (sf1', b) = (sfTF' sf1) dt a - in case fe (a, b) of - NoEvent -> (kSwitchAuxAE sf1' fe, b) - Event c -> sfTF (k (freeze sf1 dt) c) a + tf dt a = case fe (a, b) of + NoEvent -> (kSwitchAuxAE sf1' fe, b) + Event c -> sfTF (k (freeze sf1 dt) c) a + where + (sf1', b) = (sfTF' sf1) dt a -- !!! Untested optimization! kSwitchAuxC1AE b fe = SF' tf -- False @@ -311,11 +309,11 @@ -- !!! Untested optimization! kSwitchAuxA1AE f1 fe = SF' tf -- False where - tf _ a = - let b = f1 a - in case fe (a, b) of - NoEvent -> (kSwitchAuxA1AE f1 fe, b) - Event c -> sfTF (k (arr f1) c) a + tf _ a = case fe (a, b) of + NoEvent -> (kSwitchAuxA1AE f1 fe, b) + Event c -> sfTF (k (arr f1) c) a + where + b = f1 a -- | 'kSwitch' with delayed observation. -- @@ -325,42 +323,40 @@ -- -- The switch is decoupled ('dSwitch'). -- --- See for more --- information on how this switch works. -dkSwitch :: SF a b -> SF (a,b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b +-- See for more information on how +-- this switch works. +dkSwitch :: SF a b -> SF (a, b) (Event c) -> (SF a b -> c -> SF a b) -> SF a b dkSwitch sf10@(SF {sfTF = tf10}) (SF {sfTF = tfe0}) k = SF {sfTF = tf0} where - tf0 a0 = - let (sf1, b0) = tf10 a0 - in ( case tfe0 (a0, b0) of - (sfe, NoEvent) -> dkSwitchAux sf1 sfe - (_, Event c0) -> fst (sfTF (k sf10 c0) a0) - , b0 - ) + tf0 a0 = ( case tfe0 (a0, b0) of + (sfe, NoEvent) -> dkSwitchAux sf1 sfe + (_, Event c0) -> fst (sfTF (k sf10 c0) a0) + , b0 + ) + where + (sf1, b0) = tf10 a0 dkSwitchAux sf1 (SFArr _ (FDC NoEvent)) = sf1 dkSwitchAux sf1 sfe = SF' tf -- False where - tf dt a = - let (sf1', b) = (sfTF' sf1) dt a - in ( case (sfTF' sfe) dt (a, b) of - (sfe', NoEvent) -> dkSwitchAux sf1' sfe' - (_, Event c) -> fst (sfTF (k (freeze sf1 dt) c) a) - , b - ) + tf dt a = ( case (sfTF' sfe) dt (a, b) of + (sfe', NoEvent) -> dkSwitchAux sf1' sfe' + (_, Event c) -> fst (sfTF (k (freeze sf1 dt) c) a) + , b + ) + where + (sf1', b) = (sfTF' sf1) dt a -- * Parallel composition and switching over collections with broadcasting --- | Tuple a value up with every element of a collection of signal --- functions. +-- | Tuple a value up with every element of a collection of signal functions. broadcast :: Functor col => a -> col sf -> col (a, sf) broadcast a = fmap (\sf -> (a, sf)) --- | Spatial parallel composition of a signal function collection. --- Given a collection of signal functions, it returns a signal --- function that broadcasts its input signal to every element --- of the collection, to return a signal carrying a collection --- of outputs. See 'par'. +-- | Spatial parallel composition of a signal function collection. Given a +-- collection of signal functions, it returns a signal function that broadcasts +-- its input signal to every element of the collection, to return a signal +-- carrying a collection of outputs. See 'par'. -- -- For more information on how parallel composition works, check -- @@ -372,27 +368,31 @@ -- -- For more information on how parallel composition works, check -- -pSwitchB :: Functor col => - col (SF a b) -> SF (a,col b) (Event c) -> (col (SF a b)->c-> SF a (col b)) - -> SF a (col b) +pSwitchB :: Functor col + => col (SF a b) + -> SF (a, col b) (Event c) + -> (col (SF a b) -> c -> SF a (col b)) + -> SF a (col b) pSwitchB = pSwitch broadcast --- | Decoupled parallel switch with broadcasting (dynamic collection of --- signal functions spatially composed in parallel). See 'dpSwitch'. +-- | Decoupled parallel switch with broadcasting (dynamic collection of signal +-- functions spatially composed in parallel). See 'dpSwitch'. -- -- For more information on how parallel composition works, check -- -dpSwitchB :: Functor col => - col (SF a b) -> SF (a,col b) (Event c) -> (col (SF a b)->c->SF a (col b)) - -> SF a (col b) +dpSwitchB :: Functor col + => col (SF a b) + -> SF (a, col b) (Event c) + -> (col (SF a b) -> c -> SF a (col b)) + -> SF a (col b) dpSwitchB = dpSwitch broadcast -- | Recurring parallel switch with broadcasting. -- --- Uses the given collection of SFs, until an event comes in the input, in --- which case the function in the 'Event' is used to transform the collections --- of SF to be used with 'rpSwitch' again, until the next event comes in the --- input, and so on. +-- Uses the given collection of SFs, until an event comes in the input, in which +-- case the function in the 'Event' is used to transform the collections of SF +-- to be used with 'rpSwitch' again, until the next event comes in the input, +-- and so on. -- -- Broadcasting is used to decide which subpart of the input goes to each SF in -- the collection. @@ -401,16 +401,17 @@ -- -- For more information on how parallel composition works, check -- -rpSwitchB :: Functor col => - col (SF a b) -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b) +rpSwitchB :: Functor col + => col (SF a b) + -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b) rpSwitchB = rpSwitch broadcast -- | Decoupled recurring parallel switch with broadcasting. -- --- Uses the given collection of SFs, until an event comes in the input, in --- which case the function in the 'Event' is used to transform the collections --- of SF to be used with 'rpSwitch' again, until the next event comes in the --- input, and so on. +-- Uses the given collection of SFs, until an event comes in the input, in which +-- case the function in the 'Event' is used to transform the collections of SF +-- to be used with 'rpSwitch' again, until the next event comes in the input, +-- and so on. -- -- Broadcasting is used to decide which subpart of the input goes to each SF in -- the collection. @@ -419,165 +420,161 @@ -- -- For more information on how parallel composition works, check -- -drpSwitchB :: Functor col => - col (SF a b) -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b) +drpSwitchB :: Functor col + => col (SF a b) + -> SF (a, Event (col (SF a b) -> col (SF a b))) (col b) drpSwitchB = drpSwitch broadcast -- * Parallel composition and switching over collections with general routing -- | Spatial parallel composition of a signal function collection parameterized -- on the routing function. --- par :: Functor col => (forall sf . (a -> col sf -> col (b, sf))) - -- ^ Determines the input to each signal function - -- in the collection. IMPORTANT! The routing function MUST - -- preserve the structure of the signal function collection. + -- ^ Determines the input to each signal function in the collection. + -- IMPORTANT! The routing function MUST preserve the structure of the + -- signal function collection. -> col (SF b c) - -- ^ Signal function collection. + -- ^ Signal function collection. -> SF a (col c) par rf sfs0 = SF {sfTF = tf0} where - tf0 a0 = - let bsfs0 = rf a0 sfs0 - sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0 - sfs = fmap fst sfcs0 - cs0 = fmap snd sfcs0 - in (parAux rf sfs, cs0) + tf0 a0 = (parAux rf sfs, cs0) + where + bsfs0 = rf a0 sfs0 + sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0 + sfs = fmap fst sfcs0 + cs0 = fmap snd sfcs0 -- Internal definition. Also used in parallel switchers. -parAux :: Functor col => - (forall sf . (a -> col sf -> col (b, sf))) - -> col (SF' b c) - -> SF' a (col c) +parAux :: Functor col + => (forall sf . (a -> col sf -> col (b, sf))) + -> col (SF' b c) + -> SF' a (col c) parAux rf sfs = SF' tf -- True where - tf dt a = - let bsfs = rf a sfs - sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs - sfs' = fmap fst sfcs' - cs = fmap snd sfcs' - in (parAux rf sfs', cs) + tf dt a = (parAux rf sfs', cs) + where + bsfs = rf a sfs + sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs + sfs' = fmap fst sfcs' + cs = fmap snd sfcs' -- | Parallel switch parameterized on the routing function. This is the most --- general switch from which all other (non-delayed) switches in principle --- can be derived. The signal function collection is spatially composed in --- parallel and run until the event signal function has an occurrence. Once --- the switching event occurs, all signal function are "frozen" and their --- continuations are passed to the continuation function, along with the --- event value. +-- general switch from which all other (non-delayed) switches in principle can +-- be derived. The signal function collection is spatially composed in parallel +-- and run until the event signal function has an occurrence. Once the switching +-- event occurs, all signal function are "frozen" and their continuations are +-- passed to the continuation function, along with the event value. pSwitch :: Functor col => (forall sf . (a -> col sf -> col (b, sf))) - -- ^ Routing function: determines the input to each signal - -- function in the collection. IMPORTANT! The routing function - -- has an obligation to preserve the structure of the signal - -- function collection. + -- ^ Routing function: determines the input to each signal function + -- in the collection. IMPORTANT! The routing function has an + -- obligation to preserve the structure of the signal function + -- collection. -> col (SF b c) - -- ^ Signal function collection. + -- ^ Signal function collection. -> SF (a, col c) (Event d) - -- ^ Signal function generating the switching event. + -- ^ Signal function generating the switching event. -> (col (SF b c) -> d -> SF a (col c)) - -- ^ Continuation to be invoked once event occurs. + -- ^ Continuation to be invoked once event occurs. -> SF a (col c) pSwitch rf sfs0 sfe0 k = SF {sfTF = tf0} where - tf0 a0 = - let bsfs0 = rf a0 sfs0 - sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0 - sfs = fmap fst sfcs0 - cs0 = fmap snd sfcs0 - in case (sfTF sfe0) (a0, cs0) of - (sfe, NoEvent) -> (pSwitchAux sfs sfe, cs0) - (_, Event d0) -> sfTF (k sfs0 d0) a0 + tf0 a0 = case (sfTF sfe0) (a0, cs0) of + (sfe, NoEvent) -> (pSwitchAux sfs sfe, cs0) + (_, Event d0) -> sfTF (k sfs0 d0) a0 + where + bsfs0 = rf a0 sfs0 + sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0 + sfs = fmap fst sfcs0 + cs0 = fmap snd sfcs0 pSwitchAux sfs (SFArr _ (FDC NoEvent)) = parAux rf sfs - pSwitchAux sfs sfe = SF' tf -- False + pSwitchAux sfs sfe = SF' tf -- False where - tf dt a = - let bsfs = rf a sfs - sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs - sfs' = fmap fst sfcs' - cs = fmap snd sfcs' - in case (sfTF' sfe) dt (a, cs) of - (sfe', NoEvent) -> (pSwitchAux sfs' sfe', cs) - (_, Event d) -> sfTF (k (freezeCol sfs dt) d) a + tf dt a = case (sfTF' sfe) dt (a, cs) of + (sfe', NoEvent) -> (pSwitchAux sfs' sfe', cs) + (_, Event d) -> sfTF (k (freezeCol sfs dt) d) a + where + bsfs = rf a sfs + sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs + sfs' = fmap fst sfcs' + cs = fmap snd sfcs' -- | Parallel switch with delayed observation parameterized on the routing -- function. -- --- The collection argument to the function invoked on the --- switching event is of particular interest: it captures the --- continuations of the signal functions running in the collection --- maintained by 'dpSwitch' at the time of the switching event, --- thus making it possible to preserve their state across a switch. --- Since the continuations are plain, ordinary signal functions, --- they can be resumed, discarded, stored, or combined with --- other signal functions. +-- The collection argument to the function invoked on the switching event is of +-- particular interest: it captures the continuations of the signal functions +-- running in the collection maintained by 'dpSwitch' at the time of the +-- switching event, thus making it possible to preserve their state across a +-- switch. Since the continuations are plain, ordinary signal functions, they +-- can be resumed, discarded, stored, or combined with other signal functions. dpSwitch :: Functor col => (forall sf . (a -> col sf -> col (b, sf))) - -- ^ Routing function. Its purpose is to pair up each running - -- signal function in the collection maintained by 'dpSwitch' - -- with the input it is going to see at each point in time. All - -- the routing function can do is specify how the input is - -- distributed. + -- ^ Routing function. Its purpose is to pair up each running signal + -- function in the collection maintained by 'dpSwitch' with the + -- input it is going to see at each point in time. All the routing + -- function can do is specify how the input is distributed. -> col (SF b c) - -- ^ Initial collection of signal functions. + -- ^ Initial collection of signal functions. -> SF (a, col c) (Event d) - -- ^ Signal function that observes the external input signal and - -- the output signals from the collection in order to produce a - -- switching event. + -- ^ Signal function that observes the external input signal and the + -- output signals from the collection in order to produce a + -- switching event. -> (col (SF b c) -> d -> SF a (col c)) - -- ^ The fourth argument is a function that is invoked when the - -- switching event occurs, yielding a new signal function to - -- switch into based on the collection of signal functions - -- previously running and the value carried by the switching - -- event. This allows the collection to be updated and then - -- switched back in, typically by employing 'dpSwitch' again. + -- ^ The fourth argument is a function that is invoked when the + -- switching event occurs, yielding a new signal function to switch + -- into based on the collection of signal functions previously + -- running and the value carried by the switching event. This allows + -- the collection to be updated and then switched back in, typically + -- by employing 'dpSwitch' again. -> SF a (col c) dpSwitch rf sfs0 sfe0 k = SF {sfTF = tf0} where - tf0 a0 = - let bsfs0 = rf a0 sfs0 - sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0 - cs0 = fmap snd sfcs0 - in ( case (sfTF sfe0) (a0, cs0) of - (sfe, NoEvent) -> dpSwitchAux (fmap fst sfcs0) sfe - (_, Event d0) -> fst (sfTF (k sfs0 d0) a0) - , cs0 - ) + tf0 a0 = ( case (sfTF sfe0) (a0, cs0) of + (sfe, NoEvent) -> dpSwitchAux (fmap fst sfcs0) sfe + (_, Event d0) -> fst (sfTF (k sfs0 d0) a0) + , cs0 + ) + where + bsfs0 = rf a0 sfs0 + sfcs0 = fmap (\(b0, sf0) -> (sfTF sf0) b0) bsfs0 + cs0 = fmap snd sfcs0 dpSwitchAux sfs (SFArr _ (FDC NoEvent)) = parAux rf sfs dpSwitchAux sfs sfe = SF' tf -- False where - tf dt a = - let bsfs = rf a sfs - sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs - cs = fmap snd sfcs' - in ( case (sfTF' sfe) dt (a, cs) of - (sfe', NoEvent) -> dpSwitchAux (fmap fst sfcs') sfe' - (_, Event d) -> fst (sfTF (k (freezeCol sfs dt) d) a) - , cs - ) + tf dt a = ( case (sfTF' sfe) dt (a, cs) of + (sfe', NoEvent) -> dpSwitchAux (fmap fst sfcs') sfe' + (_, Event d) -> fst (sfTF (k (freezeCol sfs dt) d) a) + , cs + ) + where + bsfs = rf a sfs + sfcs' = fmap (\(b, sf) -> (sfTF' sf) dt b) bsfs + cs = fmap snd sfcs' -- | Recurring parallel switch parameterized on the routing function. -- --- Uses the given collection of SFs, until an event comes in the input, in --- which case the function in the 'Event' is used to transform the collections --- of SF to be used with 'rpSwitch' again, until the next event comes in the --- input, and so on. +-- Uses the given collection of SFs, until an event comes in the input, in which +-- case the function in the 'Event' is used to transform the collections of SF +-- to be used with 'rpSwitch' again, until the next event comes in the input, +-- and so on. -- --- The routing function is used to decide which subpart of the input --- goes to each SF in the collection. +-- The routing function is used to decide which subpart of the input goes to +-- each SF in the collection. -- -- This is the parallel version of 'rSwitch'. rpSwitch :: Functor col => (forall sf . (a -> col sf -> col (b, sf))) - -- ^ Routing function: determines the input to each signal - -- function in the collection. IMPORTANT! The routing function - -- has an obligation to preserve the structure of the signal - -- function collection. + -- ^ Routing function: determines the input to each signal function + -- in the collection. IMPORTANT! The routing function has an + -- obligation to preserve the structure of the signal function + -- collection. -> col (SF b c) - -- ^ Initial signal function collection. + -- ^ Initial signal function collection. -> SF (a, Event (col (SF b c) -> col (SF b c))) (col c) rpSwitch rf sfs = pSwitch (rf . fst) sfs (arr (snd . fst)) $ \sfs' f -> @@ -586,48 +583,47 @@ -- | Recurring parallel switch with delayed observation parameterized on the -- routing function. -- --- Uses the given collection of SFs, until an event comes in the input, in --- which case the function in the 'Event' is used to transform the collections --- of SF to be used with 'rpSwitch' again, until the next event comes in the --- input, and so on. +-- Uses the given collection of SFs, until an event comes in the input, in which +-- case the function in the 'Event' is used to transform the collections of SF +-- to be used with 'rpSwitch' again, until the next event comes in the input, +-- and so on. -- --- The routing function is used to decide which subpart of the input --- goes to each SF in the collection. +-- The routing function is used to decide which subpart of the input goes to +-- each SF in the collection. -- -- This is the parallel version of 'drSwitch'. drpSwitch :: Functor col => (forall sf . (a -> col sf -> col (b, sf))) - -- ^ Routing function: determines the input to each signal - -- function in the collection. IMPORTANT! The routing function - -- has an obligation to preserve the structure of the signal - -- function collection. + -- ^ Routing function: determines the input to each signal function + -- in the collection. IMPORTANT! The routing function has an + -- obligation to preserve the structure of the signal function + -- collection. -> col (SF b c) - -- ^ Initial signal function collection. + -- ^ Initial signal function collection. -> SF (a, Event (col (SF b c) -> col (SF b c))) (col c) drpSwitch rf sfs = dpSwitch (rf . fst) sfs (arr (snd . fst)) $ \sfs' f -> - noEventSnd >=- drpSwitch rf (f sfs') + noEventSnd >=- drpSwitch rf (f sfs') -- * Parallel composition/switchers with "zip" routing -- | Parallel composition of a list of SFs. -- --- Given a list of SFs, returns an SF that takes a list of inputs, applies --- each SF to each input in order, and returns the SFs' outputs. +-- Given a list of SFs, returns an SF that takes a list of inputs, applies each +-- SF to each input in order, and returns the SFs' outputs. -- --- >>> embed (parZ [arr (+1), arr (+2)]) (deltaEncode 0.1 [[0, 0], [1, 1]]) --- [[1,2],[2,3]] +-- >>> embed (parZ [arr (+1), arr (+2)]) (deltaEncode 0.1 [[0, 0], [1, 1]]) +-- [[1,2],[2,3]] -- --- If there are more SFs than inputs, an exception is thrown. +-- If there are more SFs than inputs, an exception is thrown. -- --- >>> embed (parZ [arr (+1), arr (+1), arr (+2)]) (deltaEncode 0.1 [[0, 0], [1, 1]]) --- [[1,1,*** Exception: FRP.Yampa.Switches.parZ: Input list too short. +-- >>> embed (parZ [arr (+1), arr (+1), arr (+2)]) (deltaEncode 0.1 [[0, 0], [1, 1]]) +-- [[1,1,*** Exception: FRP.Yampa.Switches.parZ: Input list too short. -- --- If there are more inputs than SFs, the unused inputs are ignored. +-- If there are more inputs than SFs, the unused inputs are ignored. -- --- >>> embed (parZ [arr (+1)]) (deltaEncode 0.1 [[0, 0], [1, 1]]) --- [[1],[2]] - +-- >>> embed (parZ [arr (+1)]) (deltaEncode 0.1 [[0, 0], [1, 1]]) +-- [[1],[2]] parZ :: [SF a b] -> SF [a] [b] parZ = par (safeZip "parZ") @@ -636,17 +632,21 @@ -- -- For more information on how parallel composition works, check -- -pSwitchZ :: [SF a b] -> SF ([a],[b]) (Event c) -> ([SF a b] -> c -> SF [a] [b]) - -> SF [a] [b] +pSwitchZ :: [SF a b] + -> SF ([a], [b]) (Event c) + -> ([SF a b] -> c -> SF [a] [b]) + -> SF [a] [b] pSwitchZ = pSwitch (safeZip "pSwitchZ") --- | Decoupled parallel switch with broadcasting (dynamic collection of --- signal functions spatially composed in parallel). See 'dpSwitch'. +-- | Decoupled parallel switch with broadcasting (dynamic collection of signal +-- functions spatially composed in parallel). See 'dpSwitch'. -- -- For more information on how parallel composition works, check -- -dpSwitchZ :: [SF a b] -> SF ([a],[b]) (Event c) -> ([SF a b] -> c ->SF [a] [b]) - -> SF [a] [b] +dpSwitchZ :: [SF a b] + -> SF ([a], [b]) (Event c) + -> ([SF a b] -> c -> SF [a] [b]) + -> SF [a] [b] dpSwitchZ = dpSwitch (safeZip "dpSwitchZ") -- | Recurring parallel switch with "zip" routing. @@ -681,7 +681,7 @@ drpSwitchZ :: [SF a b] -> SF ([a], Event ([SF a b] -> [SF a b])) [b] drpSwitchZ = drpSwitch (safeZip "drpSwitchZ") -safeZip :: String -> [a] -> [b] -> [(a,b)] +safeZip :: String -> [a] -> [b] -> [(a, b)] safeZip fn l1 l2 = safeZip' l1 l2 where safeZip' :: [a] -> [b] -> [(a, b)] @@ -709,24 +709,23 @@ -- | Apply an SF to every element of a list. -- --- Example: +-- Example: -- --- >>> embed (parC integral) (deltaEncode 0.1 [[1, 2], [2, 4], [3, 6], [4.0, 8.0 :: Float]]) --- [[0.0,0.0],[0.1,0.2],[0.3,0.6],[0.6,1.2]] +-- >>> embed (parC integral) (deltaEncode 0.1 [[1, 2], [2, 4], [3, 6], [4.0, 8.0 :: Float]]) +-- [[0.0,0.0],[0.1,0.2],[0.3,0.6],[0.6,1.2]] -- --- The number of SFs or expected inputs is determined by the first input --- list, and not expected to vary over time. +-- The number of SFs or expected inputs is determined by the first input list, +-- and not expected to vary over time. -- --- If more inputs come in a subsequent list, they are ignored. +-- If more inputs come in a subsequent list, they are ignored. -- --- >>> embed (parC (arr (+1))) (deltaEncode 0.1 [[0], [1, 1], [3, 4], [6, 7, 8], [1, 1], [0, 0], [1, 9, 8]]) --- [[1],[2],[4],[7],[2],[1],[2]] +-- >>> embed (parC (arr (+1))) (deltaEncode 0.1 [[0], [1, 1], [3, 4], [6, 7, 8], [1, 1], [0, 0], [1, 9, 8]]) +-- [[1],[2],[4],[7],[2],[1],[2]] -- --- If less inputs come in a subsequent list, an exception is thrown. +-- If less inputs come in a subsequent list, an exception is thrown. -- --- >>> embed (parC (arr (+1))) (deltaEncode 0.1 [[0, 0], [1, 1], [3, 4], [6, 7, 8], [1, 1], [0, 0], [1, 9, 8]]) --- [[1,1],[2,2],[4,5],[7,8],[2,2],[1,1],[2,10]] - +-- >>> embed (parC (arr (+1))) (deltaEncode 0.1 [[0, 0], [1, 1], [3, 4], [6, 7, 8], [1, 1], [0, 0], [1, 9, 8]]) +-- [[1,1],[2,2],[4,5],[7,8],[2,2],[1,1],[2,10]] parC :: SF a b -> SF [a] [b] parC sf = SF $ \as -> let os = map (sfTF sf) as bs = map snd os @@ -737,11 +736,11 @@ parCAux :: [SF' a b] -> SF' [a] [b] parCAux sfs = SF' tf where - tf dt as = - let os = map (\(a,sf) -> sfTF' sf dt a) $ safeZip "parC" as sfs - bs = map snd os - sfcs = map fst os - in (listSeq sfcs `seq` parCAux sfcs, listSeq bs) + tf dt as = (listSeq sfcs `seq` parCAux sfcs, listSeq bs) + where + os = map (\(a, sf) -> sfTF' sf dt a) $ safeZip "parC" as sfs + bs = map snd os + sfcs = map fst os listSeq :: [a] -> [a] listSeq x = x `seq` (listSeq' x) diff --git a/src/FRP/Yampa/Task.hs b/src/FRP/Yampa/Task.hs --- a/src/FRP/Yampa/Task.hs +++ b/src/FRP/Yampa/Task.hs @@ -1,36 +1,44 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} -- | --- Module : FRP.Yampa.Task --- Copyright : (c) Ivan Perez, 2014-2022 --- (c) George Giorgidze, 2007-2012 --- (c) Henrik Nilsson, 2005-2006 --- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 --- License : BSD-style (see the LICENSE file in the distribution) +-- Module : FRP.Yampa.Task +-- Copyright : (c) Ivan Perez, 2014-2022 +-- (c) George Giorgidze, 2007-2012 +-- (c) Henrik Nilsson, 2005-2006 +-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 +-- License : BSD-style (see the LICENSE file in the distribution) -- --- Maintainer : ivan.perez@keera.co.uk --- Stability : provisional --- Portability : non-portable (GHC extensions) +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) -- -- Task abstraction on top of signal transformers. module FRP.Yampa.Task - ( Task + ( + -- * The Task type + Task , mkTask , runTask , runTask_ , taskToSF + + -- * Basic tasks , constT , sleepT , snapT + + -- * Basic tasks combinators , timeOut , abortWhen ) where +-- External imports #if __GLASGOW_HASKELL__ < 710 import Control.Applicative (Applicative(..)) #endif +-- Internal imports import FRP.Yampa.Basic (constant) import FRP.Yampa.Diagnostics (intErr, usrErr) import FRP.Yampa.Event (Event, lMerge) @@ -43,12 +51,10 @@ -- * The Task type -- | A task is a partially SF that may terminate with a result. - newtype Task a b c = - -- CPS-based representation allowing termination to be detected. - -- (Note the rank 2 polymorphic type!) - -- The representation can be changed if necessary, but the Monad laws - -- follow trivially in this case. + -- CPS-based representation allowing termination to be detected. Note the + -- rank 2 polymorphic type! The representation can be changed if necessary, + -- but the Monad laws follow trivially in this case. Task (forall d . (c -> SF a (Either b d)) -> SF a (Either b d)) unTask :: Task a b c -> ((c -> SF a (Either b d)) -> SF a (Either b d)) @@ -62,9 +68,9 @@ -- | Runs a task. -- -- The output from the resulting signal transformer is tagged with Left while --- the underlying task is running. Once the task has terminated, the output --- goes constant with the value Right x, where x is the value of the --- terminating event. +-- the underlying task is running. Once the task has terminated, the output goes +-- constant with the value Right x, where x is the value of the terminating +-- event. -- Check name. runTask :: Task a b c -> SF a (Either b c) @@ -80,8 +86,8 @@ >>> arr (either id (usrErr "YampaTask" "runTask_" "Task terminated!")) --- | Creates an SF that represents an SF and produces an event --- when the task terminates, and otherwise produces just an output. +-- | Creates an SF that represents an SF and produces an event when the task +-- terminates, and otherwise produces just an output. taskToSF :: Task a b c -> SF a (b, Event c) taskToSF tk = runTask tk >>> (arr (either id (usrErr "YampaTask" "runTask_" @@ -153,7 +159,6 @@ -- No time passes; therefore, the following must hold: -- -- @snapT >> snapT = snapT@ - snapT :: Task a b a snapT = mkTask (constant (intErr "YampaTask" "snapT" "Bad switch?") &&& snap) @@ -163,21 +168,21 @@ timeOut :: Task a b c -> Time -> Task a b (Maybe c) tk `timeOut` t = mkTask ((taskToSF tk &&& after t ()) >>> arr aux) where - aux ((b, ec), et) = (b, (lMerge (fmap Just ec) (fmap (const Nothing) et))) + aux ((b, ec), et) = (b, lMerge (fmap Just ec) (fmap (const Nothing) et)) --- | Run a "guarding" event source (SF a (Event b)) in parallel with a --- (possibly non-terminating) task. +-- | Run a "guarding" event source (SF a (Event b)) in parallel with a (possibly +-- non-terminating) task. -- -- The task will be aborted at the first occurrence of the event source (if it -- has not terminated itself before that). -- -- Useful for separating sequencing and termination concerns. E.g. we can do --- something "useful", but in parallel watch for a (exceptional) condition --- which should terminate that activity, without having to check for that --- condition explicitly during each and every phase of the activity. +-- something "useful", but in parallel watch for a (exceptional) condition which +-- should terminate that activity, without having to check for that condition +-- explicitly during each and every phase of the activity. -- -- Example: @tsk `abortWhen` lbp@ abortWhen :: Task a b c -> SF a (Event d) -> Task a b (Either c d) tk `abortWhen` est = mkTask ((taskToSF tk &&& est) >>> arr aux) where - aux ((b, ec), ed) = (b, (lMerge (fmap Left ec) (fmap Right ed))) + aux ((b, ec), ed) = (b, lMerge (fmap Left ec) (fmap Right ed)) diff --git a/src/FRP/Yampa/Time.hs b/src/FRP/Yampa/Time.hs --- a/src/FRP/Yampa/Time.hs +++ b/src/FRP/Yampa/Time.hs @@ -1,19 +1,19 @@ -- | --- Module : FRP.Yampa.Time --- Copyright : (c) Ivan Perez, 2014-2022 --- (c) George Giorgidze, 2007-2012 --- (c) Henrik Nilsson, 2005-2006 --- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 --- License : BSD-style (see the LICENSE file in the distribution) +-- Module : FRP.Yampa.Time +-- Copyright : (c) Ivan Perez, 2014-2022 +-- (c) George Giorgidze, 2007-2012 +-- (c) Henrik Nilsson, 2005-2006 +-- (c) Antony Courtney and Henrik Nilsson, Yale University, 2003-2004 +-- License : BSD-style (see the LICENSE file in the distribution) -- --- Maintainer : ivan.perez@keera.co.uk --- Stability : provisional --- Portability : non-portable (GHC extensions) +-- Maintainer : ivan.perez@keera.co.uk +-- Stability : provisional +-- Portability : non-portable (GHC extensions) -- -- SF primitives that producing the current running time. -- --- Time is global for an 'SF', so, every constituent 'SF' will use the --- same global clock. However, when used in combination with +-- Time is global for an 'SF', so, every constituent 'SF' will use the same +-- global clock. However, when used in combination with -- 'FRP.Yampa.Switches.switch'ing, the SF switched into will be started at the -- time of switching, so any reference to 'localTime' or 'time' from that 'SF' -- will count using the time of switching as the start time. @@ -29,8 +29,10 @@ ) where -import Control.Arrow +-- External imports +import Control.Arrow ((>>>)) +-- Internal imports import FRP.Yampa.Basic (constant) import FRP.Yampa.Integration (integral) import FRP.Yampa.InternalCore (SF, Time)