reflex 0.7.2.0 → 0.9.4.1
raw patch · 57 files changed
Files
- ChangeLog.md +93/−1
- README.md +5/−4
- bench/Main.hs +1/−5
- bench/RunAll.hs +5/−0
- reflex.cabal +460/−436
- src/Control/Monad/ReaderIO.hs +4/−10
- src/Data/AppendMap.hs +1/−11
- src/Data/FastMutableIntMap.hs +1/−0
- src/Data/FastWeakBag.hs +1/−3
- src/Data/Map/Misc.hs +1/−0
- src/Data/WeakBag.hs +1/−3
- src/Reflex.hs +1/−2
- src/Reflex/Adjustable/Class.hs +1/−3
- src/Reflex/BehaviorWriter/Base.hs +12/−4
- src/Reflex/BehaviorWriter/Class.hs +1/−3
- src/Reflex/Class.hs +16/−20
- src/Reflex/Collection.hs +15/−12
- src/Reflex/Dynamic.hs +18/−17
- src/Reflex/Dynamic/TH.hs +16/−18
- src/Reflex/Dynamic/Uniq.hs +6/−6
- src/Reflex/DynamicWriter/Base.hs +18/−10
- src/Reflex/DynamicWriter/Class.hs +1/−3
- src/Reflex/EventWriter/Base.hs +6/−3
- src/Reflex/EventWriter/Class.hs +4/−3
- src/Reflex/FunctorMaybe.hs +3/−5
- src/Reflex/Host/Class.hs +7/−7
- src/Reflex/Host/Headless.hs +52/−31
- src/Reflex/Network.hs +4/−6
- src/Reflex/NotReady/Class.hs +2/−3
- src/Reflex/Optimizer.hs +0/−65
- src/Reflex/PerformEvent/Base.hs +17/−13
- src/Reflex/PerformEvent/Class.hs +12/−8
- src/Reflex/PostBuild/Base.hs +29/−14
- src/Reflex/PostBuild/Class.hs +1/−3
- src/Reflex/Profiled.hs +10/−4
- src/Reflex/Pure.hs +2/−8
- src/Reflex/Query/Base.hs +17/−10
- src/Reflex/Query/Class.hs +11/−5
- src/Reflex/Requester/Base.hs +2/−523
- src/Reflex/Requester/Base/Internal.hs +596/−0
- src/Reflex/Requester/Class.hs +8/−5
- src/Reflex/Spider.hs +12/−11
- src/Reflex/Spider/Internal.hs +111/−79
- src/Reflex/Time.hs +18/−23
- src/Reflex/TriggerEvent/Base.hs +12/−3
- src/Reflex/TriggerEvent/Class.hs +1/−0
- src/Reflex/Widget/Basic.hs +0/−3
- src/Reflex/Workflow.hs +6/−4
- test/DebugCycles.hs +1/−1
- test/QueryT.hs +3/−2
- test/Reflex/Bench/Focused.hs +10/−3
- test/Reflex/Plan/Reflex.hs +1/−0
- test/Reflex/Test/CrossImpl.hs +2/−0
- test/Reflex/Test/Micro.hs +42/−0
- test/RequesterT.hs +12/−11
- test/behaviorLeak.hs +79/−0
- test/hlint.hs +1/−1
ChangeLog.md view
@@ -1,7 +1,99 @@ # Revision history for reflex -## 0.7.2.0+## 0.9.4.1++* Bug fix for `CausalityLoopException`s caused by incorrect coincidence and merge height invalidation by @parenthetical in [#536](https://github.com/reflex-frp/reflex/pull/536).+* Space leak fixed: Applicative combination of Behaviors, with at least one never changing, no longer causes unbounded memory growth by @parenthetical in [#535](https://github.com/reflex-frp/reflex/pull/535).+* Stray debug print removed from non-debug builds.++## 0.9.4.0++* Add note about `requesting` semantics by @LightAndLight in https://github.com/reflex-frp/reflex/pull/508+* Dropped lens by @ilyakooo0 in https://github.com/reflex-frp/reflex/pull/463+* Build with ghc(js) 9.8.2 + 9.10.1 + 9.12.2 by @ymeister in https://github.com/reflex-frp/reflex/pull/502+* headless: Add MonadThrow (Performable m) by @ali-abrar in https://github.com/reflex-frp/reflex/pull/523+* Don't check in newSubscriberCoincidenceInner whether occRef is already set by @parenthetical in https://github.com/reflex-frp/reflex/pull/496+* Always enable Template Haskell by @Ericson2314 in https://github.com/reflex-frp/reflex/pull/484++## 0.9.3.4++* Support random 1.3++## 0.9.3.3++* Add support for GHC 9.12+* Loosen version bounds++## 0.9.3.2++* Add support for witherable 0.5++## 0.9.3.1++* Add support for GHC 9.8 and 9.10++## 0.9.3.0++* Headless Host: Generalize to allow returning arbitrary types++## 0.9.2.0++* Add MonadMask, MonadCatch, MonadThrow instances++## 0.9.1.0++* Headless Host: Add some MonadSample, MonadHold, and MonadFix instances++## 0.9.0.1++* Add support for ghc-9.6++## 0.9.0.0++* Breaking Change: Filter updates to `listWithKey` child widgets so that changes to the input Map don't cause spurious updates to unaffected children. This imposes an `Eq` constraint on the child values.+* Expose all Requester internals in Reflex.Requester.Base.Internal+* [Add EventWriter instance for RequesterT #469](https://github.com/reflex-frp/reflex/pull/469)++## 0.8.2.2++* Require witherable >= 0.4 and, hence, a newer monoidal-containers+* Support newer constraints-extras (0.4)++## 0.8.2.1++* Fix build for GHC 9.2+* Require patch >= 0.0.7.0++## 0.8.2.0++* Add `matchResponseMapWithRequests`, which it similar to `matchResponsesWithRequests` but allows processing of multiple responses at once.++## 0.8.1.1++* Allow newer hlint for older GHCs, and add upper bound for newer GHCs++## 0.8.1.0++* Add support for GHC 8.10+* Drop support for GHC < 8.4++## 0.8.0.0++* Replace 0.7.2.0 with 0.8.0.0 to reflect the `MonadHold` interface change. Deprecates 0.7.2.0.++## 0.7.2.0 -- *Deprecated*+ * ([#416](https://github.com/reflex-frp/reflex/pull/416)) Add `now :: m (Event t ())` to `MonadHold`.+* Extend some dependency version bounds+* Fix HLint 3 test++## 0.7.1.1++*Backport release*.+Changes do not carry forward to 0.7.2.0.++* Add support for GHC 8.10+* Drop support for GHC < 8.4 * Extend some dependency version bounds * Fix HLint 3 test
README.md view
@@ -1,6 +1,6 @@-## [Reflex](https://reflex-frp.org/)+# [Reflex](https://reflex-frp.org/) -[](https://haskell.org) [](https://hackage.haskell.org/package/reflex) [](https://matrix.hackage.haskell.org/#/package/reflex) [](https://travis-ci.org/reflex-frp/reflex) [](https://github.com/reflex-frp/reflex/blob/master/LICENSE)+[](https://haskell.org) [](https://hackage.haskell.org/package/reflex) [](https://github.com/reflex-frp/reflex/blob/master/LICENSE) Interactive programs without callbacks or side-effects. Functional Reactive Programming (FRP) uses composable events and time-varying values to describe interactive systems as pure functions. Just like other pure functional code, functional reactive code is easier to get right on the first try, maintain, and reuse. @@ -8,16 +8,17 @@ **Visit https://reflex-frp.org for more information, tutorials, documentation and [examples](https://examples.reflex-frp.org/).** -### Resources+## Resources * [Official Website](https://reflex-frp.org) * [Quick Reference](Quickref.md) * [Reflex-DOM](https://github.com/reflex-frp/reflex-dom): A framework built on Reflex that facilitates the development of web pages, including highly-interactive single-page apps. * [Obelisk](https://github.com/obsidiansystems/obelisk#obelisk): A framework built on Reflex and Reflex-DOM for functional reactive web and mobile applications, with batteries included. * [Get started with Reflex](https://github.com/reflex-frp/reflex-platform)+* [#reflex-frp:matrix.org](https://matrix.to/#/#reflex-frp:matrix.org): Official Matrix room * [/r/reflexfrp](https://www.reddit.com/r/reflexfrp) * [irc.freenode.net #reflex-frp](http://webchat.freenode.net?channels=%23reflex-frp&uio=d4) -### Hacking+## Hacking From the root of a [Reflex Platform](https://github.com/reflex-frp/reflex-platform) checkout, run `./scripts/hack-on haskell-overlays/reflex-packages/dep/reflex`. This will check out the reflex source code into the `haskell-overlays/reflex-packages/dep/reflex` directory. You can then point that checkout at your fork, make changes, etc. Use the `./try-reflex` or `./scripts/work-on` scripts to start a shell in which you can test your changes.
bench/Main.hs view
@@ -12,6 +12,7 @@ import Control.Concurrent.STM import Control.DeepSeq import Control.Exception (evaluate)+import Control.Monad import Control.Monad.Identity import Control.Monad.IO.Class import Criterion.Main@@ -27,11 +28,6 @@ main :: IO () main = defaultMain [ bgroup "micro" micros ]--#if !(MIN_VERSION_deepseq(1,4,2))-instance NFData (IORef a) where- rnf x = seq x ()-#endif instance NFData (TVar a) where rnf x = seq x ()
bench/RunAll.hs view
@@ -121,6 +121,7 @@ firing n = group ("firing " <> show n) $ Focused.firing n merging n = group ("merging " <> show n) $ Focused.merging n dynamics n = group ("dynamics " <> show n) $ Focused.dynamics n+ shared w = group ("sharedInvalidators " <> show w) $ Focused.sharedInvalidators w cases = concat [ sub 100 40 , dynamics 100@@ -131,6 +132,10 @@ , merging 50 , merging 100 , merging 200+ , shared 30+ , shared 100+ , shared 300+ , shared 1000 ] pattern RunTestCaseFlag = "--run-test-case"
reflex.cabal view
@@ -1,499 +1,523 @@-Name: reflex-Version: 0.7.2.0-Synopsis: Higher-order Functional Reactive Programming-Description:- Interactive programs without callbacks or side-effects.- Functional Reactive Programming (FRP) uses composable events and time-varying- values to describe interactive systems as pure functions.- Just like other pure functional code, functional reactive code is easier- to get right on the first try, maintain, and reuse.- .- Reflex is a fully-deterministic, higher-order Functional Reactive Programming- interface and an engine that efficiently implements that interface.- .- <https://reflex-frp.org>-License: BSD3-License-file: LICENSE-Author: Ryan Trinkle-Maintainer: ryan.trinkle@gmail.com-Stability: Experimental-Category: FRP-Build-type: Simple-Cabal-version: 1.22-homepage: https://reflex-frp.org-bug-reports: https://github.com/reflex-frp/reflex/issues-extra-source-files:- README.md- Quickref.md- ChangeLog.md-+cabal-version: 1.22+name: reflex+version: 0.9.4.1+license: BSD3+license-file: LICENSE+maintainer: ryan.trinkle@gmail.com+author: Ryan Trinkle+stability: Experimental tested-with:- GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.1,- GHCJS ==8.4+ ghc ==8.4.4 || ==8.6.5 || ==8.8.1 || ==8.10.7 || ==9.0.1 || ==9.2.5 || ==9.4.5 || ==9.6.1 || ==9.8.2 || ==9.10.1 || ==9.12.2 -flag use-reflex-optimizer- description: Use the GHC plugin Reflex.Optimizer on some of the modules in the package. This is still experimental.- default: False- manual: True+homepage: https://reflex-frp.org+bug-reports: https://github.com/reflex-frp/reflex/issues+synopsis: Higher-order Functional Reactive Programming+description:+ Interactive programs without callbacks or side-effects.+ Functional Reactive Programming (FRP) uses composable events and time-varying+ values to describe interactive systems as pure functions.+ Just like other pure functional code, functional reactive code is easier+ to get right on the first try, maintain, and reuse.+ .+ Reflex is a fully-deterministic, higher-order Functional Reactive Programming+ interface and an engine that efficiently implements that interface.+ .+ <https://reflex-frp.org> -flag use-template-haskell- description: Use template haskell to generate lenses- default: True- manual: True+category: FRP+build-type: Simple+extra-source-files:+ README.md+ Quickref.md+ ChangeLog.md +source-repository head+ type: git+ location: https://github.com/reflex-frp/reflex+ flag debug-trace-events- description: Add instrumentation that outputs the stack trace of the definition of an event whenever it is subscribed to. Warning: It is very slow!- default: False- manual: True+ description:+ Add instrumentation that outputs the stack trace of the definition of an event whenever it is subscribed to. Warning: It is very slow! + default: False+ manual: True+ flag fast-weak- description: Use the primitive implementation of FastWeak in GHCJS; note that this requires GHCJS to be built with FastWeak and FastWeakBag present in the RTS, which is not the default- default: False- manual: True+ description:+ Use the primitive implementation of FastWeak in GHCJS; note that this requires GHCJS to be built with FastWeak and FastWeakBag present in the RTS, which is not the default + default: False+ manual: True+ flag debug-propagation- description: Enable debugging of spider internals- default: False- manual: True+ description: Enable debugging of spider internals+ default: False+ manual: True flag debug-cycles- description: Enable debugging of event cycles- default: False- manual: True+ description: Enable debugging of event cycles+ default: False+ manual: True flag split-these- description: Use split these/semialign packages- manual: False- default: True+ description: Use split these/semialign packages+ manual: False+ default: True library- default-language: Haskell2010- hs-source-dirs: src- build-depends:- MemoTrie == 0.6.*,- base >= 4.9 && < 4.14,- bifunctors >= 5.2 && < 5.6,- comonad >= 5.0.4 && < 5.1,- constraints-extras >= 0.3 && < 0.4,- containers >= 0.6 && < 0.7,- data-default >= 0.5 && < 0.8,- dependent-map >= 0.3 && < 0.5,- exception-transformers == 0.4.*,- lens >= 4.7 && < 5,- mmorph >= 1.0 && < 1.2,- monad-control >= 1.0.1 && < 1.1,- mtl >= 2.1 && < 2.3,- patch >= 0.0.1 && < 0.1,- prim-uniq >= 0.1.0.1 && < 0.3,- primitive >= 0.5 && < 0.8,- profunctors >= 5.3 && < 5.6,- random == 1.1.*,- ref-tf == 0.4.*,- reflection == 2.1.*,- semigroupoids >= 4.0 && < 6,- stm >= 2.4 && < 2.6,- syb >= 0.5 && < 0.8,- time >= 1.4 && < 1.10,- transformers >= 0.5.6.0 && < 0.6,- unbounded-delays >= 0.1.0.0 && < 0.2,- witherable >= 0.3 && < 0.4+ exposed-modules:+ Control.Monad.ReaderIO+ Data.AppendMap+ Data.FastMutableIntMap+ Data.FastWeakBag+ Data.Map.Misc+ Data.WeakBag+ Reflex+ Reflex.Class+ Reflex.Adjustable.Class+ Reflex.BehaviorWriter.Base+ Reflex.BehaviorWriter.Class+ Reflex.Collection+ Reflex.Dynamic+ Reflex.Dynamic.TH+ Reflex.Dynamic.Uniq+ Reflex.DynamicWriter+ Reflex.DynamicWriter.Base+ Reflex.DynamicWriter.Class+ Reflex.EventWriter+ Reflex.EventWriter.Base+ Reflex.EventWriter.Class+ Reflex.FastWeak+ Reflex.FunctorMaybe+ Reflex.Host.Class+ Reflex.Host.Headless+ Reflex.Network+ Reflex.NotReady.Class+ Reflex.PerformEvent.Base+ Reflex.PerformEvent.Class+ Reflex.PostBuild.Base+ Reflex.PostBuild.Class+ Reflex.Profiled+ Reflex.Pure+ Reflex.Query.Base+ Reflex.Query.Class+ Reflex.Requester.Base+ Reflex.Requester.Base.Internal+ Reflex.Requester.Class+ Reflex.Spider+ Reflex.Spider.Internal+ Reflex.Time+ Reflex.TriggerEvent.Base+ Reflex.TriggerEvent.Class+ Reflex.Widget.Basic+ Reflex.Workflow - if flag(split-these)- build-depends: these >= 1 && <1.2,- semialign >=1 && <1.2,- monoidal-containers >= 0.6 && < 0.7- else- build-depends: these >= 0.4 && <0.9,- monoidal-containers == 0.4.0.0+ reexported-modules:+ patch:Data.Functor.Misc+ , patch:Data.Patch as Reflex.Patch+ , patch:Data.Patch.Class as Reflex.Patch.Class+ , patch:Data.Patch.DMap as Reflex.Patch.DMap+ , patch:Data.Patch.DMapWithMove as Reflex.Patch.DMapWithMove+ , patch:Data.Patch.IntMap as Reflex.Patch.IntMap+ , patch:Data.Patch.Map as Reflex.Patch.Map+ , patch:Data.Patch.MapWithMove as Reflex.Patch.MapWithMove - exposed-modules:- Control.Monad.ReaderIO- Data.AppendMap,- Data.FastMutableIntMap,- Data.FastWeakBag,- Data.Map.Misc,- Data.WeakBag,- Reflex,- Reflex.Class,- Reflex.Adjustable.Class,- Reflex.BehaviorWriter.Base,- Reflex.BehaviorWriter.Class,- Reflex.Collection,- Reflex.Dynamic,- Reflex.Dynamic.Uniq,- Reflex.DynamicWriter,- Reflex.DynamicWriter.Base,- Reflex.DynamicWriter.Class,- Reflex.EventWriter,- Reflex.EventWriter.Base,- Reflex.EventWriter.Class,- Reflex.FastWeak,- Reflex.FunctorMaybe,- Reflex.Host.Class,- Reflex.Host.Headless,- Reflex.Network,- Reflex.NotReady.Class,- Reflex.PerformEvent.Base,- Reflex.PerformEvent.Class,- Reflex.PostBuild.Base,- Reflex.PostBuild.Class,- Reflex.Profiled,- Reflex.Pure,- Reflex.Query.Base,- Reflex.Query.Class,- Reflex.Requester.Base,- Reflex.Requester.Class,- Reflex.Spider,- Reflex.Spider.Internal,- Reflex.Time,- Reflex.TriggerEvent.Base,- Reflex.TriggerEvent.Class,- Reflex.Widget.Basic,- Reflex.Workflow+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options:+ -Wall -fwarn-redundant-constraints -fwarn-tabs+ -funbox-strict-fields -O2 -fspecialise-aggressively - reexported-modules:- patch:Data.Functor.Misc,- patch:Data.Patch as Reflex.Patch,- patch:Data.Patch.Class as Reflex.Patch.Class,- patch:Data.Patch.DMap as Reflex.Patch.DMap,- patch:Data.Patch.DMapWithMove as Reflex.Patch.DMapWithMove,- patch:Data.Patch.IntMap as Reflex.Patch.IntMap,- patch:Data.Patch.Map as Reflex.Patch.Map,- patch:Data.Patch.MapWithMove as Reflex.Patch.MapWithMove+ build-depends:+ MemoTrie == 0.6.*+ , base >= 4.11 && < 4.22+ , bifunctors >= 5.2 && < 5.7+ , comonad >= 5.0.4 && < 5.1+ , commutative-semigroups >= 0.1 && <0.3+ , constraints >= 0.10 && <0.15+ , constraints-extras >= 0.3 && < 0.5+ , containers >= 0.6 && < 0.8+ , data-default >= 0.5 && < 0.9+ , dependent-map >= 0.3 && < 0.5+ , dependent-sum >= 0.6 && < 0.8+ , exceptions >= 0.10 && < 0.11+ , exception-transformers >= 0.4 && < 0.5+ , mmorph >= 1.0 && < 1.3+ , monad-control >= 1.0.1 && < 1.1+ , mtl >= 2.1 && < 2.4+ , patch >= 0.0.7 && < 0.1+ , prim-uniq >= 0.1.0.1 && < 0.3+ , primitive >= 0.5 && < 0.10+ , profunctors >= 5.3 && < 5.7+ , random >= 1.1 && < 1.4+ , ref-tf >= 0.4 && < 0.6+ , reflection == 2.1.*+ , semigroupoids >= 4.0 && < 7+ , stm >= 2.4 && < 2.6+ , syb >= 0.5 && < 0.8+ , time >= 1.4 && < 1.15+ , transformers >= 0.5 && < 0.7+ , unbounded-delays >= 0.1.0.0 && < 0.2+ , witherable >= 0.4 && < 0.6+ , haskell-src-exts >= 1.16 && < 1.24+ , haskell-src-meta >= 0.6 && < 0.9+ , template-haskell >= 2.9 && < 2.24 - ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively+ other-extensions:+ TemplateHaskell - if flag(debug-trace-events)- cpp-options: -DDEBUG_TRACE_EVENTS- build-depends:- bytestring >= 0.10.8 && < 0.11+ if flag(split-these)+ build-depends:+ these >=1 && <1.3+ , semialign >=1 && <1.4+ , monoidal-containers >=0.6.2.0 && <0.7 - if flag(use-reflex-optimizer)- cpp-options: -DUSE_REFLEX_OPTIMIZER- build-depends: ghc- exposed-modules: Reflex.Optimizer+ else+ build-depends:+ these >=0.4 && <0.9+ , monoidal-containers ==0.4.0.0 - if flag(debug-propagation)- cpp-options: -DDEBUG -DDEBUG_TRACE_PROPAGATION -DDEBUG_TRACE_INVALIDATION+ if flag(debug-trace-events)+ cpp-options: -DDEBUG_TRACE_EVENTS+ build-depends: bytestring >=0.10.8 && <0.11 - if flag(debug-cycles)- cpp-options: -DDEBUG_CYCLES+ if flag(debug-propagation)+ cpp-options:+ -DDEBUG -DDEBUG_TRACE_PROPAGATION -DDEBUG_TRACE_INVALIDATION - if flag(use-template-haskell)- cpp-options: -DUSE_TEMPLATE_HASKELL- build-depends:- dependent-sum >= 0.6 && < 0.8,- haskell-src-exts >= 1.16 && < 1.24,- haskell-src-meta >= 0.6 && < 0.9,- template-haskell >= 2.9 && < 2.16- exposed-modules:- Reflex.Dynamic.TH- other-extensions: TemplateHaskell- else- build-depends:- dependent-sum >= 0.6 && < 0.8+ if flag(debug-cycles)+ cpp-options: -DDEBUG_CYCLES - if flag(fast-weak) && impl(ghcjs)- cpp-options: -DGHCJS_FAST_WEAK+ if flag(fast-weak) && impl(ghcjs >=0)+ cpp-options: -DGHCJS_FAST_WEAK - if impl(ghcjs)- build-depends:- ghcjs-base == 0.2.*+ if impl(ghcjs)+ build-depends: ghcjs-base >=0.2 && <0.3 test-suite semantics- default-language: Haskell2010- type: exitcode-stdio-1.0- main-is: semantics.hs- hs-source-dirs: test- ghc-options: -O2 -Wall -rtsopts- build-depends:- base,- bifunctors,- containers,- deepseq,- dependent-map,- dependent-sum,- mtl,- ref-tf,- reflex,- split,- transformers- other-modules:- Reflex.Bench.Focused- Reflex.Plan.Pure- Reflex.Plan.Reflex- Reflex.Test- Reflex.Test.Micro- Reflex.TestPlan+ type: exitcode-stdio-1.0+ main-is: semantics.hs+ hs-source-dirs: test+ other-modules:+ Reflex.Bench.Focused+ Reflex.Plan.Pure+ Reflex.Plan.Reflex+ Reflex.Test+ Reflex.Test.Micro+ Reflex.TestPlan + default-language: Haskell2010+ ghc-options: -O2 -Wall -rtsopts+ build-depends:+ base >= 4.11 && < 4.22+ , bifunctors+ , containers+ , deepseq+ , dependent-map+ , dependent-sum+ , mtl+ , ref-tf+ , reflex+ , split+ , transformers+ test-suite CrossImpl- default-language: Haskell2010- type: exitcode-stdio-1.0- main-is: Reflex/Test/CrossImpl.hs- hs-source-dirs: test- ghc-options: -O2 -Wall -rtsopts- build-depends:- base,- containers,- dependent-map,- dependent-sum,- deepseq,- mtl,- transformers,- ref-tf,- reflex- other-modules:- Reflex.Test- Reflex.TestPlan- Reflex.Plan.Reflex- Reflex.Plan.Pure+ type: exitcode-stdio-1.0+ main-is: Reflex/Test/CrossImpl.hs+ hs-source-dirs: test+ other-modules:+ Reflex.Test+ Reflex.TestPlan+ Reflex.Plan.Reflex+ Reflex.Plan.Pure -test-suite hlint- default-language: Haskell2010- type: exitcode-stdio-1.0- main-is: hlint.hs- hs-source-dirs: test- build-depends: base- , directory- , filepath- , filemanip- if impl(ghc >= 8.8)- build-depends: hlint >= 3- else- build-depends: hlint (< 2.1 || >= 2.2.2) && < 3- if impl(ghcjs)- buildable: False+ default-language: Haskell2010+ ghc-options: -O2 -Wall -rtsopts+ build-depends:+ base >= 4.11 && < 4.22+ , containers+ , dependent-map+ , dependent-sum+ , deepseq+ , mtl+ , transformers+ , ref-tf+ , reflex -test-suite EventWriterT- default-language: Haskell2010- type: exitcode-stdio-1.0- main-is: EventWriterT.hs- hs-source-dirs: test- build-depends: base- , containers- , deepseq- , dependent-map- , dependent-sum- , lens- , mtl- , these- , transformers- , reflex- , ref-tf+test-suite hlint+ type: exitcode-stdio-1.0+ main-is: hlint.hs+ hs-source-dirs: test+ default-language: Haskell2010+ build-depends:+ base >= 4.11 && < 4.22+ , directory+ , filepath+ , filemanip - if flag(split-these)- build-depends: these-lens+ if impl(ghc >=9.6)+ buildable: False - other-modules:- Test.Run+ if impl(ghc <9.2)+ build-depends: hlint (<2.1 || >=2.2.2) && <3.5 + else+ build-depends: hlint >=3.5 && <3.6 -test-suite DebugCycles- default-language: Haskell2010- type: exitcode-stdio-1.0- main-is: DebugCycles.hs- hs-source-dirs: test- ghc-options: -threaded- build-depends: base- , containers- , deepseq- , dependent-map- , dependent-sum- , hspec- , lens- , mtl- , these- , transformers- , reflex- , ref-tf- , witherable- , proctest+ if impl(ghcjs >=0) || arch(javascript)+ buildable: False +test-suite EventWriterT+ type: exitcode-stdio-1.0+ main-is: EventWriterT.hs+ hs-source-dirs: test+ other-modules: Test.Run+ default-language: Haskell2010+ build-depends:+ base >= 4.11 && < 4.22+ , containers+ , deepseq+ , dependent-map+ , dependent-sum+ , lens+ , mtl+ , these+ , transformers+ , reflex+ , ref-tf - if flag(split-these)- build-depends: these-lens, semialign+ if flag(split-these)+ build-depends: these-lens - other-modules:- Test.Run+test-suite DebugCycles+ type: exitcode-stdio-1.0+ main-is: DebugCycles.hs+ hs-source-dirs: test+ other-modules: Test.Run+ default-language: Haskell2010+ ghc-options: -threaded+ build-depends:+ base >= 4.11 && < 4.22+ , containers+ , deepseq+ , dependent-map+ , dependent-sum+ , hspec+ , lens+ , mtl+ , these+ , transformers+ , reflex+ , ref-tf+ , witherable + if flag(split-these)+ build-depends:+ these-lens+ , semialign test-suite RequesterT- default-language: Haskell2010- type: exitcode-stdio-1.0- main-is: RequesterT.hs- hs-source-dirs: test- build-depends: base- , constraints- , constraints-extras- , containers- , deepseq- , dependent-map- , dependent-sum- , lens- , mtl- , ref-tf- , reflex- , text- , these- , transformers+ type: exitcode-stdio-1.0+ main-is: RequesterT.hs+ hs-source-dirs: test+ other-modules:+ Reflex.TestPlan+ Reflex.Plan.Pure+ Test.Run - if flag(split-these)- build-depends: these-lens+ default-language: Haskell2010+ build-depends:+ base >= 4.11 && < 4.22+ , constraints+ , constraints-extras+ , containers+ , deepseq+ , dependent-map+ , dependent-sum+ , lens+ , mtl+ , ref-tf+ , reflex+ , text+ , these+ , transformers - other-modules:- Reflex.TestPlan- Reflex.Plan.Pure- Test.Run+ if flag(split-these)+ build-depends: these-lens test-suite Headless- default-language: Haskell2010- type: exitcode-stdio-1.0- main-is: Headless.hs- hs-source-dirs: test- build-depends: base- , reflex+ type: exitcode-stdio-1.0+ main-is: Headless.hs+ hs-source-dirs: test+ default-language: Haskell2010+ build-depends:+ base >= 4.11 && < 4.22+ , reflex test-suite Adjustable- default-language: Haskell2010- type: exitcode-stdio-1.0- main-is: Adjustable.hs- hs-source-dirs: test- build-depends: base- , containers- , dependent-sum- , reflex- , ref-tf- , these-- other-modules:- Test.Run+ type: exitcode-stdio-1.0+ main-is: Adjustable.hs+ hs-source-dirs: test+ other-modules: Test.Run+ default-language: Haskell2010+ build-depends:+ base >= 4.11 && < 4.22+ , containers+ , dependent-sum+ , reflex+ , ref-tf+ , these test-suite QueryT- default-language: Haskell2010- type: exitcode-stdio-1.0- main-is: QueryT.hs- hs-source-dirs: test- build-depends: base- , containers- , dependent-map- , dependent-sum- , deepseq- , lens- , monoidal-containers- , mtl- , patch- , ref-tf- , reflex- , these- , transformers+ type: exitcode-stdio-1.0+ main-is: QueryT.hs+ hs-source-dirs: test+ other-modules:+ Test.Run+ Reflex.TestPlan+ Reflex.Plan.Reflex+ Reflex.Plan.Pure - if flag(split-these)- build-depends: semialign, these-lens+ default-language: Haskell2010+ build-depends:+ base >= 4.11 && < 4.22+ , commutative-semigroups+ , containers+ , dependent-map+ , dependent-sum+ , deepseq+ , lens+ , monoidal-containers+ , mtl+ , patch+ , ref-tf+ , reflex+ , these+ , transformers - other-modules:- Test.Run- Reflex.TestPlan- Reflex.Plan.Reflex- Reflex.Plan.Pure+ if flag(split-these)+ build-depends:+ semialign+ , these-lens test-suite GC-Semantics- default-language: Haskell2010- type: exitcode-stdio-1.0- main-is: GC.hs- hs-source-dirs: test- build-depends: base- , containers- , dependent-sum- , dependent-map- , deepseq- , mtl- , patch- , these- , transformers- , reflex- , ref-tf+ type: exitcode-stdio-1.0+ main-is: GC.hs+ hs-source-dirs: test+ other-modules:+ Reflex.Plan.Pure+ Reflex.Plan.Reflex+ Reflex.TestPlan+ Test.Run - if flag(split-these)- build-depends: semialign+ default-language: Haskell2010+ build-depends:+ base >= 4.11 && < 4.22+ , containers+ , dependent-sum+ , dependent-map+ , deepseq+ , mtl+ , patch+ , these+ , transformers+ , reflex+ , ref-tf - other-modules:- Reflex.Plan.Pure- Reflex.Plan.Reflex- Reflex.TestPlan- Test.Run+ if flag(split-these)+ build-depends: semialign test-suite rootCleanup- default-language: Haskell2010- type: exitcode-stdio-1.0- main-is: rootCleanup.hs- hs-source-dirs: test- build-depends: base- , containers- , deepseq- , dependent-sum- , mtl- , reflex- , ref-tf- , these- other-modules:- Reflex.Plan.Pure- Reflex.TestPlan- Test.Run+ type: exitcode-stdio-1.0+ main-is: rootCleanup.hs+ hs-source-dirs: test+ other-modules:+ Reflex.Plan.Pure+ Reflex.TestPlan+ Test.Run + default-language: Haskell2010+ build-depends:+ base >= 4.11 && < 4.22+ , containers+ , deepseq+ , dependent-sum+ , mtl+ , reflex+ , ref-tf+ , these++test-suite behaviorLeak+ type: exitcode-stdio-1.0+ main-is: behaviorLeak.hs+ hs-source-dirs: test+ default-language: Haskell2010+ ghc-options: -Wall -O2 -rtsopts "-with-rtsopts=-T"+ build-depends:+ base >= 4.11 && < 4.22+ , dependent-sum+ , reflex+ , ref-tf+ , primitive+ benchmark spider-bench- default-language: Haskell2010- type: exitcode-stdio-1.0- hs-source-dirs: bench test- main-is: Main.hs- ghc-options: -Wall -O2 -rtsopts- build-depends:- base,- containers,- criterion,- deepseq,- dependent-map,- dependent-sum,- ref-tf,- mtl,- primitive,- reflex,- split,- stm,- transformers- other-modules:- Reflex.TestPlan- Reflex.Plan.Reflex- Reflex.Bench.Focused+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: bench test+ other-modules:+ Reflex.TestPlan+ Reflex.Plan.Reflex+ Reflex.Bench.Focused + default-language: Haskell2010+ ghc-options: -Wall -O2 -rtsopts+ build-depends:+ base >= 4.11 && < 4.22+ , containers+ , criterion+ , deepseq+ , dependent-map+ , dependent-sum+ , ref-tf+ , mtl+ , primitive+ , reflex+ , split+ , stm+ , transformers++ if arch(javascript)+ buildable: False+ benchmark saulzar-bench- default-language: Haskell2010- type: exitcode-stdio-1.0- hs-source-dirs: bench test- c-sources: bench-cbits/checkCapability.c- main-is: RunAll.hs- ghc-options: -Wall -O2 -rtsopts -threaded- build-depends:- base,- containers,- criterion,- deepseq,- dependent-map,- dependent-sum,- loch-th,- mtl,- primitive,- process,- ref-tf,- reflex,- split,- stm,- time,- transformers- other-modules:- Reflex.TestPlan- Reflex.Plan.Reflex- Reflex.Bench.Focused+ type: exitcode-stdio-1.0+ main-is: RunAll.hs+ c-sources: bench-cbits/checkCapability.c+ hs-source-dirs: bench test+ other-modules:+ Reflex.TestPlan+ Reflex.Plan.Reflex+ Reflex.Bench.Focused -source-repository head- type: git- location: https://github.com/reflex-frp/reflex+ default-language: Haskell2010+ ghc-options: -Wall -O2 -rtsopts -threaded+ build-depends:+ base >= 4.11 && < 4.22+ , containers+ , criterion+ , deepseq+ , dependent-map+ , dependent-sum+ , loch-th+ , mtl+ , primitive+ , process+ , ref-tf+ , reflex+ , split+ , stm+ , time+ , transformers++ if arch(javascript)+ buildable: False
src/Control/Monad/ReaderIO.hs view
@@ -2,16 +2,12 @@ {-# language MultiParamTypeClasses #-} {-# language FlexibleInstances #-} {-# language CPP #-}+ module Control.Monad.ReaderIO- (- ReaderIO (..)- )- where+ ( ReaderIO (..)+ ) where import Control.Monad.Fix-#if MIN_VERSION_base(4,10,0)-import Control.Applicative-#endif import Control.Monad import Control.Monad.Reader.Class import Control.Monad.IO.Class@@ -34,12 +30,10 @@ {-# INLINE pure #-} (<*>) = ap {-# INLINE (<*>) #-}-#if MIN_VERSION_base(4,10,0)+#if MIN_VERSION_base(4,18,0) liftA2 = liftM2 {-# INLINE liftA2 #-} #endif- (*>) = (>>)- {-# INLINE (*>) #-} instance Monad (ReaderIO e) where ReaderIO q >>= f = ReaderIO $ \e -> q e >>= \a -> runReaderIO (f a) e
src/Data/AppendMap.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-}+ -- | -- Module: -- Data.AppendMap@@ -25,14 +26,8 @@ import Data.Coerce import Data.Default import Data.Map (Map)-#if MIN_VERSION_containers(0,5,11) import qualified Data.Map.Internal.Debug as Map (showTree, showTreeWith)-#else-import qualified Data.Map as Map (showTree, showTreeWith)-#endif-import qualified Data.Witherable as W import Data.Map.Monoidal-import qualified Data.Map.Monoidal as MonoidalMap {-# DEPRECATED AppendMap "Use 'MonoidalMap' instead" #-}@@ -47,11 +42,6 @@ -- | Pattern synonym for 'MonoidalMap' pattern AppendMap :: Map k v -> MonoidalMap k v pattern AppendMap m = MonoidalMap m--#if !MIN_VERSION_witherable(0,3,2)-instance W.Filterable (MonoidalMap k) where- mapMaybe = MonoidalMap.mapMaybe-#endif -- | Deletes a key, returning 'Nothing' if the result is empty. nonEmptyDelete :: Ord k => k -> MonoidalMap k a -> Maybe (MonoidalMap k a)
src/Data/FastMutableIntMap.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-}+ -- | -- Module: -- Data.FastMutableIntMap
src/Data/FastWeakBag.hs view
@@ -1,12 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-}-#ifdef USE_REFLEX_OPTIMIZER-{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}-#endif #ifdef GHCJS_FAST_WEAK {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE JavaScriptFFI #-} #endif+ -- | This module defines the 'FastWeakBag' type, which represents a mutable -- collection of items that does not cause the items to be retained in memory. -- This is useful for situations where a value needs to be inspected or modified
src/Data/Map/Misc.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-}+ -- | Additional functions for manipulating 'Map's. module Data.Map.Misc (
src/Data/WeakBag.hs view
@@ -1,9 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-}-#ifdef USE_REFLEX_OPTIMIZER-{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}-#endif+ -- | This module defines the 'WeakBag' type, which represents a mutable -- collection of items that does not cause the items to be retained in memory. -- This is useful for situations where a value needs to be inspected or modified
src/Reflex.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+ -- | This module exports all of the commonly-used functionality of Reflex; if -- you are just getting started with Reflex, this is probably what you want. module Reflex@@ -13,9 +14,7 @@ import Reflex.Dynamic as X import Reflex.EventWriter.Base as X import Reflex.EventWriter.Class as X-#ifdef USE_TEMPLATE_HASKELL import Reflex.Dynamic.TH as X-#endif import Reflex.Dynamic.Uniq as X import Reflex.DynamicWriter.Base as X import Reflex.DynamicWriter.Class as X
src/Reflex/Adjustable/Class.hs view
@@ -7,9 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}-#ifdef USE_REFLEX_OPTIMIZER-{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}-#endif+ -- | -- Module: -- Reflex.Adjustable.Class
src/Reflex/BehaviorWriter/Base.hs view
@@ -10,19 +10,20 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE StandaloneDeriving #-}-#ifdef USE_REFLEX_OPTIMIZER-{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}-#endif+ module Reflex.BehaviorWriter.Base ( BehaviorWriterT (..) , runBehaviorWriterT , withBehaviorWriterT ) where +import Control.Monad+import Control.Monad.Catch (MonadMask, MonadThrow, MonadCatch) import Control.Monad.Exception-import Control.Monad.Identity+import Control.Monad.Fix import Control.Monad.IO.Class import Control.Monad.Morph import Control.Monad.Reader@@ -37,6 +38,10 @@ import qualified Data.Map as Map import Data.Some (Some) +#if !MIN_VERSION_base(4,18,0)+import Control.Monad.Identity+#endif+ import Reflex.Class import Reflex.Adjustable.Class import Reflex.BehaviorWriter.Class@@ -60,6 +65,9 @@ , MonadFix , MonadAsyncException , MonadException+ , MonadCatch+ , MonadThrow+ , MonadMask ) -- | Run a 'BehaviorWriterT' action. The behavior writer output will be provided
src/Reflex/BehaviorWriter/Class.hs view
@@ -7,9 +7,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-}-#ifdef USE_REFLEX_OPTIMIZER-{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}-#endif+ module Reflex.BehaviorWriter.Class ( MonadBehaviorWriter , BehaviorWriter(..)
src/Reflex/Class.hs view
@@ -17,9 +17,6 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE Trustworthy #-}-#ifdef USE_REFLEX_OPTIMIZER-{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}-#endif -- | -- Module:@@ -185,6 +182,8 @@ #endif import Control.Applicative+import Control.Monad+import Control.Monad.Fix import Control.Monad.Identity import Control.Monad.Reader import Control.Monad.State.Strict@@ -202,13 +201,13 @@ import Data.Functor.Compose import Data.Functor.Product import Data.GADT.Compare (GEq (..), GCompare (..))-import Data.FastMutableIntMap (PatchIntMap) import Data.Foldable import Data.Functor.Bind import Data.Functor.Misc import Data.Functor.Plus import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap+import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty (..)) import Data.Map (Map) import Data.Semigroup (Semigroup (..))@@ -217,12 +216,12 @@ import Data.These import Data.Type.Coercion import Data.Type.Equality ((:~:) (..))-import Data.Witherable (Filterable(..))-import qualified Data.Witherable as W import Reflex.FunctorMaybe (FunctorMaybe) import qualified Reflex.FunctorMaybe import Data.Patch import qualified Data.Patch.MapWithMove as PatchMapWithMove+import Witherable (Filterable(..))+import qualified Witherable as W import Debug.Trace (trace) @@ -240,25 +239,25 @@ ) => Reflex t where -- | A container for a value that can change over time. 'Behavior's can be -- sampled at will, but it is not possible to be notified when they change- data Behavior t :: * -> *+ data Behavior t :: Type -> Type -- | A stream of occurrences. During any given frame, an 'Event' is either -- occurring or not occurring; if it is occurring, it will contain a value of -- the given type (its "occurrence type")- data Event t :: * -> *+ data Event t :: Type -> Type -- | A container for a value that can change over time and allows -- notifications on changes. Basically a combination of a 'Behavior' and an -- 'Event', with a rule that the 'Behavior' will change if and only if the -- 'Event' fires.- data Dynamic t :: * -> *+ data Dynamic t :: Type -> Type -- | An 'Incremental' is a more general form of a 'Dynamic'. -- Instead of always fully replacing the value, only parts of it can be patched. -- This is only needed for performance critical code via `mergeIncremental` to make small -- changes to large values.- data Incremental t :: * -> *+ data Incremental t :: Type -> Type -- | A monad for doing complex push-based calculations efficiently- type PushM t :: * -> *+ type PushM t :: Type -> Type -- | A monad for doing complex pull-based calculations efficiently- type PullM t :: * -> *+ type PullM t :: Type -> Type -- | An 'Event' with no occurrences never :: Event t a -- | Create a 'Behavior' that always has the given value@@ -677,14 +676,17 @@ instance Reflex t => Monad (Behavior t) where a >>= f = pull $ sample a >>= sample . f -- Note: it is tempting to write (_ >> b = b); however, this would result in (fail x >> return y) succeeding (returning y), which violates the law that (a >> b = a >>= \_ -> b), since the implementation of (>>=) above actually will fail. Since we can't examine 'Behavior's other than by using sample, I don't think it's possible to write (>>) to be more efficient than the (>>=) above.- return = constant #if !MIN_VERSION_base(4,13,0) fail = error "Monad (Behavior t) does not support fail" #endif +instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where+ a <> b = pull $ liftM2 (<>) (sample a) (sample b)+ sconcat = pull . fmap sconcat . mapM sample+ stimes n = fmap $ stimes n+ instance (Reflex t, Monoid a) => Monoid (Behavior t a) where mempty = constant mempty- mappend a b = pull $ liftM2 mappend (sample a) (sample b) mconcat = pull . fmap mconcat . mapM sample instance (Reflex t, Num a) => Num (Behavior t a) where@@ -705,11 +707,6 @@ negate = fmap negate (-) = liftA2 (-) -instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where- a <> b = pull $ liftM2 (<>) (sample a) (sample b)- sconcat = pull . fmap sconcat . mapM sample- stimes n = fmap $ stimes n- -- | Alias for 'mapMaybe' fmapMaybe :: Filterable f => (a -> Maybe b) -> f a -> f b fmapMaybe = mapMaybe@@ -1156,7 +1153,6 @@ instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where mconcat = distributeListOverDynWith mconcat mempty = constDyn mempty- mappend = zipDynWith mappend -- | This function converts a 'DMap' whose elements are 'Dynamic's into a -- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same
src/Reflex/Collection.hs view
@@ -7,9 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}-#ifdef USE_REFLEX_OPTIMIZER-{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}-#endif+ -- | -- Module: -- Reflex.Collection@@ -34,7 +32,8 @@ #endif #endif -import Control.Monad.Identity+import Control.Monad+import Control.Monad.Fix import Data.Align import Data.Functor.Misc import Data.Map (Map)@@ -42,6 +41,10 @@ import Data.Map.Misc import Data.These +#if !MIN_VERSION_base(4,18,0)+import Control.Monad.Identity+#endif+ import Reflex.Class import Reflex.Adjustable.Class import Reflex.Dynamic@@ -74,7 +77,7 @@ --where the Events carry diffs, not the whole value listWithKey :: forall t k v m a- . (Ord k, Adjustable t m, PostBuild t m, MonadFix m, MonadHold t m)+ . (Ord k, Adjustable t m, PostBuild t m, MonadFix m, MonadHold t m, Eq v) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a))@@ -106,7 +109,7 @@ , tag (current vals) postBuild ] listHoldWithKey Map.empty changeVals $ \k v ->- mkChild k =<< holdDyn v (select childValChangedSelector $ Const2 k)+ mkChild k =<< holdUniqDyn =<< holdDyn v (select childValChangedSelector $ Const2 k) -- | Display the given map of items (in key order) using the builder -- function provided, and update it with the given event. 'Nothing'@@ -147,7 +150,7 @@ -- this scenario, but 'listViewWithKey' flattens this to -- @/Event t (Map k a)/@ via 'switch'. listViewWithKey- :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m)+ :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m, Eq v) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m (Event t a)) -> m (Event t (Map k a))@@ -155,7 +158,7 @@ switch . fmap mergeMap <$> listViewWithKey' vals mkChild listViewWithKey'- :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m)+ :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m, Eq v) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Behavior t (Map k a))@@ -165,7 +168,7 @@ -- selected at any time. selectViewListWithKey :: forall t m k v a- . (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)+ . (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m, Eq v) => Dynamic t k -- ^ Current selection key -> Dynamic t (Map k v)@@ -189,7 +192,7 @@ -- item widget's output 'Event'. selectViewListWithKey_ :: forall t m k v a- . (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)+ . (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m, Eq v) => Dynamic t k -- ^ Current selection key -> Dynamic t (Map k v)@@ -207,7 +210,7 @@ -- key/value map. Unlike the 'withKey' variants, the child widgets -- are insensitive to which key they're associated with. list- :: (Ord k, Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m)+ :: (Ord k, Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m, Eq v) => Dynamic t (Map k v) -> (Dynamic t v -> m a) -> m (Dynamic t (Map k a))@@ -215,7 +218,7 @@ -- | Create a dynamically-changing set of widgets from a Dynamic list. simpleList- :: (Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m)+ :: (Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m, Eq v) => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])
src/Reflex/Dynamic.hs view
@@ -14,9 +14,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}-#ifdef USE_REFLEX_OPTIMIZER-{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}-#endif+ -- | -- Module: -- Reflex.Dynamic@@ -78,28 +76,31 @@ , unsafeDynamic ) where -import Data.Functor.Compose-import Data.Functor.Misc-import Reflex.Class--import Control.Monad import Control.Monad.Fix import Control.Monad.Identity import Data.Align import Data.Dependent.Map (DMap) import qualified Data.Dependent.Map as DMap import Data.Dependent.Sum (DSum (..))+import Data.Functor.Compose+import Data.Functor.Misc import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..)) import Data.IntMap (IntMap)-import qualified Data.IntMap as IntMap+import Data.Kind (Type) import Data.Map (Map) import Data.Maybe-import Data.Monoid ((<>)) import Data.These import Data.Type.Equality ((:~:) (..)) -import Debug.Trace+import Debug.Trace (trace) +#if !MIN_VERSION_base(4,18,0)+import Control.Monad+import Data.Monoid ((<>))+#endif++import Reflex.Class+ -- | Map a sampling function over a 'Dynamic'. mapDynM :: forall t m a b. (Reflex t, MonadHold t m) => (forall m'. MonadSample t m' => a -> m' b) -> Dynamic t a -> m (Dynamic t b) mapDynM f d = buildDynamic (f =<< sample (current d)) $ pushAlways f (updated d)@@ -348,7 +349,7 @@ -- -- > demuxed (demux d) k === fmap (== k) d ----- However, when getDemuxed is used multiple times, the complexity is only+-- However, when 'demuxed' is used multiple times, the complexity is only -- /O(log(n))/, rather than /O(n)/ for fmap. data Demux t k = Demux { demuxValue :: Behavior t k , demuxSelector :: EventSelector t (Const2 k Bool)@@ -381,7 +382,7 @@ -- | A heterogeneous list whose type and length are fixed statically. This is -- reproduced from the 'HList' package due to integration issues, and because -- very little other functionality from that library is needed.-data HList (l::[*]) where+data HList (l::[Type]) where HNil :: HList '[] HCons :: e -> HList l -> HList (e ': l) @@ -437,7 +438,7 @@ deriving instance Eq (HListPtr l a) deriving instance Ord (HListPtr l a) -fhlistToDMap :: forall (f :: * -> *) l. FHList f l -> DMap (HListPtr l) f+fhlistToDMap :: forall (f :: Type -> Type) l. FHList f l -> DMap (HListPtr l) f fhlistToDMap = DMap.fromList . go where go :: forall l'. FHList f l' -> [DSum (HListPtr l') f] go = \case@@ -477,8 +478,8 @@ -- | Indicates that all elements in a type-level list are applications of the -- same functor.-class AllAreFunctors (f :: a -> *) (l :: [a]) where- type FunctorList f l :: [*]+class AllAreFunctors (f :: a -> Type) (l :: [a]) where+ type FunctorList f l :: [Type] toFHList :: HList (FunctorList f l) -> FHList f l fromFHList :: FHList f l -> HList (FunctorList f l) @@ -513,7 +514,7 @@ -- | Poor man's 'Generic's for product types only. class IsHList a where- type HListElems a :: [*]+ type HListElems a :: [Type] toHList :: a -> HList (HListElems a) fromHList :: HList (HListElems a) -> a
src/Reflex/Dynamic/TH.hs view
@@ -5,9 +5,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeOperators #-}-#ifdef USE_REFLEX_OPTIMIZER-{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}-#endif+ -- | Template Haskell helper functions for building complex 'Dynamic' values. module Reflex.Dynamic.TH ( qDynPure@@ -15,18 +13,21 @@ , mkDynPure ) where -import Reflex.Dynamic- import Control.Monad.State import Data.Data import Data.Generics-import Data.Monoid ((<>)) import qualified Language.Haskell.Exts as Hs import qualified Language.Haskell.Meta.Syntax.Translate as Hs import Language.Haskell.TH import Language.Haskell.TH.Quote import qualified Language.Haskell.TH.Syntax as TH +#if !MIN_VERSION_base(4,18,0)+import Data.Monoid ((<>))+#endif++import Reflex.Dynamic+ -- | Quote a 'Dynamic' expression. Within the quoted expression, you can use -- @$(unqDyn [| x |])@ to refer to any expression @x@ of type @Dynamic t a@; the -- unquoted result will be of type @a@@@ -44,9 +45,15 @@ _ -> gmapM f d (e', exprsReversed) <- runStateT (gmapM f e) [] let exprs = reverse exprsReversed- arg = foldr (\a b -> ConE 'FHCons `AppE` snd a `AppE` b) (ConE 'FHNil) exprs- param = foldr (\a b -> ConP 'HCons [VarP (fst a), b]) (ConP 'HNil []) exprs- [| $(return $ LamE [param] e') <$> distributeFHListOverDynPure $(return arg) |]+ arg = foldr+ (\(_, expr) rest -> [e| FHCons $(pure expr) $rest |])+ [e| FHNil |]+ exprs+ param = foldr+ (\(name, _) rest -> [p| HCons $(pure $ VarP name) $rest |])+ [p| HNil |]+ exprs+ [| (\ $param -> $(pure e')) <$> distributeFHListOverDynPure $arg |] -- | Antiquote a 'Dynamic' expression. This can /only/ be used inside of a -- 'qDyn' quotation.@@ -85,7 +92,6 @@ Hs.ParseFailed (Hs.SrcLoc _ l c) err -> fail $ "mkDyn:" <> show l <> ":" <> show c <> ": " <> err Hs.ParseOk e -> qDynPure $ return $ everywhere (id `extT` reinstateUnqDyn) $ Hs.toExp $ everywhere (id `extT` antiE) e where TH.Name (TH.OccName occName) (TH.NameG _ _ (TH.ModName modName)) = 'unqMarker-#if MIN_VERSION_haskell_src_exts(1,18,0) antiE :: Hs.Exp Hs.SrcSpanInfo -> Hs.Exp Hs.SrcSpanInfo antiE x = case x of Hs.SpliceExp l se ->@@ -93,14 +99,6 @@ Hs.IdSplice l2 v -> Hs.Var l2 $ Hs.UnQual l2 $ Hs.Ident l2 v Hs.ParenSplice _ ps -> ps _ -> x-#else- antiE x = case x of- Hs.SpliceExp se ->- Hs.App (Hs.Var $ Hs.Qual (Hs.ModuleName modName) (Hs.Ident occName)) $ case se of- Hs.IdSplice v -> Hs.Var $ Hs.UnQual $ Hs.Ident v- Hs.ParenSplice ps -> ps- _ -> x-#endif reinstateUnqDyn (TH.Name (TH.OccName occName') (TH.NameQ (TH.ModName modName'))) | modName == modName' && occName == occName' = 'unqMarker reinstateUnqDyn x = x
src/Reflex/Dynamic/Uniq.hs view
@@ -2,9 +2,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-}-#ifdef USE_REFLEX_OPTIMIZER-{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}-#endif+ -- | This module provides a variation of 'Dynamic' values that uses cheap -- pointer equality checks to reduce the amount of signal propagation needed. module Reflex.Dynamic.Uniq@@ -14,8 +12,12 @@ , alreadyUniqDynamic ) where -import Control.Applicative (Applicative (..)) import GHC.Exts++#if !MIN_VERSION_base(4,18,0)+import Control.Applicative (Applicative(..))+#endif+ import Reflex.Class -- | A 'Dynamic' whose 'updated' 'Event' will never fire with the same value as@@ -101,5 +103,3 @@ instance Reflex t => Monad (UniqDynamic t) where UniqDynamic x >>= f = uniqDynamic $ x >>= unUniqDynamic . f- _ >> b = b- return = pure
src/Reflex/DynamicWriter/Base.hs view
@@ -8,19 +8,20 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE StandaloneDeriving #-}-#ifdef USE_REFLEX_OPTIMIZER-{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}-#endif+ module Reflex.DynamicWriter.Base ( DynamicWriterT (..) , runDynamicWriterT , withDynamicWriterT ) where +import Control.Monad+import Control.Monad.Catch (MonadMask, MonadThrow, MonadCatch) import Control.Monad.Exception-import Control.Monad.Identity+import Control.Monad.Fix import Control.Monad.IO.Class import Control.Monad.Morph import Control.Monad.Primitive@@ -36,10 +37,14 @@ import qualified Data.IntMap as IntMap import Data.Map (Map) import qualified Data.Map as Map-import Data.Semigroup (Semigroup(..)) import Data.Some (Some) import Data.These +#if !MIN_VERSION_base(4,18,0)+import Control.Monad.Identity+import Data.Semigroup (Semigroup(..))+#endif+ import Reflex.Adjustable.Class import Reflex.Class import Reflex.DynamicWriter.Class@@ -99,6 +104,9 @@ , MonadFix , MonadAsyncException , MonadException+ , MonadCatch+ , MonadThrow+ , MonadMask ) deriving instance MonadHold t m => MonadHold t (DynamicWriterT t w m)@@ -120,7 +128,7 @@ -- | Run a 'DynamicWriterT' action. The dynamic writer output will be provided -- along with the result of the action.-runDynamicWriterT :: (MonadFix m, Reflex t, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)+runDynamicWriterT :: (Monad m, Reflex t, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w) runDynamicWriterT (DynamicWriterT a) = do (result, ws) <- runStateT a [] return (result, mconcat $ reverse ws)@@ -159,7 +167,7 @@ -- | When the execution of a 'DynamicWriterT' action is adjusted using -- 'Adjustable', the 'Dynamic' output of that action will also be updated to -- match.-instance (Adjustable t m, MonadFix m, Monoid w, MonadHold t m, Reflex t) => Adjustable t (DynamicWriterT t w m) where+instance (Adjustable t m, Monoid w, MonadHold t m, Reflex t) => Adjustable t (DynamicWriterT t w m) where runWithReplace a0 a' = do (result0, result') <- lift $ runWithReplace (runDynamicWriterT a0) $ runDynamicWriterT <$> a' tellDyn . join =<< holdDyn (snd result0) (snd <$> result')@@ -168,7 +176,7 @@ traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap weakenPatchDMapWith mergeDynIncremental traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove weakenPatchDMapWithMoveWith mergeDynIncrementalWithMove -traverseDMapWithKeyWithAdjustImpl :: forall t w k v' p p' v m. (PatchTarget (p' (Some k) (Dynamic t w)) ~ Map (Some k) (Dynamic t w), PatchTarget (p' (Some k) w) ~ Map (Some k) w, Patch (p' (Some k) w), Patch (p' (Some k) (Dynamic t w)), MonadFix m, Monoid w, Reflex t, MonadHold t m)+traverseDMapWithKeyWithAdjustImpl :: forall t w k v' p p' v m. (PatchTarget (p' (Some k) (Dynamic t w)) ~ Map (Some k) (Dynamic t w), PatchTarget (p' (Some k) w) ~ Map (Some k) w, Patch (p' (Some k) w), Patch (p' (Some k) (Dynamic t w)), Monoid w, Reflex t, MonadHold t m) => ( (forall a. k a -> v a -> m (DynamicWriterTLoweredResult t w v' a)) -> DMap k v -> Event t (p k v)@@ -195,7 +203,7 @@ tellDyn $ fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeMyDynIncremental i return (liftedResult0, liftedResult') -traverseIntMapWithKeyWithAdjustImpl :: forall t w v' p p' v m. (PatchTarget (p' (Dynamic t w)) ~ IntMap (Dynamic t w), PatchTarget (p' w) ~ IntMap w, Patch (p' w), Patch (p' (Dynamic t w)), MonadFix m, Monoid w, Reflex t, MonadHold t m, Functor p, p ~ p')+traverseIntMapWithKeyWithAdjustImpl :: forall t w v' p p' v m. (PatchTarget (p' (Dynamic t w)) ~ IntMap (Dynamic t w), PatchTarget (p' w) ~ IntMap w, Patch (p' w), Patch (p' (Dynamic t w)), Monoid w, Reflex t, MonadHold t m, Functor p, p ~ p') => ( (IntMap.Key -> v -> m (v', Dynamic t w)) -> IntMap v -> Event t (p v)@@ -219,7 +227,7 @@ return (liftedResult0, liftedResult') -- | Map a function over the output of a 'DynamicWriterT'.-withDynamicWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m, MonadFix m)+withDynamicWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m) => (w -> w') -> DynamicWriterT t w m a -> DynamicWriterT t w' m a
src/Reflex/DynamicWriter/Class.hs view
@@ -4,9 +4,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-}-#ifdef USE_REFLEX_OPTIMIZER-{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}-#endif+ module Reflex.DynamicWriter.Class ( MonadDynamicWriter , DynamicWriter(..)
src/Reflex/EventWriter/Base.hs view
@@ -10,9 +10,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}-#ifdef USE_REFLEX_OPTIMIZER-{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}-#endif+ module Reflex.EventWriter.Base ( EventWriterT (..) , runEventWriterT@@ -33,7 +31,9 @@ import Reflex.Requester.Class import Reflex.TriggerEvent.Class +import Control.Monad.Catch (MonadMask, MonadThrow, MonadCatch) import Control.Monad.Exception+import Control.Monad.Fix import Control.Monad.Identity import Control.Monad.Morph import Control.Monad.Primitive@@ -108,6 +108,9 @@ , MonadIO , MonadException , MonadAsyncException+ , MonadMask+ , MonadCatch+ , MonadThrow ) -- | Run a 'EventWriterT' action.
src/Reflex/EventWriter/Class.hs view
@@ -3,15 +3,16 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-}-#ifdef USE_REFLEX_OPTIMIZER-{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}-#endif+ module Reflex.EventWriter.Class ( EventWriter (..) ) where import Control.Monad.Reader (ReaderT, lift)++#if !MIN_VERSION_base(4,18,0) import Data.Semigroup (Semigroup)+#endif import Reflex.Class (Event)
src/Reflex/FunctorMaybe.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE CPP #-}-#if MIN_VERSION_base(4,9,0) {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-}-#endif -- | -- Module:@@ -16,10 +14,10 @@ import Data.IntMap (IntMap) import Data.Map (Map)-#if MIN_VERSION_base(4,9,0)+#if !MIN_VERSION_base(4,16,0) import Data.Semigroup (Option(..)) #endif-import Data.Witherable+import Witherable --TODO: See if there's a better class in the standard libraries already @@ -33,7 +31,7 @@ instance FunctorMaybe Maybe where fmapMaybe = mapMaybe -#if MIN_VERSION_base(4,9,0)+#if !MIN_VERSION_base(4,16,0) deriving instance FunctorMaybe Option #endif
src/Reflex/Host/Class.hs view
@@ -8,10 +8,9 @@ {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}-#ifdef USE_REFLEX_OPTIMIZER-{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}-#endif+ -- | This module provides the interface for hosting 'Reflex' engines. This -- should only be necessary if you're writing a binding or some other library -- that provides a core event loop.@@ -42,6 +41,7 @@ import Control.Monad.Trans.Writer (WriterT) import Data.Dependent.Sum (DSum (..)) import Data.GADT.Compare+import Data.Kind (Type) -- | Framework implementation support class for the reflex implementation -- represented by @t@.@@ -52,9 +52,9 @@ , MonadFix (HostFrame t) , MonadSubscribeEvent t (HostFrame t) ) => ReflexHost t where- type EventTrigger t :: * -> *- type EventHandle t :: * -> *- type HostFrame t :: * -> *+ type EventTrigger t :: Type -> Type+ type EventHandle t :: Type -> Type+ type HostFrame t :: Type -> Type -- | Monad in which Events can be 'subscribed'. This forces all underlying -- event sources to be initialized, so that the event will fire whenever it@@ -114,7 +114,7 @@ , MonadSample t (ReadPhase m) , MonadHold t (ReadPhase m) ) => MonadReflexHost t m | m -> t where- type ReadPhase m :: * -> *+ type ReadPhase m :: Type -> Type -- | Propagate some events firings and read the values of events afterwards. -- -- This function will create a new frame to fire the given events. It will
src/Reflex/Host/Headless.hs view
@@ -1,42 +1,51 @@-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeOperators #-} module Reflex.Host.Headless where import Control.Concurrent.Chan (newChan, readChan)-import Control.Monad (unless)+import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.Fix (MonadFix, fix) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Primitive (PrimMonad) import Control.Monad.Ref (MonadRef, Ref, readRef) import Data.Dependent.Sum (DSum (..), (==>))-import Data.Foldable (for_)+import Data.Foldable (for_, asum) import Data.Functor.Identity (Identity(..)) import Data.IORef (IORef, readIORef)-import Data.Maybe (catMaybes, fromMaybe)+import Data.Maybe (catMaybes) import Data.Traversable (for) import Reflex import Reflex.Host.Class type MonadHeadlessApp t m =- ( Adjustable t m+ ( Reflex t+ , Adjustable t m+ , MonadCatch m+ , MonadFix (Performable m) , MonadFix m+ , MonadHold t (Performable m) , MonadHold t m , MonadIO (HostFrame t) , MonadIO (Performable m) , MonadIO m+ , MonadMask m , MonadRef (HostFrame t)+ , MonadSample t (Performable m)+ , MonadSample t m+ , MonadThrow m+ , MonadThrow (Performable m) , NotReady t m , PerformEvent t m , PostBuild t m , PrimMonad (HostFrame t) , Ref (HostFrame t) ~ IORef , Ref m ~ IORef- , Reflex t , ReflexHost t , TriggerEvent t m )@@ -46,10 +55,11 @@ -- classes to interface the FRP network with the outside world. Useful for -- testing. Each headless network runs on its own spider timeline. runHeadlessApp- :: (forall t m. MonadHeadlessApp t m => m (Event t ()))+ :: forall a+ . (forall t m. MonadHeadlessApp t m => m (Event t a)) -- ^ The action to be run in the headless FRP network. The FRP network is -- closed at the first occurrence of the resulting 'Event'.- -> IO ()+ -> IO a runHeadlessApp guest = -- We are using the 'Spider' implementation of reflex. Running the host -- allows us to take actions on the FRP timeline.@@ -89,35 +99,46 @@ shutdown <- subscribeEvent result -- When there is a subscriber to the post-build event, fire the event.- soa <- for mPostBuildTrigger $ \postBuildTrigger ->- fire [postBuildTrigger :=> Identity ()] $ isFiring shutdown+ initialShutdownEventFirings :: Maybe [Maybe a] <- for mPostBuildTrigger $ \postBuildTrigger ->+ fire [postBuildTrigger :=> Identity ()] $ sequence =<< readEvent shutdown+ let shutdownImmediately = case initialShutdownEventFirings of+ -- We didn't even fire postBuild because it wasn't subscribed+ Nothing -> Nothing+ -- Take the first Just, if there is one. Ideally, we should cut off+ -- the event loop as soon as the firing happens, but Performable+ -- doesn't currently give us an easy way to do that+ Just firings -> asum firings - -- The main application loop. We wait for new events and fire those that- -- have subscribers. If we detect a shutdown request, the application- -- terminates.- unless (or (fromMaybe [] soa)) $ fix $ \loop -> do- -- Read the next event (blocking).- ers <- liftIO $ readChan events- stop <- do- -- Fire events that have subscribers.- fireEventTriggerRefs fc ers $- -- Check if the shutdown 'Event' is firing.- isFiring shutdown- if or stop- then pure ()- else loop+ case shutdownImmediately of+ Just exitResult -> pure exitResult+ -- The main application loop. We wait for new events and fire those that+ -- have subscribers. If we detect a shutdown request, the application+ -- terminates.+ Nothing -> fix $ \loop -> do+ -- Read the next event (blocking).+ ers <- liftIO $ readChan events+ shutdownEventFirings :: [Maybe a] <- do+ -- Fire events that have subscribers.+ fireEventTriggerRefs fc ers $+ -- Check if the shutdown 'Event' is firing.+ sequence =<< readEvent shutdown+ let -- If the shutdown event fires multiple times, take the first one.+ -- Ideally, we should cut off the event loop as soon as this fires,+ -- but Performable doesn't currently give us an easy way to do that.+ shutdownNow = asum shutdownEventFirings+ case shutdownNow of+ Just exitResult -> pure exitResult+ Nothing -> loop where- isFiring ev = readEvent ev >>= \case- Nothing -> pure False- Just _ -> pure True -- Use the given 'FireCommand' to fire events that have subscribers -- and call the callback for the 'TriggerInvocation' of each. fireEventTriggerRefs- :: MonadIO m+ :: forall b m t+ . MonadIO m => FireCommand t m -> [DSum (EventTriggerRef t) TriggerInvocation]- -> ReadPhase m a- -> m [a]+ -> ReadPhase m b+ -> m [b] fireEventTriggerRefs (FireCommand fire) ers rcb = do mes <- liftIO $ for ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do
src/Reflex/Network.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-}-#ifdef USE_REFLEX_OPTIMIZER-{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}-#endif+ -- | -- Module: -- Reflex.Network@@ -22,7 +20,7 @@ -- | A 'Dynamic' "network": Takes a 'Dynamic' of network-creating actions and replaces the network whenever the 'Dynamic' updates. -- The returned Event of network results fires at post-build time and when the 'Dynamic' updates. -- Note: Often, the type 'a' is an Event, in which case the return value is an Event-of-Events, where the outer 'Event' fires--- when switching networks. Such an 'Event' would typically be flattened (via 'switchPromptly').+-- when switching networks. Such an 'Event' would typically be flattened (via 'switchHoldPromptly'). networkView :: (NotReady t m, Adjustable t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a) networkView child = do postBuild <- getPostBuild@@ -30,8 +28,8 @@ snd <$> runWithReplace notReady newChild -- | Given an initial "network" and an 'Event' of network-creating actions, create a network that is recreated whenever the Event fires.--- The returned Dynamic of network results occurs when the Event does.--- Note: Often, the type 'a' is an Event, in which case the return value is a Dynamic-of-Events that would typically be flattened.+-- The returned Dynamic of network results occurs when the Event does.+-- Note: Often, the type 'a' is an Event, in which case the return value is a Dynamic-of-Events that would typically be flattened (via 'switchPromptlyDyn'). networkHold :: (Adjustable t m, MonadHold t m) => m a -> Event t (m a) -> m (Dynamic t a) networkHold child0 newChild = do (result0, newResult) <- runWithReplace child0 newChild
src/Reflex/NotReady/Class.hs view
@@ -4,10 +4,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}-#ifdef USE_REFLEX_OPTIMIZER-{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}-#endif+ module Reflex.NotReady.Class ( NotReady(..) ) where
− src/Reflex/Optimizer.hs
@@ -1,65 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}--- |--- Module:--- Reflex.Optimizer--- Description:--- This module provides a GHC plugin designed to improve code that uses--- Reflex. Currently, it just adds an INLINABLE pragma to any top-level--- definition that doesn't have an explicit inlining pragma. In the future,--- additional optimizations are likely to be added.-module Reflex.Optimizer- ( plugin- ) where--#ifdef ghcjs_HOST_OS-import Plugins-#else-import Control.Arrow-import CoreMonad-import Data.String-import GhcPlugins--#if MIN_VERSION_base(4,9,0)-import Prelude hiding ((<>))-#endif--#endif--#ifdef ghcjs_HOST_OS---- | The GHCJS build of Reflex.Optimizer just throws an error; instead, the version built with GHC should be used.-plugin :: Plugin-plugin = error "The GHCJS build of Reflex.Optimizer cannot be used. Instead, build with GHC and use the result with GHCJS."--#else---- | The GHC plugin itself. See "GhcPlugins" for more details.-plugin :: Plugin-plugin = defaultPlugin { installCoreToDos = install }--install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]-install [] p = do- liftIO $ putStrLn $ showSDocUnsafe $ ppr p- let f = \case- simpl@(CoreDoSimplify _ _) -> [CoreDoSpecialising, simpl]- x -> [x]- return $ makeInlinable : concatMap f p-install options@(_:_) p = do- warnMsg $ "Reflex.Optimizer: ignoring " <> fromString (show $ length options) <> " command-line options"- install [] p--makeInlinable :: CoreToDo-makeInlinable = CoreDoPluginPass "MakeInlinable" $ \modGuts -> do- let f v = setIdInfo v $ let i = idInfo v in- setInlinePragInfo i $ let p = inlinePragInfo i in- if isDefaultInlinePragma p- then defaultInlinePragma { inl_inline = Inlinable }- else p- newBinds = flip map (mg_binds modGuts) $ \case- NonRec b e -> NonRec (f b) e- Rec bes -> Rec $ map (first f) bes- return $ modGuts { mg_binds = newBinds }--#endif
src/Reflex/PerformEvent/Base.hs view
@@ -15,25 +15,23 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}-#ifdef USE_REFLEX_OPTIMIZER-{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}-#endif+ module Reflex.PerformEvent.Base ( PerformEventT (..) , FireCommand (..) , hostPerformEventT ) where -import Reflex.Class import Reflex.Adjustable.Class+import Reflex.Class import Reflex.Host.Class import Reflex.PerformEvent.Class import Reflex.Requester.Base import Reflex.Requester.Class -import Control.Lens+import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.Exception-import Control.Monad.Identity+import Control.Monad.Fix import Control.Monad.Primitive import Control.Monad.Reader import Control.Monad.Ref@@ -41,10 +39,15 @@ import Data.Dependent.Map (DMap) import qualified Data.Dependent.Map as DMap import Data.Dependent.Sum+import Data.Functor.Identity import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap import qualified Data.Semigroup as S +#if !MIN_VERSION_base(4,18,0)+import Control.Monad.Identity+#endif+ -- | A function that fires events for the given 'EventTrigger's and then runs -- any followup actions provided via 'PerformEvent'. The given 'ReadPhase' -- action will be run once for the initial trigger execution as well as once for@@ -63,19 +66,22 @@ deriving instance (ReflexHost t, MonadException (HostFrame t)) => MonadException (PerformEventT t m) deriving instance (ReflexHost t, Monoid a) => Monoid (PerformEventT t m a) deriving instance (ReflexHost t, S.Semigroup a) => S.Semigroup (PerformEventT t m a)+deriving instance (ReflexHost t, MonadCatch (HostFrame t)) => MonadCatch (PerformEventT t m)+deriving instance (ReflexHost t, MonadThrow (HostFrame t)) => MonadThrow (PerformEventT t m)+deriving instance (ReflexHost t, MonadMask (HostFrame t)) => MonadMask (PerformEventT t m) instance (PrimMonad (HostFrame t), ReflexHost t) => PrimMonad (PerformEventT t m) where type PrimState (PerformEventT t m) = PrimState (HostFrame t) primitive = PerformEventT . lift . primitive -instance (ReflexHost t, Ref m ~ Ref IO) => PerformEvent t (PerformEventT t m) where+instance (Monad (HostFrame t), ReflexHost t, Ref m ~ Ref IO) => PerformEvent t (PerformEventT t m) where type Performable (PerformEventT t m) = HostFrame t {-# INLINABLE performEvent_ #-} performEvent_ = PerformEventT . requesting_ {-# INLINABLE performEvent #-} performEvent = PerformEventT . requestingIdentity -instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT t m) where+instance ReflexHost t => Adjustable t (PerformEventT t m) where runWithReplace outerA0 outerA' = PerformEventT $ runWithReplaceRequesterTWith f (coerce outerA0) (coerceEvent outerA') where f :: HostFrame t a -> Event t (HostFrame t b) -> RequesterT t (HostFrame t) Identity (HostFrame t) (a, Event t b) f a0 a' = do@@ -86,7 +92,7 @@ traverseDMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithKey) mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm') traverseDMapWithKeyWithAdjustWithMove f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithMoveWithKey) mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm') -defaultAdjustBase :: forall t v v2 k' p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t)+defaultAdjustBase :: forall t v v2 k' p. (Monad (HostFrame t), Reflex t) => ((forall a. k' a -> v a -> HostFrame t (v2 a)) -> p k' v -> HostFrame t (p k' v2)) -> (forall a. k' a -> v a -> HostFrame t (v2 a)) -> DMap k' v@@ -97,7 +103,7 @@ result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f' return (result0, result') -defaultAdjustIntBase :: forall t v v2 p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t)+defaultAdjustIntBase :: forall t v v2 p. (Monad (HostFrame t), Reflex t) => ((IntMap.Key -> v -> HostFrame t v2) -> p v -> HostFrame t (p v2)) -> (IntMap.Key -> v -> HostFrame t v2) -> IntMap v@@ -119,9 +125,7 @@ -- at the appropriate time. {-# INLINABLE hostPerformEventT #-} hostPerformEventT :: forall t m a.- ( Monad m- , MonadSubscribeEvent t m- , MonadReflexHost t m+ ( MonadReflexHost t m , MonadRef m , Ref m ~ Ref IO )
src/Reflex/PerformEvent/Class.hs view
@@ -1,4 +1,4 @@--- | This module defines 'PerformEvent' and 'TriggerEvent', which mediate the+-- | This module defines 'PerformEvent', which mediates the -- interaction between a "Reflex"-based program and the external side-effecting -- actions such as 'IO'. {-# LANGUAGE CPP #-}@@ -9,26 +9,30 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}-#ifdef USE_REFLEX_OPTIMIZER-{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}-#endif+ module Reflex.PerformEvent.Class ( PerformEvent (..) , performEventAsync ) where -import Reflex.Class-import Reflex.TriggerEvent.Class-+import Control.Monad import Control.Monad.Reader import Control.Monad.Trans.Maybe (MaybeT (..))+import Data.Kind (Type) +#if !MIN_VERSION_base(4,18,0)+import Control.Monad.Fix+#endif++import Reflex.Class+import Reflex.TriggerEvent.Class+ -- | 'PerformEvent' represents actions that can trigger other actions based on -- 'Event's. class (Reflex t, Monad (Performable m), Monad m) => PerformEvent t m | m -> t where -- | The type of action to be triggered; this is often not the same type as -- the triggering action.- type Performable m :: * -> *+ type Performable m :: Type -> Type -- | Perform the action contained in the given 'Event' whenever the 'Event' -- fires. Return the result in another 'Event'. Note that the output 'Event' -- will generally occur later than the input 'Event', since most 'Performable'
src/Reflex/PostBuild/Base.hs view
@@ -10,9 +10,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}-#ifdef USE_REFLEX_OPTIMIZER-{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}-#endif+ module Reflex.PostBuild.Base ( PostBuildT (..) , runPostBuildT@@ -21,16 +19,9 @@ , mapDMapWithAdjustImpl ) where -import Reflex.Class-import Reflex.Adjustable.Class-import Reflex.Host.Class-import Reflex.PerformEvent.Class-import Reflex.PostBuild.Class-import Reflex.TriggerEvent.Class--import Control.Applicative (liftA2)+import Control.Monad.Catch (MonadMask, MonadThrow, MonadCatch) import Control.Monad.Exception-import Control.Monad.Identity+import Control.Monad.Fix import Control.Monad.Primitive import Control.Monad.Reader import Control.Monad.Ref@@ -42,8 +33,33 @@ import qualified Data.IntMap.Strict as IntMap import qualified Data.Semigroup as S +#if !MIN_VERSION_base(4,18,0)+import Control.Applicative (liftA2)+import Control.Monad.Identity+#endif++import Reflex.Class+import Reflex.Adjustable.Class+import Reflex.Host.Class+import Reflex.PerformEvent.Class+import Reflex.PostBuild.Class+import Reflex.TriggerEvent.Class+ -- | Provides a basic implementation of 'PostBuild'.-newtype PostBuildT t m a = PostBuildT { unPostBuildT :: ReaderT (Event t ()) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadTrans, MonadException, MonadAsyncException)+newtype PostBuildT t m a = PostBuildT { unPostBuildT :: ReaderT (Event t ()) m a }+ deriving+ ( Functor+ , Applicative+ , Monad+ , MonadFix+ , MonadIO+ , MonadTrans+ , MonadException+ , MonadAsyncException+ , MonadMask+ , MonadThrow+ , MonadCatch+ ) -- | Run a 'PostBuildT' action. An 'Event' should be provided that fires -- immediately after the action is finished running; no other 'Event's should@@ -55,7 +71,6 @@ -- TODO: Monoid and Semigroup can likely be derived once ReaderT has them. instance (Monoid a, Applicative m) => Monoid (PostBuildT t m a) where mempty = pure mempty- mappend = liftA2 mappend instance (S.Semigroup a, Applicative m) => S.Semigroup (PostBuildT t m a) where (<>) = liftA2 (S.<>)
src/Reflex/PostBuild/Class.hs view
@@ -7,9 +7,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}-#ifdef USE_REFLEX_OPTIMIZER-{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}-#endif+ module Reflex.PostBuild.Class ( PostBuild (..) ) where
src/Reflex/Profiled.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -11,6 +12,7 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE RankNTypes #-}+ -- | -- Module: -- Reflex.Profiled@@ -33,9 +35,9 @@ import Data.FastMutableIntMap import Data.IORef import Data.List+import Data.Kind (Type) import Data.Map (Map) import qualified Data.Map.Strict as Map-import Data.Monoid ((<>)) import Data.Ord import Data.Profunctor.Unsafe ((#.)) import qualified Data.Semigroup as S@@ -44,6 +46,12 @@ import GHC.Foreign import GHC.IO.Encoding import GHC.Stack+import System.IO.Unsafe++#if !MIN_VERSION_base(4,18,0)+import Data.Monoid ((<>))+#endif+ import Reflex.Adjustable.Class import Reflex.BehaviorWriter.Class import Reflex.Class@@ -57,8 +65,6 @@ import Reflex.Requester.Class import Reflex.TriggerEvent.Class -import System.IO.Unsafe- data ProfiledTimeline t {-# NOINLINE profilingData #-}@@ -147,7 +153,7 @@ pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e pull = Behavior_Profiled . pull . coerce fanG (Event_Profiled e) = EventSelectorG $ coerce $ selectG (fanG $ profileEvent e)- mergeG :: forall (k :: z -> *) q v. GCompare k+ mergeG :: forall z (k :: z -> Type) q v. GCompare k => (forall a. q a -> Event (ProfiledTimeline t) (v a)) -> DMap k q -> Event (ProfiledTimeline t) (DMap k v) mergeG nt = Event_Profiled #. mergeG (coerce nt)
src/Reflex/Pure.hs view
@@ -5,17 +5,14 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE PolyKinds #-}--#ifdef USE_REFLEX_OPTIMIZER-{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}-#endif- -- There are two expected orphan instances in this module: -- * MonadSample (Pure t) ((->) t) -- * MonadHold (Pure t) ((->) t) {-# OPTIONS_GHC -fno-warn-orphans #-}+ -- | -- Module: Reflex.Pure -- Description:@@ -212,6 +209,3 @@ headE = slowHeadE now t = Event $ guard . (t ==)-- -
src/Reflex/Query/Base.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-}@@ -19,7 +20,7 @@ , mapQueryT ) where -import Control.Applicative (liftA2)+import Control.Monad.Catch (MonadMask, MonadThrow, MonadCatch) import Control.Monad.Exception import Control.Monad.Fix import Control.Monad.Morph@@ -37,13 +38,19 @@ import Data.GADT.Compare (GCompare) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap+import Data.Kind (Type) import Data.Map (Map) import qualified Data.Map as Map-import Data.Monoid ((<>)) import qualified Data.Semigroup as S+import Data.Semigroup.Commutative import Data.Some (Some(Some)) import Data.These +#if !MIN_VERSION_base(4,18,0)+import Control.Applicative (liftA2)+import Data.Monoid ((<>))+#endif+ import Reflex.Class import Reflex.Adjustable.Class import Reflex.DynamicWriter.Class@@ -58,12 +65,12 @@ import Reflex.TriggerEvent.Class newtype QueryT t q m a = QueryT { unQueryT :: StateT [Behavior t q] (EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m)) a }- deriving (Functor, Applicative, Monad, MonadException, MonadFix, MonadIO, MonadAtomicRef)+ deriving (Functor, Applicative, Monad, MonadException, MonadFix, MonadIO, MonadAtomicRef, MonadCatch, MonadThrow, MonadMask) deriving instance MonadHold t m => MonadHold t (QueryT t q m) deriving instance MonadSample t m => MonadSample t (QueryT t q m) -runQueryT :: (MonadFix m, Additive q, Group q, Reflex t) => QueryT t q m a -> Dynamic t (QueryResult q) -> m (a, Incremental t (AdditivePatch q))+runQueryT :: (MonadFix m, Commutative q, Group q, Reflex t) => QueryT t q m a -> Dynamic t (QueryResult q) -> m (a, Incremental t (AdditivePatch q)) runQueryT (QueryT a) qr = do ((r, bs), es) <- runReaderT (runEventWriterT (runStateT a mempty)) qr return (r, unsafeBuildIncremental (foldlM (\b c -> (b <>) <$> sample c) mempty bs) (fmapCheap AdditivePatch es))@@ -79,7 +86,7 @@ maskMempty :: (Eq a, Monoid a) => a -> Maybe a maskMempty x = if x == mempty then Nothing else Just x -instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t m, Adjustable t m) => Adjustable t (QueryT t q m) where+instance (Reflex t, MonadFix m, Group q, Commutative q, Query q, Eq q, MonadHold t m, Adjustable t m) => Adjustable t (QueryT t q m) where runWithReplace (QueryT a0) a' = do ((r0, bs0), r') <- QueryT $ lift $ runWithReplace (runStateT a0 []) $ fmapCheap (flip runStateT [] . unQueryT) a' let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q@@ -138,7 +145,7 @@ tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch return (liftedResult0, liftedResult') - traverseDMapWithKeyWithAdjust :: forall (k :: * -> *) v v'. (GCompare k) => (forall a. k a -> v a -> QueryT t q m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> QueryT t q m (DMap k v', Event t (PatchDMap k v'))+ traverseDMapWithKeyWithAdjust :: forall (k :: Type -> Type) v v'. (GCompare k) => (forall a. k a -> v a -> QueryT t q m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> QueryT t q m (DMap k v', Event t (PatchDMap k v')) traverseDMapWithKeyWithAdjust f dm0 dm' = do let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a) f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v@@ -183,7 +190,7 @@ tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch return (liftedResult0, liftedResult') - traverseDMapWithKeyWithAdjustWithMove :: forall (k :: * -> *) v v'. (GCompare k) => (forall a. k a -> v a -> QueryT t q m (v' a)) -> DMap k v -> Event t (PatchDMapWithMove k v) -> QueryT t q m (DMap k v', Event t (PatchDMapWithMove k v'))+ traverseDMapWithKeyWithAdjustWithMove :: forall (k :: Type -> Type) v v'. (GCompare k) => (forall a. k a -> v a -> QueryT t q m (v' a)) -> DMap k v -> Event t (PatchDMapWithMove k v) -> QueryT t q m (DMap k v', Event t (PatchDMapWithMove k v')) traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a) f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v@@ -282,7 +289,7 @@ (<>) = liftA2 (S.<>) -- | withQueryT's QueryMorphism argument needs to be a group homomorphism in order to behave correctly-withQueryT :: (MonadFix m, PostBuild t m, Group q, Group q', Additive q, Additive q', Query q')+withQueryT :: (MonadFix m, PostBuild t m, Group q, Group q', Commutative q, Commutative q', Query q') => QueryMorphism q q' -> QueryT t q m a -> QueryT t q' m a@@ -299,7 +306,7 @@ mapQueryT f (QueryT a) = QueryT $ mapStateT (mapEventWriterT (mapReaderT f)) a -- | dynWithQueryT's (Dynamic t QueryMorphism) argument needs to be a group homomorphism at all times in order to behave correctly-dynWithQueryT :: (MonadFix m, PostBuild t m, Group q, Additive q, Group q', Additive q', Query q')+dynWithQueryT :: (MonadFix m, PostBuild t m, Group q, Commutative q, Group q', Commutative q', Query q') => Dynamic t (QueryMorphism q q') -> QueryT t q m a -> QueryT t q' m a@@ -324,7 +331,7 @@ return $ Just $ AdditivePatch $ mconcat [ g a bOld, negateG (g aOld bOld), g a b] in unsafeBuildIncremental (g <$> sample (current da) <*> sample (currentIncremental ib)) ec -instance (Monad m, Group q, Additive q, Query q, Reflex t) => MonadQuery t q (QueryT t q m) where+instance (Monad m, Group q, Commutative q, Query q, Reflex t) => MonadQuery t q (QueryT t q m) where tellQueryIncremental q = do QueryT (modify (currentIncremental q:)) QueryT (lift (tellEvent (fmapCheap unAdditivePatch (updatedIncremental q))))
src/Reflex/Query/Class.hs view
@@ -6,6 +6,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}+ -- | -- Module: -- Reflex.Query.Class@@ -33,13 +34,18 @@ import Data.Bits import Data.Data import Data.Ix+import Data.Kind (Type) import Data.Map.Monoidal (MonoidalMap) import qualified Data.Map.Monoidal as MonoidalMap-import Data.Semigroup (Semigroup(..))-import Foreign.Storable+import Data.Semigroup.Commutative import Data.Void import Data.Monoid hiding ((<>))+import Foreign.Storable++#if !MIN_VERSION_base(4,18,0) import Control.Applicative+import Data.Semigroup (Semigroup(..))+#endif import Reflex.Class @@ -48,7 +54,7 @@ -- The @crop@ function provides a way to determine what part of a given 'QueryResult' -- is relevant to a given 'Query'. class (Monoid (QueryResult a), Semigroup (QueryResult a)) => Query a where- type QueryResult a :: *+ type QueryResult a :: Type crop :: a -> QueryResult a -> QueryResult a instance (Ord k, Query v) => Query (MonoidalMap k v) where@@ -123,7 +129,7 @@ instance Group SelectedCount where negateG (SelectedCount a) = SelectedCount (negate a) -instance Additive SelectedCount+instance Commutative SelectedCount -- | The Semigroup\/Monoid\/Group instances for a Query containing 'SelectedCount's should use -- this function which returns Nothing if the result is 0. This allows the pruning of leaves@@ -133,7 +139,7 @@ -- | A class that allows sending of 'Query's and retrieval of 'QueryResult's. See 'queryDyn' for a commonly -- used interface.-class (Group q, Additive q, Query q, Monad m) => MonadQuery t q m | m -> q t where+class (Group q, Commutative q, Query q, Monad m) => MonadQuery t q m | m -> q t where tellQueryIncremental :: Incremental t (AdditivePatch q) -> m () askQueryResult :: m (Dynamic t (QueryResult q)) queryIncremental :: Incremental t (AdditivePatch q) -> m (Dynamic t (QueryResult q))
src/Reflex/Requester/Base.hs view
@@ -1,23 +1,3 @@--- | This module provides 'RequesterT', the standard implementation of--- 'Requester'.-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE RecursiveDo #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-#ifdef USE_REFLEX_OPTIMIZER-{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}-#endif module Reflex.Requester.Base ( RequesterT (..) , runRequesterT@@ -32,511 +12,10 @@ , requesterDataToList , singletonRequesterData , matchResponsesWithRequests+ , matchResponseMapWithRequests , multiEntry , unMultiEntry , requesting' ) where -import Reflex.Class-import Reflex.Adjustable.Class-import Reflex.Dynamic-import Reflex.Host.Class-import Reflex.PerformEvent.Class-import Reflex.PostBuild.Class-import Reflex.Requester.Class-import Reflex.TriggerEvent.Class--import Control.Applicative (liftA2)-import Control.Monad.Exception-import Control.Monad.Identity-import Control.Monad.Morph-import Control.Monad.Primitive-import Control.Monad.Reader-import Control.Monad.Ref-import Control.Monad.State.Strict-import Data.Bits-import Data.Coerce-import Data.Dependent.Map (DMap)-import qualified Data.Dependent.Map as DMap-import Data.Dependent.Sum (DSum (..))-import Data.Functor.Compose-import Data.Functor.Misc-import Data.IntMap.Strict (IntMap)-import qualified Data.IntMap.Strict as IntMap-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Monoid ((<>))-import Data.Proxy-import qualified Data.Semigroup as S-import Data.Some (Some(Some))-import Data.Type.Equality-import Data.Unique.Tag--import GHC.Exts (Any)-import Unsafe.Coerce----TODO: Make this module type-safe--newtype TagMap (f :: * -> *) = TagMap (IntMap Any)--newtype RequesterData f = RequesterData (TagMap (Entry f))--data RequesterDataKey a where- RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a- RequesterDataKey_Multi :: {-# UNPACK #-} !(MyTag Multi) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a --TODO: Don't put a second Int here (or in the other Multis); use a single Int instead- RequesterDataKey_Multi2 :: {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a- RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a--singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f-singletonRequesterData rdk v = case rdk of- RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v- RequesterDataKey_Multi k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v- RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v- RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v--requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]-requesterDataToList (RequesterData m) = do- k :=> Entry e <- tagMapToList m- case myKeyType k of- MyTagType_Single -> return $ RequesterDataKey_Single k :=> e- MyTagType_Multi -> do- (k', e') <- IntMap.toList e- k'' :=> e'' <- requesterDataToList e'- return $ RequesterDataKey_Multi k k' k'' :=> e''- MyTagType_Multi2 -> do- (k', e') <- Map.toList e- (k'', e'') <- IntMap.toList e'- k''' :=> e''' <- requesterDataToList e''- return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''- MyTagType_Multi3 -> do- (k', e') <- IntMap.toList e- (k'', e'') <- IntMap.toList e'- k''' :=> e''' <- requesterDataToList e''- return $ RequesterDataKey_Multi3 k k' k'' k''' :=> e'''--singletonTagMap :: forall f a. MyTag a -> f a -> TagMap f-singletonTagMap (MyTag k) v = TagMap $ IntMap.singleton k $ (unsafeCoerce :: f a -> Any) v--tagMapToList :: forall f. TagMap f -> [DSum MyTag f]-tagMapToList (TagMap m) = f <$> IntMap.toList m- where f :: (Int, Any) -> DSum MyTag f- f (k, v) = MyTag k :=> (unsafeCoerce :: Any -> f a) v--traverseTagMapWithKey :: forall t f g. Applicative t => (forall a. MyTag a -> f a -> t (g a)) -> TagMap f -> t (TagMap g)-traverseTagMapWithKey f (TagMap m) = TagMap <$> IntMap.traverseWithKey g m- where- g :: Int -> Any -> t Any- g k v = (unsafeCoerce :: g a -> Any) <$> f (MyTag k) ((unsafeCoerce :: Any -> f a) v)---- | Runs in reverse to accommodate for the fact that we accumulate it in reverse-traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequesterData request -> m (RequesterData response)-traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWithKey go m --TODO: reverse this, since our tags are in reverse order- where go :: forall x. MyTag x -> Entry request x -> m (Entry response x)- go k (Entry request) = Entry <$> case myKeyType k of- MyTagType_Single -> f request- MyTagType_Multi -> traverse (traverseRequesterData f) request- MyTagType_Multi2 -> traverse (traverse (traverseRequesterData f)) request- MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request---- | 'traverseRequesterData' with its arguments flipped-forRequesterData :: forall request response m. Applicative m => RequesterData request -> (forall a. request a -> m (response a)) -> m (RequesterData response)-forRequesterData r f = traverseRequesterData f r--data MyTagType :: * -> * where- MyTagType_Single :: MyTagType (Single a)- MyTagType_Multi :: MyTagType Multi- MyTagType_Multi2 :: MyTagType (Multi2 k)- MyTagType_Multi3 :: MyTagType Multi3--myKeyType :: MyTag x -> MyTagType x-myKeyType (MyTag k) = case k .&. 0x3 of- 0x0 -> unsafeCoerce MyTagType_Single- 0x1 -> unsafeCoerce MyTagType_Multi- 0x2 -> unsafeCoerce MyTagType_Multi2- 0x3 -> unsafeCoerce MyTagType_Multi3- t -> error $ "Reflex.Requester.Base.myKeyType: no such key type" <> show t--data Single a-data Multi-data Multi2 (k :: * -> *)-data Multi3--class MyTagTypeOffset x where- myTagTypeOffset :: proxy x -> Int--instance MyTagTypeOffset (Single a) where- myTagTypeOffset _ = 0x0--instance MyTagTypeOffset Multi where- myTagTypeOffset _ = 0x1--instance MyTagTypeOffset (Multi2 k) where- myTagTypeOffset _ = 0x2--instance MyTagTypeOffset Multi3 where- myTagTypeOffset _ = 0x3--type family EntryContents request a where- EntryContents request (Single a) = request a- EntryContents request Multi = IntMap (RequesterData request)- EntryContents request (Multi2 k) = Map (Some k) (IntMap (RequesterData request))- EntryContents request Multi3 = IntMap (IntMap (RequesterData request))--newtype Entry request x = Entry { unEntry :: EntryContents request x }--{-# INLINE singleEntry #-}-singleEntry :: f a -> Entry f (Single a)-singleEntry = Entry--{-# INLINE multiEntry #-}-multiEntry :: IntMap (RequesterData f) -> Entry f Multi-multiEntry = Entry--{-# INLINE unMultiEntry #-}-unMultiEntry :: Entry f Multi -> IntMap (RequesterData f)-unMultiEntry = unEntry---- | We use a hack here to pretend we have x ~ request a; we don't want to use a GADT, because GADTs (even with zero-size existential contexts) can't be newtypes--- WARNING: This type should never be exposed. In particular, this is extremely unsound if a MyTag from one run of runRequesterT is ever compared against a MyTag from another-newtype MyTag x = MyTag Int deriving (Show, Eq, Ord, Enum)--newtype MyTagWrap (f :: * -> *) x = MyTagWrap Int deriving (Show, Eq, Ord, Enum)--{-# INLINE castMyTagWrap #-}-castMyTagWrap :: MyTagWrap f (Entry f x) -> MyTagWrap g (Entry g x)-castMyTagWrap = coerce--instance GEq MyTag where- (MyTag a) `geq` (MyTag b) =- if a == b- then Just $ unsafeCoerce Refl- else Nothing--instance GCompare MyTag where- (MyTag a) `gcompare` (MyTag b) =- case a `compare` b of- LT -> GLT- EQ -> unsafeCoerce GEQ- GT -> GGT--instance GEq (MyTagWrap f) where- (MyTagWrap a) `geq` (MyTagWrap b) =- if a == b- then Just $ unsafeCoerce Refl- else Nothing--instance GCompare (MyTagWrap f) where- (MyTagWrap a) `gcompare` (MyTagWrap b) =- case a `compare` b of- LT -> GLT- EQ -> unsafeCoerce GEQ- GT -> GGT--data RequesterState t (request :: * -> *) = RequesterState- { _requesterState_nextMyTag :: {-# UNPACK #-} !Int -- Starts at -4 and goes down by 4 each time, to accommodate two 'type' bits at the bottom- , _requesterState_requests :: ![(Int, Event t Any)]- }---- | A basic implementation of 'Requester'.-newtype RequesterT t request (response :: * -> *) m a = RequesterT { unRequesterT :: StateT (RequesterState t request) (ReaderT (EventSelectorInt t Any) m) a }- deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException--- MonadAsyncException can't be derived on ghc-8.0.1; we use base-4.9.1 as a proxy for ghc-8.0.2-#if MIN_VERSION_base(4,9,1)- , MonadAsyncException-#endif- )--deriving instance MonadSample t m => MonadSample t (RequesterT t request response m)-deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)-deriving instance PostBuild t m => PostBuild t (RequesterT t request response m)-deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)--instance PrimMonad m => PrimMonad (RequesterT t request response m) where- type PrimState (RequesterT t request response m) = PrimState m- primitive = lift . primitive---- TODO: Monoid and Semigroup can likely be derived once StateT has them.-instance (Monoid a, Monad m) => Monoid (RequesterT t request response m a) where- mempty = pure mempty- mappend = liftA2 mappend--instance (S.Semigroup a, Monad m) => S.Semigroup (RequesterT t request response m a) where- (<>) = liftA2 (S.<>)----- | Run a 'RequesterT' action. The resulting 'Event' will fire whenever--- requests are made, and responses should be provided in the input 'Event'.--- The 'Tag' keys will be used to return the responses to the same place the--- requests were issued.-runRequesterT :: (Reflex t, Monad m)- => RequesterT t request response m a- -> Event t (RequesterData response) --TODO: This DMap will be in reverse order, so we need to make sure the caller traverses it in reverse- -> m (a, Event t (RequesterData request)) --TODO: we need to hide these 'MyTag's here, because they're unsafe to mix in the wild-runRequesterT (RequesterT a) responses = do- (result, s) <- runReaderT (runStateT a $ RequesterState (-4) []) $ fanInt $- coerceEvent responses- return (result, fmapCheap (RequesterData . TagMap) $ mergeInt $ IntMap.fromDistinctAscList $ _requesterState_requests s)---- | Map a function over the request and response of a 'RequesterT'-withRequesterT- :: (Reflex t, MonadFix m)- => (forall x. req x -> req' x) -- ^ The function to map over the request- -> (forall x. rsp' x -> rsp x) -- ^ The function to map over the response- -> RequesterT t req rsp m a -- ^ The internal 'RequesterT' whose input and output will be transformed- -> RequesterT t req' rsp' m a -- ^ The resulting 'RequesterT'-withRequesterT freq frsp child = do- rec let rsp = fmap (runIdentity . traverseRequesterData (Identity . frsp)) rsp'- (a, req) <- lift $ runRequesterT child rsp- rsp' <- fmap (flip selectInt 0 . fanInt . fmapCheap unMultiEntry) $ requesting' $- fmapCheap (multiEntry . IntMap.singleton 0) $ fmap (runIdentity . traverseRequesterData (Identity . freq)) req- return a--instance (Reflex t, Monad m) => Requester t (RequesterT t request response m) where- type Request (RequesterT t request response m) = request- type Response (RequesterT t request response m) = response- requesting = fmap coerceEvent . responseFromTag . castMyTagWrap <=< tagRequest . (coerceEvent :: Event t (request a) -> Event t (Entry request (Single a)))- requesting_ = void . tagRequest . fmapCheap singleEntry--{-# INLINE tagRequest #-}-tagRequest :: forall m x t request response. (Monad m, MyTagTypeOffset x) => Event t (Entry request x) -> RequesterT t request response m (MyTagWrap request (Entry request x))-tagRequest req = do- old <- RequesterT get- let n = _requesterState_nextMyTag old .|. myTagTypeOffset (Proxy :: Proxy x)- t = MyTagWrap n- RequesterT $ put $ RequesterState- { _requesterState_nextMyTag = _requesterState_nextMyTag old - 0x4- , _requesterState_requests = (n, (unsafeCoerce :: Event t (Entry request x) -> Event t Any) req) : _requesterState_requests old- }- return t--{-# INLINE responseFromTag #-}-responseFromTag :: Monad m => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))-responseFromTag (MyTagWrap t) = do- responses :: EventSelectorInt t Any <- RequesterT ask- return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t--instance MonadTrans (RequesterT t request response) where- lift = RequesterT . lift . lift--instance MFunctor (RequesterT t request response) where- hoist f = RequesterT . hoist (hoist f) . unRequesterT--instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where- type Performable (RequesterT t request response m) = Performable m- performEvent_ = lift . performEvent_- performEvent = lift . performEvent--instance MonadRef m => MonadRef (RequesterT t request response m) where- type Ref (RequesterT t request response m) = Ref m- newRef = lift . newRef- readRef = lift . readRef- writeRef r = lift . writeRef r--instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where- newEventWithTrigger = lift . newEventWithTrigger- newFanEventWithTrigger f = lift $ newFanEventWithTrigger f--instance MonadReader r m => MonadReader r (RequesterT t request response m) where- ask = lift ask- local f (RequesterT a) = RequesterT $ mapStateT (mapReaderT $ local f) a- reader = lift . reader--instance (Reflex t, Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (RequesterT t request response m) where- runWithReplace = runWithReplaceRequesterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'- traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElementsMap mergeIntIncremental- {-# INLINABLE traverseDMapWithKeyWithAdjust #-}- traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental- traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove--requesting' :: (MyTagTypeOffset x, Monad m) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x))-requesting' = responseFromTag . castMyTagWrap <=< tagRequest--{-# INLINABLE runWithReplaceRequesterTWith #-}-runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m- , MonadFix m- )- => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))- -> RequesterT t request response m a- -> Event t (RequesterT t request response m b)- -> RequesterT t request response m (a, Event t b)-runWithReplaceRequesterTWith f a0 a' = do- rec na' <- numberOccurrencesFrom 1 a'- responses <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here- let responses' = fanInt responses- ((result0, requests0), v') <- f (runRequesterT a0 (selectInt responses' 0)) $ fmapCheap (\(n, a) -> fmap ((,) n) $ runRequesterT a $ selectInt responses' n) na'- requests <- holdDyn (fmapCheap (IntMap.singleton 0) requests0) $ fmapCheap (\(n, (_, reqs)) -> fmapCheap (IntMap.singleton n) reqs) v'- return (result0, fmapCheap (fst . snd) v')--{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}-traverseIntMapWithKeyWithAdjustRequesterTWith :: forall t request response m v v' p.- ( Reflex t- , MonadHold t m- , PatchTarget (p (Event t (IntMap (RequesterData request)))) ~ IntMap (Event t (IntMap (RequesterData request)))- , Patch (p (Event t (IntMap (RequesterData request))))- , Functor p- , MonadFix m- )- => ( (IntMap.Key -> (IntMap.Key, v) -> m (Event t (IntMap (RequesterData request)), v'))- -> IntMap (IntMap.Key, v)- -> Event t (p (IntMap.Key, v))- -> RequesterT t request response m (IntMap (Event t (IntMap (RequesterData request)), v'), Event t (p (Event t (IntMap (RequesterData request)), v')))- )- -> (p (Event t (IntMap (RequesterData request))) -> IntMap (Event t (IntMap (RequesterData request))))- -> (Incremental t (p (Event t (IntMap (RequesterData request)))) -> Event t (IntMap (IntMap (RequesterData request))))- -> (IntMap.Key -> v -> RequesterT t request response m v')- -> IntMap v- -> Event t (p v)- -> RequesterT t request response m (IntMap v', Event t (p v'))-traverseIntMapWithKeyWithAdjustRequesterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do- rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here- let responses :: EventSelectorInt t (IntMap (RequesterData response))- responses = fanInt $ fmapCheap unpack response- unpack :: Entry response Multi3 -> IntMap (IntMap (RequesterData response))- unpack = unEntry- pack :: IntMap (IntMap (RequesterData request)) -> Entry request Multi3- pack = Entry- f' :: IntMap.Key -> (Int, v) -> m (Event t (IntMap (RequesterData request)), v')- f' k (n, v) = do- (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ selectInt responses k --TODO: Instead of doing mapMaybeCheap, can we share a fanInt across all instances of a given key, or at least the ones that are adjacent in time?- return (fmapCheap (IntMap.singleton n) myRequests, result)- ndm' <- numberOccurrencesFrom 1 dm'- (children0, children') <- base f' (fmap ((,) 0) dm0) $ fmap (\(n, dm) -> fmap ((,) n) dm) ndm' --TODO: Avoid this somehow, probably by adding some sort of per-cohort information passing to Adjustable- let result0 = fmap snd children0- result' = fforCheap children' $ fmap snd- requests0 :: IntMap (Event t (IntMap (RequesterData request)))- requests0 = fmap fst children0- requests' :: Event t (p (Event t (IntMap (RequesterData request))))- requests' = fforCheap children' $ fmap fst- promptRequests :: Event t (IntMap (IntMap (RequesterData request)))- promptRequests = coincidence $ fmapCheap (mergeInt . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'- requests <- holdIncremental requests0 requests'- return (result0, result')--{-# INLINE traverseDMapWithKeyWithAdjustRequesterTWith #-}-traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v' p p'.- ( GCompare k- , Reflex t- , MonadHold t m- , PatchTarget (p' (Some k) (Event t (IntMap (RequesterData request)))) ~ Map (Some k) (Event t (IntMap (RequesterData request)))- , Patch (p' (Some k) (Event t (IntMap (RequesterData request))))- , MonadFix m- )- => (forall k' v1 v2. GCompare k'- => (forall a. k' a -> v1 a -> m (v2 a))- -> DMap k' v1- -> Event t (p k' v1)- -> RequesterT t request response m (DMap k' v2, Event t (p k' v2))- )- -> (forall v1 v2. (forall a. v1 a -> v2 a) -> p k v1 -> p k v2)- -> (forall v1 v2. (forall a. v1 a -> v2) -> p k v1 -> p' (Some k) v2)- -> (forall v2. p' (Some k) v2 -> Map (Some k) v2)- -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a))- -> (forall a. k a -> v a -> RequesterT t request response m (v' a))- -> DMap k v- -> Event t (p k v)- -> RequesterT t request response m (DMap k v', Event t (p k v'))-traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do- rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here- let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))- responses = fanMap $ fmapCheap unpack response- unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))- unpack = unEntry- pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)- pack = Entry- f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)- f' k (Compose (n, v)) = do- (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some k))- return $ Compose (fmapCheap (IntMap.singleton n) myRequests, result)- ndm' <- numberOccurrencesFrom 1 dm'- (children0, children') <- base f' (DMap.map (\v -> Compose (0, v)) dm0) $ fmap (\(n, dm) -> mapPatch (\v -> Compose (n, v)) dm) ndm'- let result0 = DMap.map (snd . getCompose) children0- result' = fforCheap children' $ mapPatch $ snd . getCompose- requests0 :: Map (Some k) (Event t (IntMap (RequesterData request)))- requests0 = weakenDMapWith (fst . getCompose) children0- requests' :: Event t (p' (Some k) (Event t (IntMap (RequesterData request))))- requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose- promptRequests :: Event t (Map (Some k) (IntMap (RequesterData request)))- promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'- requests <- holdIncremental requests0 requests'- return (result0, result')--data Decoder rawResponse response =- forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)---- | Matches incoming responses with previously-sent requests--- and uses the provided request "decoder" function to process--- incoming responses.-matchResponsesWithRequests- :: forall t rawRequest rawResponse request response m.- ( MonadFix m- , MonadHold t m- , Reflex t- )- => (forall a. request a -> (rawRequest, rawResponse -> response a))- -- ^ Given a request (from 'Requester'), produces the wire format of the- -- request and a function used to process the associated response- -> Event t (RequesterData request)- -- ^ The outgoing requests- -> Event t (Int, rawResponse)- -- ^ The incoming responses, tagged by an identifying key- -> m ( Event t (Map Int rawRequest)- , Event t (RequesterData response)- )- -- ^ A map of outgoing wire-format requests and an event of responses keyed- -- by the 'RequesterData' key of the associated outgoing request-matchResponsesWithRequests f send recv = do- rec nextId <- hold 1 $ fmap (\(next, _, _) -> next) outgoing- waitingFor :: Incremental t (PatchMap Int (Decoder rawResponse response)) <-- holdIncremental mempty $ leftmost- [ fmap (\(_, outstanding, _) -> outstanding) outgoing- , snd <$> incoming- ]- let outgoing = processOutgoing nextId send- incoming = processIncoming waitingFor recv- return (fmap (\(_, _, rawReqs) -> rawReqs) outgoing, fst <$> incoming)- where- -- Tags each outgoing request with an identifying integer key- -- and returns the next available key, a map of response decoders- -- for requests for which there are outstanding responses, and the- -- raw requests to be sent out.- processOutgoing- :: Behavior t Int- -- The next available key- -> Event t (RequesterData request)- -- The outgoing request- -> Event t ( Int- , PatchMap Int (Decoder rawResponse response)- , Map Int rawRequest )- -- The new next-available-key, a map of requests expecting responses, and the tagged raw requests- processOutgoing nextId out = flip pushAlways out $ \dm -> do- oldNextId <- sample nextId- let (result, newNextId) = flip runState oldNextId $ forM (requesterDataToList dm) $ \(k :=> v) -> do- n <- get- put $ succ n- let (rawReq, rspF) = f v- return (n, rawReq, Decoder k rspF)- patchWaitingFor = PatchMap $ Map.fromList $- (\(n, _, dec) -> (n, Just dec)) <$> result- toSend = Map.fromList $ (\(n, rawReq, _) -> (n, rawReq)) <$> result- return (newNextId, patchWaitingFor, toSend)- -- Looks up the each incoming raw response in a map of response- -- decoders and returns the decoded response and a patch that can- -- be used to clear the ID of the consumed response out of the queue- -- of expected responses.- processIncoming- :: Incremental t (PatchMap Int (Decoder rawResponse response))- -- A map of outstanding expected responses- -> Event t (Int, rawResponse)- -- A incoming response paired with its identifying key- -> Event t (RequesterData response, PatchMap Int v)- -- The decoded response and a patch that clears the outstanding responses queue- processIncoming waitingFor inc = flip push inc $ \(n, rawRsp) -> do- wf <- sample $ currentIncremental waitingFor- case Map.lookup n wf of- Nothing -> return Nothing -- TODO How should lookup failures be handled here? They shouldn't ever happen..- Just (Decoder k rspF) -> do- let rsp = rspF rawRsp- return $ Just- ( singletonRequesterData k rsp- , PatchMap $ Map.singleton n Nothing- )+import Reflex.Requester.Base.Internal
+ src/Reflex/Requester/Base/Internal.hs view
@@ -0,0 +1,596 @@+-- | This module provides 'RequesterT', the standard implementation of+-- 'Requester'.+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Reflex.Requester.Base.Internal where++import Control.Monad+import Control.Monad.Catch (MonadMask, MonadThrow, MonadCatch)+import Control.Monad.Exception+import Control.Monad.Fix+import Control.Monad.Identity+import Control.Monad.Morph+import Control.Monad.Primitive+import Control.Monad.Reader+import Control.Monad.Ref+import Control.Monad.State.Strict+import Data.Bits+import Data.Coerce+import Data.Constraint+import Data.Dependent.Map (DMap)+import qualified Data.Dependent.Map as DMap+import Data.Dependent.Sum (DSum (..))+import Data.Functor.Compose+import Data.Functor.Misc+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IntMap+import Data.Kind (Type)+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Proxy+import Data.Some (Some(Some))+import Data.Type.Equality+import Data.Unique.Tag++import GHC.Exts (Any)+import Unsafe.Coerce++#if !MIN_VERSION_base(4,18,0)+import Control.Applicative (liftA2)+import Data.Monoid ((<>))+#endif++import Reflex.Class+import Reflex.Adjustable.Class+import Reflex.Dynamic+import Reflex.EventWriter.Class+import Reflex.Host.Class+import Reflex.PerformEvent.Class+import Reflex.PostBuild.Class+import Reflex.Requester.Class+import Reflex.TriggerEvent.Class++--TODO: Make this module type-safe++newtype TagMap (f :: Type -> Type) = TagMap (IntMap Any)++newtype RequesterData f = RequesterData (TagMap (Entry f))++emptyRequesterData :: RequesterData f+emptyRequesterData = RequesterData $ TagMap IntMap.empty++data RequesterDataKey a where+ RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a+ RequesterDataKey_Multi :: {-# UNPACK #-} !(MyTag Multi) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a --TODO: Don't put a second Int here (or in the other Multis); use a single Int instead+ RequesterDataKey_Multi2 :: GCompare k => {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a+ RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a++singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f+singletonRequesterData rdk v = case rdk of+ RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v+ RequesterDataKey_Multi k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v+ RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Multi2Contents+ { _multi2Contents_values = Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v+ , _multi2Contents_dict = Dict+ }+ RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v++mergeRequesterData :: RequesterData f -> RequesterData f -> RequesterData f+mergeRequesterData (RequesterData a) (RequesterData b) = RequesterData $ mergeTagMap a b++mergeTagMap :: forall f. TagMap (Entry f) -> TagMap (Entry f) -> TagMap (Entry f)+mergeTagMap (TagMap m) (TagMap n) =+ TagMap $ IntMap.unionWithKey (g' combiner) m n+ where+ combiner :: forall a. MyTag a -> Entry f a -> Entry f a -> Entry f a+ combiner k (Entry a) (Entry b) = Entry $ case myKeyType k of+ MyTagType_Single -> a+ MyTagType_Multi -> IntMap.unionWith mergeRequesterData a b+ MyTagType_Multi2 -> case _multi2Contents_dict a of+ Dict -> Multi2Contents+ { _multi2Contents_values = Map.unionWith (IntMap.unionWith mergeRequesterData) (_multi2Contents_values a) (_multi2Contents_values b)+ , _multi2Contents_dict = Dict+ }+ MyTagType_Multi3 -> IntMap.unionWith (IntMap.unionWith mergeRequesterData) a b+ g' :: (forall a. MyTag a -> Entry f a -> Entry f a -> Entry f a) -> Int -> Any -> Any -> Any+ g' f rawKey a b =+ let k = MyTag rawKey :: MyTag a+ fromAny :: Any -> Entry f a+ fromAny = unsafeCoerce+ toAny :: Entry f a -> Any+ toAny = unsafeCoerce+ in toAny $ f k (fromAny a) (fromAny b)++requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]+requesterDataToList (RequesterData m) = do+ k :=> Entry e <- tagMapToList m+ case myKeyType k of+ MyTagType_Single -> return $ RequesterDataKey_Single k :=> e+ MyTagType_Multi -> do+ (k', e') <- IntMap.toList e+ k'' :=> e'' <- requesterDataToList e'+ return $ RequesterDataKey_Multi k k' k'' :=> e''+ MyTagType_Multi2 -> case _multi2Contents_dict e of+ Dict -> do+ (k', e') <- Map.toList $ _multi2Contents_values e+ (k'', e'') <- IntMap.toList e'+ k''' :=> e''' <- requesterDataToList e''+ return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''+ MyTagType_Multi3 -> do+ (k', e') <- IntMap.toList e+ (k'', e'') <- IntMap.toList e'+ k''' :=> e''' <- requesterDataToList e''+ return $ RequesterDataKey_Multi3 k k' k'' k''' :=> e'''++singletonTagMap :: forall f a. MyTag a -> f a -> TagMap f+singletonTagMap (MyTag k) v = TagMap $ IntMap.singleton k $ (unsafeCoerce :: f a -> Any) v++tagMapToList :: forall f. TagMap f -> [DSum MyTag f]+tagMapToList (TagMap m) = f <$> IntMap.toList m+ where f :: (Int, Any) -> DSum MyTag f+ f (k, v) = MyTag k :=> (unsafeCoerce :: Any -> f a) v++traverseTagMapWithKey :: forall t f g. Applicative t => (forall a. MyTag a -> f a -> t (g a)) -> TagMap f -> t (TagMap g)+traverseTagMapWithKey f (TagMap m) = TagMap <$> IntMap.traverseWithKey g m+ where+ g :: Int -> Any -> t Any+ g k v = (unsafeCoerce :: g a -> Any) <$> f (MyTag k) ((unsafeCoerce :: Any -> f a) v)++-- | Runs in reverse to accommodate for the fact that we accumulate it in reverse+traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequesterData request -> m (RequesterData response)+traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWithKey go m --TODO: reverse this, since our tags are in reverse order+ where go :: forall x. MyTag x -> Entry request x -> m (Entry response x)+ go k (Entry request) = Entry <$> case myKeyType k of+ MyTagType_Single -> f request+ MyTagType_Multi -> traverse (traverseRequesterData f) request+ MyTagType_Multi2 -> case request of+ Multi2Contents { _multi2Contents_values = request', _multi2Contents_dict = Dict } -> do+ v <- traverse (traverse (traverseRequesterData f)) request'+ pure $ Multi2Contents+ { _multi2Contents_values = v+ , _multi2Contents_dict = Dict+ }+ MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request++-- | 'traverseRequesterData' with its arguments flipped+forRequesterData :: forall request response m. Applicative m => RequesterData request -> (forall a. request a -> m (response a)) -> m (RequesterData response)+forRequesterData r f = traverseRequesterData f r++data MyTagType :: Type -> Type where+ MyTagType_Single :: MyTagType (Single a)+ MyTagType_Multi :: MyTagType Multi+ MyTagType_Multi2 :: MyTagType (Multi2 k)+ MyTagType_Multi3 :: MyTagType Multi3++myKeyType :: MyTag x -> MyTagType x+myKeyType (MyTag k) = case k .&. 0x3 of+ 0x0 -> unsafeCoerce MyTagType_Single+ 0x1 -> unsafeCoerce MyTagType_Multi+ 0x2 -> unsafeCoerce MyTagType_Multi2+ 0x3 -> unsafeCoerce MyTagType_Multi3+ t -> error $ "Reflex.Requester.Base.myKeyType: no such key type" <> show t++data Single a+data Multi+data Multi2 (k :: Type -> Type)+data Multi3++class MyTagTypeOffset x where+ myTagTypeOffset :: proxy x -> Int++instance MyTagTypeOffset (Single a) where+ myTagTypeOffset _ = 0x0++instance MyTagTypeOffset Multi where+ myTagTypeOffset _ = 0x1++instance MyTagTypeOffset (Multi2 k) where+ myTagTypeOffset _ = 0x2++instance MyTagTypeOffset Multi3 where+ myTagTypeOffset _ = 0x3++type family EntryContents request a where+ EntryContents request (Single a) = request a+ EntryContents request Multi = IntMap (RequesterData request)+ EntryContents request (Multi2 k) = Multi2Contents k request+ EntryContents request Multi3 = IntMap (IntMap (RequesterData request))++data Multi2Contents k request = Multi2Contents+ { _multi2Contents_dict :: {-# UNPACK #-} !(Dict (GCompare k)) -- This is a Dict instead of an existential context because we only want to use it in certain circumstances+ , _multi2Contents_values :: {-# UNPACK #-} !(Map (Some k) (IntMap (RequesterData request)))+ }++newtype Entry request x = Entry { unEntry :: EntryContents request x }++{-# INLINE singleEntry #-}+singleEntry :: f a -> Entry f (Single a)+singleEntry = Entry++{-# INLINE multiEntry #-}+multiEntry :: IntMap (RequesterData f) -> Entry f Multi+multiEntry = Entry++{-# INLINE unMultiEntry #-}+unMultiEntry :: Entry f Multi -> IntMap (RequesterData f)+unMultiEntry = unEntry++-- | We use a hack here to pretend we have x ~ request a; we don't want to use a GADT, because GADTs (even with zero-size existential contexts) can't be newtypes+-- WARNING: This type should never be exposed. In particular, this is extremely unsound if a MyTag from one run of runRequesterT is ever compared against a MyTag from another+newtype MyTag x = MyTag Int deriving (Show, Eq, Ord, Enum)++newtype MyTagWrap (f :: Type -> Type) x = MyTagWrap Int deriving (Show, Eq, Ord, Enum)++{-# INLINE castMyTagWrap #-}+castMyTagWrap :: MyTagWrap f (Entry f x) -> MyTagWrap g (Entry g x)+castMyTagWrap = coerce++instance GEq MyTag where+ (MyTag a) `geq` (MyTag b) =+ if a == b+ then Just $ unsafeCoerce Refl+ else Nothing++instance GCompare MyTag where+ (MyTag a) `gcompare` (MyTag b) =+ case a `compare` b of+ LT -> GLT+ EQ -> unsafeCoerce GEQ+ GT -> GGT++instance GEq (MyTagWrap f) where+ (MyTagWrap a) `geq` (MyTagWrap b) =+ if a == b+ then Just $ unsafeCoerce Refl+ else Nothing++instance GCompare (MyTagWrap f) where+ (MyTagWrap a) `gcompare` (MyTagWrap b) =+ case a `compare` b of+ LT -> GLT+ EQ -> unsafeCoerce GEQ+ GT -> GGT++data RequesterState t (request :: Type -> Type) = RequesterState+ { _requesterState_nextMyTag :: {-# UNPACK #-} !Int -- Starts at -4 and goes down by 4 each time, to accommodate two 'type' bits at the bottom+ , _requesterState_requests :: ![(Int, Event t Any)]+ }++-- | A basic implementation of 'Requester'.+newtype RequesterT t request (response :: Type -> Type) m a = RequesterT { unRequesterT :: StateT (RequesterState t request) (ReaderT (EventSelectorInt t Any) m) a }+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException+ , MonadAsyncException+ , MonadCatch+ , MonadThrow+ , MonadMask+ )++deriving instance MonadSample t m => MonadSample t (RequesterT t request response m)+deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)+deriving instance PostBuild t m => PostBuild t (RequesterT t request response m)+deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)++instance EventWriter t w m => EventWriter t w (RequesterT t request response m) where+ tellEvent = lift . tellEvent++instance PrimMonad m => PrimMonad (RequesterT t request response m) where+ type PrimState (RequesterT t request response m) = PrimState m+ primitive = lift . primitive++-- TODO: Monoid and Semigroup can likely be derived once StateT has them.+instance (Monoid a, Monad m) => Monoid (RequesterT t request response m a) where+ mempty = pure mempty++instance (Semigroup a, Monad m) => Semigroup (RequesterT t request response m a) where+ (<>) = liftA2 (<>)+++-- | Run a 'RequesterT' action. The resulting 'Event' will fire whenever+-- requests are made, and responses should be provided in the input 'Event'.+-- The 'Tag' keys will be used to return the responses to the same place the+-- requests were issued.+runRequesterT :: (Reflex t, Monad m)+ => RequesterT t request response m a+ -> Event t (RequesterData response) --TODO: This DMap will be in reverse order, so we need to make sure the caller traverses it in reverse+ -> m (a, Event t (RequesterData request)) --TODO: we need to hide these 'MyTag's here, because they're unsafe to mix in the wild+runRequesterT (RequesterT a) responses = do+ (result, s) <- runReaderT (runStateT a $ RequesterState (-4) []) $ fanInt $+ coerceEvent responses+ return (result, fmapCheap (RequesterData . TagMap) $ mergeInt $ IntMap.fromDistinctAscList $ _requesterState_requests s)++-- | Map a function over the request and response of a 'RequesterT'+withRequesterT+ :: (Reflex t, MonadFix m)+ => (forall x. req x -> req' x) -- ^ The function to map over the request+ -> (forall x. rsp' x -> rsp x) -- ^ The function to map over the response+ -> RequesterT t req rsp m a -- ^ The internal 'RequesterT' whose input and output will be transformed+ -> RequesterT t req' rsp' m a -- ^ The resulting 'RequesterT'+withRequesterT freq frsp child = do+ rec let rsp = fmap (runIdentity . traverseRequesterData (Identity . frsp)) rsp'+ (a, req) <- lift $ runRequesterT child rsp+ rsp' <- fmap (flip selectInt 0 . fanInt . fmapCheap unMultiEntry) $ requesting' $+ fmapCheap (multiEntry . IntMap.singleton 0) $ fmap (runIdentity . traverseRequesterData (Identity . freq)) req+ return a++instance (Reflex t, Monad m) => Requester t (RequesterT t request response m) where+ type Request (RequesterT t request response m) = request+ type Response (RequesterT t request response m) = response+ requesting = fmap coerceEvent . responseFromTag . castMyTagWrap <=< tagRequest . (coerceEvent :: Event t (request a) -> Event t (Entry request (Single a)))+ requesting_ = void . tagRequest . fmapCheap singleEntry++{-# INLINE tagRequest #-}+tagRequest :: forall m x t request response. (Monad m, MyTagTypeOffset x) => Event t (Entry request x) -> RequesterT t request response m (MyTagWrap request (Entry request x))+tagRequest req = do+ old <- RequesterT get+ let n = _requesterState_nextMyTag old .|. myTagTypeOffset (Proxy :: Proxy x)+ t = MyTagWrap n+ RequesterT $ put $ RequesterState+ { _requesterState_nextMyTag = _requesterState_nextMyTag old - 0x4+ , _requesterState_requests = (n, (unsafeCoerce :: Event t (Entry request x) -> Event t Any) req) : _requesterState_requests old+ }+ return t++{-# INLINE responseFromTag #-}+responseFromTag :: forall m t request response x. Monad m => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))+responseFromTag (MyTagWrap t) = do+ responses :: EventSelectorInt t Any <- RequesterT ask+ return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t++instance MonadTrans (RequesterT t request response) where+ lift = RequesterT . lift . lift++instance MFunctor (RequesterT t request response) where+ hoist f = RequesterT . hoist (hoist f) . unRequesterT++instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where+ type Performable (RequesterT t request response m) = Performable m+ performEvent_ = lift . performEvent_+ performEvent = lift . performEvent++instance MonadRef m => MonadRef (RequesterT t request response m) where+ type Ref (RequesterT t request response m) = Ref m+ newRef = lift . newRef+ readRef = lift . readRef+ writeRef r = lift . writeRef r++instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where+ newEventWithTrigger = lift . newEventWithTrigger+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f++instance MonadReader r m => MonadReader r (RequesterT t request response m) where+ ask = lift ask+ local f (RequesterT a) = RequesterT $ mapStateT (mapReaderT $ local f) a+ reader = lift . reader++instance (Reflex t, Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (RequesterT t request response m) where+ runWithReplace = runWithReplaceRequesterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'+ traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElementsMap mergeIntIncremental+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}+ traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental+ traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove++requesting' :: (MyTagTypeOffset x, Monad m) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x))+requesting' = responseFromTag . castMyTagWrap <=< tagRequest++{-# INLINABLE runWithReplaceRequesterTWith #-}+runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m+ , MonadFix m+ )+ => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))+ -> RequesterT t request response m a+ -> Event t (RequesterT t request response m b)+ -> RequesterT t request response m (a, Event t b)+runWithReplaceRequesterTWith f a0 a' = do+ rec na' <- numberOccurrencesFrom 1 a'+ responses <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here+ let responses' = fanInt responses+ ((result0, requests0), v') <- f (runRequesterT a0 (selectInt responses' 0)) $ fmapCheap (\(n, a) -> fmap ((,) n) $ runRequesterT a $ selectInt responses' n) na'+ requests <- holdDyn (fmapCheap (IntMap.singleton 0) requests0) $ fmapCheap (\(n, (_, reqs)) -> fmapCheap (IntMap.singleton n) reqs) v'+ return (result0, fmapCheap (fst . snd) v')++{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}+traverseIntMapWithKeyWithAdjustRequesterTWith :: forall t request response m v v' p.+ ( Reflex t+ , MonadHold t m+ , PatchTarget (p (Event t (IntMap (RequesterData request)))) ~ IntMap (Event t (IntMap (RequesterData request)))+ , Patch (p (Event t (IntMap (RequesterData request))))+ , Functor p+ , MonadFix m+ )+ => ( (IntMap.Key -> (IntMap.Key, v) -> m (Event t (IntMap (RequesterData request)), v'))+ -> IntMap (IntMap.Key, v)+ -> Event t (p (IntMap.Key, v))+ -> RequesterT t request response m (IntMap (Event t (IntMap (RequesterData request)), v'), Event t (p (Event t (IntMap (RequesterData request)), v')))+ )+ -> (p (Event t (IntMap (RequesterData request))) -> IntMap (Event t (IntMap (RequesterData request))))+ -> (Incremental t (p (Event t (IntMap (RequesterData request)))) -> Event t (IntMap (IntMap (RequesterData request))))+ -> (IntMap.Key -> v -> RequesterT t request response m v')+ -> IntMap v+ -> Event t (p v)+ -> RequesterT t request response m (IntMap v', Event t (p v'))+traverseIntMapWithKeyWithAdjustRequesterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do+ rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here+ let responses :: EventSelectorInt t (IntMap (RequesterData response))+ responses = fanInt $ fmapCheap unpack response+ unpack :: Entry response Multi3 -> IntMap (IntMap (RequesterData response))+ unpack = unEntry+ pack :: IntMap (IntMap (RequesterData request)) -> Entry request Multi3+ pack = Entry+ f' :: IntMap.Key -> (Int, v) -> m (Event t (IntMap (RequesterData request)), v')+ f' k (n, v) = do+ (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ selectInt responses k --TODO: Instead of doing mapMaybeCheap, can we share a fanInt across all instances of a given key, or at least the ones that are adjacent in time?+ return (fmapCheap (IntMap.singleton n) myRequests, result)+ ndm' <- numberOccurrencesFrom 1 dm'+ (children0, children') <- base f' (fmap ((,) 0) dm0) $ fmap (\(n, dm) -> fmap ((,) n) dm) ndm' --TODO: Avoid this somehow, probably by adding some sort of per-cohort information passing to Adjustable+ let result0 = fmap snd children0+ result' = fforCheap children' $ fmap snd+ requests0 :: IntMap (Event t (IntMap (RequesterData request)))+ requests0 = fmap fst children0+ requests' :: Event t (p (Event t (IntMap (RequesterData request))))+ requests' = fforCheap children' $ fmap fst+ promptRequests :: Event t (IntMap (IntMap (RequesterData request)))+ promptRequests = coincidence $ fmapCheap (mergeInt . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'+ requests <- holdIncremental requests0 requests'+ return (result0, result')++{-# INLINE traverseDMapWithKeyWithAdjustRequesterTWith #-}+traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v' p p'.+ ( GCompare k+ , Reflex t+ , MonadHold t m+ , PatchTarget (p' (Some k) (Event t (IntMap (RequesterData request)))) ~ Map (Some k) (Event t (IntMap (RequesterData request)))+ , Patch (p' (Some k) (Event t (IntMap (RequesterData request))))+ , MonadFix m+ )+ => (forall k' v1 v2. GCompare k'+ => (forall a. k' a -> v1 a -> m (v2 a))+ -> DMap k' v1+ -> Event t (p k' v1)+ -> RequesterT t request response m (DMap k' v2, Event t (p k' v2))+ )+ -> (forall v1 v2. (forall a. v1 a -> v2 a) -> p k v1 -> p k v2)+ -> (forall v1 v2. (forall a. v1 a -> v2) -> p k v1 -> p' (Some k) v2)+ -> (forall v2. p' (Some k) v2 -> Map (Some k) v2)+ -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a))+ -> (forall a. k a -> v a -> RequesterT t request response m (v' a))+ -> DMap k v+ -> Event t (p k v)+ -> RequesterT t request response m (DMap k v', Event t (p k v'))+traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do+ rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here+ let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))+ responses = fanMap $ fmapCheap unpack response+ unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))+ unpack = _multi2Contents_values . unEntry+ pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)+ pack m = Entry $ Multi2Contents { _multi2Contents_values = m, _multi2Contents_dict = Dict }+ f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)+ f' k (Compose (n, v)) = do+ (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some k))+ return $ Compose (fmapCheap (IntMap.singleton n) myRequests, result)+ ndm' <- numberOccurrencesFrom 1 dm'+ (children0, children') <- base f' (DMap.map (\v -> Compose (0, v)) dm0) $ fmap (\(n, dm) -> mapPatch (\v -> Compose (n, v)) dm) ndm'+ let result0 = DMap.map (snd . getCompose) children0+ result' = fforCheap children' $ mapPatch $ snd . getCompose+ requests0 :: Map (Some k) (Event t (IntMap (RequesterData request)))+ requests0 = weakenDMapWith (fst . getCompose) children0+ requests' :: Event t (p' (Some k) (Event t (IntMap (RequesterData request))))+ requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose+ promptRequests :: Event t (Map (Some k) (IntMap (RequesterData request)))+ promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'+ requests <- holdIncremental requests0 requests'+ return (result0, result')++data Decoder rawResponse response =+ forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)++matchResponsesWithRequests+ :: forall t rawRequest rawResponse request response m.+ ( MonadFix m+ , MonadHold t m+ , Reflex t+ )+ => (forall a. request a -> (rawRequest, rawResponse -> response a))+ -- ^ Given a request (from 'Requester'), produces the wire format of the+ -- request and a function used to process the associated response+ -> Event t (RequesterData request)+ -- ^ The outgoing requests+ -> Event t (Int, rawResponse)+ -- ^ The incoming responses, tagged by an identifying key+ -> m ( Event t (Map Int rawRequest)+ , Event t (RequesterData response)+ )+ -- ^ A map of outgoing wire-format requests and an event of responses keyed+ -- by the 'RequesterData' key of the associated outgoing request+matchResponsesWithRequests f send recv = matchResponseMapWithRequests f send $ uncurry Map.singleton <$> recv++-- | Matches incoming responses with previously-sent requests+-- and uses the provided request "decoder" function to process+-- incoming responses.+matchResponseMapWithRequests+ :: forall t rawRequest rawResponse request response m.+ ( MonadFix m+ , MonadHold t m+ , Reflex t+ )+ => (forall a. request a -> (rawRequest, rawResponse -> response a))+ -- ^ Given a request (from 'Requester'), produces the wire format of the+ -- request and a function used to process the associated response+ -> Event t (RequesterData request)+ -- ^ The outgoing requests+ -> Event t (Map Int rawResponse)+ -- ^ A map of incoming responses, tagged by an identifying key+ -> m ( Event t (Map Int rawRequest)+ , Event t (RequesterData response)+ )+ -- ^ A map of outgoing wire-format requests and an event of responses keyed+ -- by the 'RequesterData' key of the associated outgoing request+matchResponseMapWithRequests f send recv = do+ rec nextId <- hold 1 $ fmap (\(next, _, _) -> next) outgoing+ waitingFor :: Incremental t (PatchMap Int (Decoder rawResponse response)) <-+ holdIncremental mempty $ leftmost+ [ fmap (\(_, outstanding, _) -> outstanding) outgoing+ , snd <$> incoming+ ]+ let outgoing = processOutgoing nextId send+ incoming = processIncoming waitingFor recv+ return (fmap (\(_, _, rawReqs) -> rawReqs) outgoing, fst <$> incoming)+ where+ -- Tags each outgoing request with an identifying integer key+ -- and returns the next available key, a map of response decoders+ -- for requests for which there are outstanding responses, and the+ -- raw requests to be sent out.+ processOutgoing+ :: Behavior t Int+ -- The next available key+ -> Event t (RequesterData request)+ -- The outgoing request+ -> Event t ( Int+ , PatchMap Int (Decoder rawResponse response)+ , Map Int rawRequest )+ -- The new next-available-key, a map of requests expecting responses, and the tagged raw requests+ processOutgoing nextId out = flip pushAlways out $ \dm -> do+ oldNextId <- sample nextId+ let (result, newNextId) = flip runState oldNextId $ forM (requesterDataToList dm) $ \(k :=> v) -> do+ n <- get+ put $ succ n+ let (rawReq, rspF) = f v+ return (n, rawReq, Decoder k rspF)+ patchWaitingFor = PatchMap $ Map.fromList $+ (\(n, _, dec) -> (n, Just dec)) <$> result+ toSend = Map.fromList $ (\(n, rawReq, _) -> (n, rawReq)) <$> result+ return (newNextId, patchWaitingFor, toSend)+ -- Looks up the each incoming raw response in a map of response+ -- decoders and returns the decoded response and a patch that can+ -- be used to clear the ID of the consumed response out of the queue+ -- of expected responses.+ processIncoming+ :: Incremental t (PatchMap Int (Decoder rawResponse response))+ -- A map of outstanding expected responses+ -> Event t (Map Int rawResponse)+ -- A incoming response paired with its identifying key+ -> Event t (RequesterData response, PatchMap Int v)+ -- The decoded response and a patch that clears the outstanding responses queue+ processIncoming waitingFor inc = flip push inc $ \rspMap -> do+ wf <- sample $ currentIncremental waitingFor+ let match rawRsp (Decoder k rspF) =+ let rsp = rspF rawRsp+ in singletonRequesterData k rsp+ matches = Map.intersectionWith match rspMap wf+ pure $ if Map.null matches then Nothing else Just+ (Map.foldl' mergeRequesterData emptyRequesterData matches, PatchMap $ Nothing <$ matches)
src/Reflex/Requester/Class.hs view
@@ -8,20 +8,21 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}-#ifdef USE_REFLEX_OPTIMIZER-{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}-#endif+ module Reflex.Requester.Class ( Requester (..) , withRequesting , requestingIdentity ) where +import Control.Monad.Fix import Control.Monad.Identity import Control.Monad.Reader import qualified Control.Monad.State.Lazy as Lazy import Control.Monad.State.Strict+import Data.Kind (Type) import Reflex.Class -- | A 'Requester' action can trigger requests of type @Request m a@ based on@@ -32,11 +33,13 @@ -- 'Reflex.PerformEvent.Class.performEvent'. class (Reflex t, Monad m) => Requester t m | m -> t where -- | The type of requests that this 'Requester' can emit- type Request m :: * -> *+ type Request m :: Type -> Type -- | The type of responses that this 'Requester' can receive- type Response m :: * -> *+ type Response m :: Type -> Type -- | Emit a request whenever the given 'Event' fires, and return responses in -- the resulting 'Event'.+ --+ -- Semantically, the response event occurs at a later time than the request event. requesting :: Event t (Request m a) -> m (Event t (Response m a)) -- | Emit a request whenever the given 'Event' fires, and ignore all responses. requesting_ :: Event t (Request m a) -> m ()
src/Reflex/Spider.hs view
@@ -1,20 +1,21 @@ {-# LANGUAGE CPP #-}+ -- | -- Module: -- Reflex.Spider -- Description: -- This module exports all of the user-facing functionality of the 'Spider' 'Reflex' engine module Reflex.Spider- ( Spider- , SpiderTimeline- , Global- , SpiderHost- , runSpiderHost- , runSpiderHostForTimeline- , newSpiderTimeline- , withSpiderTimeline- -- * Deprecated- , SpiderEnv- ) where+ ( Spider+ , SpiderTimeline+ , Global+ , SpiderHost+ , runSpiderHost+ , runSpiderHostForTimeline+ , newSpiderTimeline+ , withSpiderTimeline+ -- * Deprecated+ , SpiderEnv+ ) where import Reflex.Spider.Internal
src/Reflex/Spider/Internal.hs view
@@ -20,36 +20,32 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiWayIf #-}--#ifdef USE_REFLEX_OPTIMIZER-{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}-#endif {-# OPTIONS_GHC -Wunused-binds #-}+ -- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses -- a graph traversal algorithm to propagate 'Event's and 'Behavior's.-module Reflex.Spider.Internal (module Reflex.Spider.Internal) where+module Reflex.Spider.Internal+ ( module Reflex.Spider.Internal+ ) where -#if MIN_VERSION_base(4,10,0)-import Control.Applicative (liftA2)-#endif import Control.Concurrent import Control.Exception import Control.Monad hiding (forM, forM_, mapM, mapM_)+import Control.Monad.Catch (MonadMask, MonadThrow, MonadCatch) import Control.Monad.Exception-import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)+import Control.Monad.Fix import Control.Monad.Primitive import Control.Monad.Reader.Class import Control.Monad.IO.Class import Control.Monad.ReaderIO import Control.Monad.Ref-import Control.Monad.Fail (MonadFail) import qualified Control.Monad.Fail as MonadFail import Data.Align import Data.Coerce import Data.Dependent.Map (DMap) import qualified Data.Dependent.Map as DMap import Data.Dependent.Sum (DSum (..))-import Data.FastMutableIntMap (FastMutableIntMap, PatchIntMap (..))+import Data.FastMutableIntMap (FastMutableIntMap) import qualified Data.FastMutableIntMap as FastMutableIntMap import Data.Foldable hiding (concat, elem, sequence_) import Data.Functor.Constant@@ -61,12 +57,10 @@ import Data.IORef import Data.Kind (Type) import Data.Maybe hiding (mapMaybe)-import Data.Monoid (mempty, (<>)) import Data.Proxy import Data.These import Data.Traversable import Data.Type.Equality ((:~:)(Refl))-import Data.Witherable (Filterable, mapMaybe) import GHC.Exts hiding (toList) import GHC.IORef (IORef (..)) import GHC.Stack@@ -74,7 +68,18 @@ import System.IO.Unsafe import System.Mem.Weak import Unsafe.Coerce+import Witherable (Filterable, mapMaybe) +#if !MIN_VERSION_base(4,18,0)+import Control.Applicative (liftA2)+import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)+import Control.Monad.Fail (MonadFail)+import Data.List (isPrefixOf)+import Data.Monoid (mempty, (<>))+#else+import Control.Monad.Identity+#endif+ #ifdef MIN_VERSION_semialign #if MIN_VERSION_these(0,8,0) import Data.These.Combinators (justThese)@@ -91,7 +96,10 @@ import Data.List.NonEmpty (NonEmpty (..), nonEmpty) import qualified Data.List.NonEmpty as NonEmpty import Data.Tree (Forest, Tree (..), drawForest)++#ifdef DEBUG_HIDE_INTERNALS import Data.List (isPrefixOf)+#endif import Data.FastWeakBag (FastWeakBag, FastWeakBagTicket) import qualified Data.FastWeakBag as FastWeakBag@@ -251,7 +259,7 @@ -- caching; if the computation function is very cheap, this is (much) more -- efficient than 'push' {-# INLINE [1] pushCheap #-}-pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b+pushCheap :: (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b pushCheap !f e = Event $ \sub -> do (subscription, occ) <- subscribeAndRead e $ debugSubscriber' "push" $ sub { subscriberPropagate = \a -> do@@ -272,7 +280,7 @@ -- | Subscribe to an Event only for the duration of one occurrence {-# INLINE subscribeAndReadHead #-}-subscribeAndReadHead :: HasSpiderTimeline x => Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)+subscribeAndReadHead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a) subscribeAndReadHead e sub = do subscriptionRef <- liftIO $ newIORef $ error "subscribeAndReadHead: not initialized" (subscription, occ) <- subscribeAndRead e $ debugSubscriber' "head" $ sub@@ -286,7 +294,7 @@ return (subscription, occ) --TODO: Make this lazy in its input event-headE :: (MonadIO m, Defer (SomeMergeInit x) m, HasSpiderTimeline x) => Event x a -> m (Event x a)+headE :: Defer (SomeMergeInit x) m => Event x a -> m (Event x a) headE originalE = do parent <- liftIO $ newIORef $ Just originalE defer $ SomeMergeInit $ do --TODO: Rename SomeMergeInit appropriately@@ -307,12 +315,10 @@ #endif } -nowSpiderEventM :: (HasSpiderTimeline x) => EventM x (R.Event (SpiderTimeline x) ())-nowSpiderEventM =- SpiderEvent <$> now+nowSpiderEventM :: HasSpiderTimeline x => EventM x (R.Event (SpiderTimeline x) ())+nowSpiderEventM = SpiderEvent <$> now -now :: (MonadIO m, Defer (Some Clear) m, HasSpiderTimeline x- ) => m (Event x ())+now :: Defer (Some Clear) m => m (Event x ()) now = do nowOrNot <- liftIO $ newIORef $ Just () scheduleClear nowOrNot@@ -533,10 +539,12 @@ newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a) newSubscriberCoincidenceInner subscribed = debugSubscriber ("SubscriberCoincidenceInner" <> showNodeId subscribed) $ Subscriber { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do+#ifdef DEBUG occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed case occ of- Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event+ Just _ -> error "Coincidence inner is propagating, but coincidence occurrence is already known?" Nothing -> do+#endif liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a scheduleClear $ coincidenceSubscribedOccurrence subscribed propagate a $ coincidenceSubscribedSubscribers subscribed@@ -551,14 +559,14 @@ recalculateSubscriberHeight = flip subscriberRecalculateHeight -- | Propagate everything at the current height-propagate :: forall x a. HasSpiderTimeline x => a -> WeakBag (Subscriber x a) -> EventM x ()+propagate :: forall x a. a -> WeakBag (Subscriber x a) -> EventM x () propagate a subscribers = withIncreasedDepth (Proxy::Proxy x) $ -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work WeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a -- | Propagate everything at the current height-propagateFast :: forall x a. HasSpiderTimeline x => a -> FastWeakBag (Subscriber x a) -> EventM x ()+propagateFast :: forall x a. a -> FastWeakBag (Subscriber x a) -> EventM x () propagateFast a subscribers = withIncreasedDepth (Proxy::Proxy x) $ -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work@@ -701,7 +709,7 @@ case val of Just subscribed -> do askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedPull subscribed)) :))- askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))+ askInvalidator >>= mapM_ (liftIO . addInvalidatorAmortized (pullSubscribedInvalidators subscribed)) liftIO $ touch $ pullSubscribedOwnInvalidator subscribed return $ pullSubscribedValue subscribed Nothing -> do@@ -710,7 +718,8 @@ parentsRef <- liftIO $ newIORef [] holdInits <- askBehaviorHoldInits a <- liftIO $ runReaderIO (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)- invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator+ inv0 <- maybeToList <$> askInvalidator+ invsRef <- liftIO $ newIORef $ InvalidatorList (length inv0) invalidatorPruneThreshold inv0 parents <- liftIO $ readIORef parentsRef let subscribed = PullSubscribed { pullSubscribedValue = a@@ -729,11 +738,49 @@ readHoldTracked :: Hold x p -> BehaviorM x (PatchTarget p) readHoldTracked h = do result <- liftIO $ readIORef $ holdValue h- askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))+ askInvalidator >>= mapM_ (liftIO . addInvalidatorAmortized (holdInvalidators h)) askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedHold h)) :)) liftIO $ touch h -- Otherwise, if this gets inlined enough, the hold's parent reference may get collected return result +data InvalidatorList x = InvalidatorList+ { invalidatorListSize :: !Int+ , invalidatorListPruneAt :: !Int+ , invalidatorListElems :: ![Weak (Invalidator x)]+ }++emptyInvalidatorList :: InvalidatorList x+emptyInvalidatorList = InvalidatorList+ { invalidatorListSize = 0+ , invalidatorListPruneAt = invalidatorPruneThreshold+ , invalidatorListElems = []+ }++-- | Add invalidator weak ref to invalidator list, pruning finalized entries+-- once the list grows to its "prune at" size.+{-# INLINE addInvalidatorAmortized #-}+addInvalidatorAmortized :: IORef (InvalidatorList x) -> Weak (Invalidator x) -> IO ()+addInvalidatorAmortized ref weakInvalidator = do+ InvalidatorList listSize pruneAt weakInvalidators <- readIORef ref+ if listSize < pruneAt+ then writeIORef ref $! InvalidatorList (listSize + 1) pruneAt (weakInvalidator : weakInvalidators)+ else do+ (liveCount, liveInvalidators) <-+ foldrM+ (\weakInvalidator' (!liveCount, liveInvalidators) ->+ (\case Just _ -> (liveCount + 1, weakInvalidator' : liveInvalidators)+ Nothing -> (liveCount, liveInvalidators))+ <$> deRefWeak weakInvalidator')+ (0, [])+ weakInvalidators+ writeIORef ref $! InvalidatorList+ (liveCount + 1)+ (max invalidatorPruneThreshold (2 * liveCount))+ (weakInvalidator : liveInvalidators)++invalidatorPruneThreshold :: Int+invalidatorPruneThreshold = 100+ {-# INLINABLE readBehaviorUntracked #-} readBehaviorUntracked :: Defer (SomeHoldInit x) m => Behavior x a -> m a readBehaviorUntracked b = do@@ -787,7 +834,7 @@ --type role Hold representational data Hold x p = Hold { holdValue :: !(IORef (PatchTarget p))- , holdInvalidators :: !(IORef [Weak (Invalidator x)])+ , holdInvalidators :: !(IORef (InvalidatorList x)) , holdEvent :: Event x p -- This must be lazy, or holds cannot be defined before their input Events , holdParent :: !(IORef (Maybe (EventSubscription x))) -- Keeps its parent alive (will be undefined until the hold is initialized) --TODO: Probably shouldn't be an IORef #ifdef DEBUG_NODEIDS@@ -837,6 +884,7 @@ , eventEnvRootClears :: !(IORef [Some RootClear]) , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe+ , eventEnvInvalidatedCoincidences :: !(IORef [SomeCoincidenceSubscribed x]) -- Coincidences whose height was set to 'invalidHeight' this frame and must be recalculated; populated by 'invalidateCoincidenceHeight' , eventEnvDelayedMerges :: !(IORef (IntMap [EventM x ()])) } @@ -939,7 +987,7 @@ hold :: (Patch p, Defer (SomeHoldInit x) m) => PatchTarget p -> Event x p -> m (Hold x p) hold v0 e = do valRef <- liftIO $ newIORef v0- invsRef <- liftIO $ newIORef []+ invsRef <- liftIO $ newIORef emptyInvalidatorList parentRef <- liftIO $ newIORef Nothing #ifdef DEBUG_NODEIDS nodeId <- liftIO newNodeId@@ -990,10 +1038,6 @@ instance Monad (BehaviorM x) where {-# INLINE (>>=) #-} BehaviorM x >>= f = BehaviorM $ x >>= unBehaviorM . f- {-# INLINE (>>) #-}- BehaviorM x >> BehaviorM y = BehaviorM $ x >> y- {-# INLINE return #-}- return x = BehaviorM $ return x #if !MIN_VERSION_base(4,13,0) {-# INLINE fail #-} fail s = BehaviorM $ fail s@@ -1008,7 +1052,7 @@ --type role PullSubscribed representational data PullSubscribed x a = PullSubscribed { pullSubscribedValue :: !a- , pullSubscribedInvalidators :: !(IORef [Weak (Invalidator x)])+ , pullSubscribedInvalidators :: !(IORef (InvalidatorList x)) , pullSubscribedOwnInvalidator :: !(Invalidator x) , pullSubscribedParents :: ![SomeBehaviorSubscribed x] -- Need to keep parent behaviors alive, or they won't let us know when they're invalidated }@@ -1057,7 +1101,8 @@ newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () } -- EventM can do everything BehaviorM can, plus create holds-newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException)+newtype EventM x a = EventM { unEventM :: IO a }+ deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException, MonadCatch, MonadThrow, MonadMask) newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x } @@ -1093,7 +1138,7 @@ _ -> IntMap.insert h (pred old) c heightBagRemoveMaybe :: Height -> HeightBag -> Maybe HeightBag-heightBagRemoveMaybe (Height h) b@(HeightBag s c) = heightBagVerify . removed <$> IntMap.lookup h c where+heightBagRemoveMaybe (Height h) (HeightBag s c) = heightBagVerify . removed <$> IntMap.lookup h c where removed old = HeightBag (pred s) $ case old of 0 -> IntMap.delete h c _ -> IntMap.insert h (pred old) c@@ -1158,9 +1203,7 @@ , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed x a))) } -#ifdef USE_TEMPLATE_HASKELL {-# ANN CoincidenceSubscribed "HLint: ignore Redundant bracket" #-}-#endif data CoincidenceSubscribed x a = CoincidenceSubscribed { coincidenceSubscribedCachedSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a))) , coincidenceSubscribedOccurrence :: !(IORef (Maybe a))@@ -1336,7 +1379,7 @@ newtype RootClear k = RootClear (IORef (DMap k Identity)) -data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a+data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef (InvalidatorList x)) a debugFinalize :: Bool debugFinalize = False@@ -1349,8 +1392,6 @@ then Just $ debugStrLn $ "finalizing: " ++ debugNote else Nothing -type WeakList a = [Weak a]- type CanTrace x m = (HasSpiderTimeline x, MonadIO m) @@ -1470,7 +1511,7 @@ #ifdef DEBUG_HIDE_INTERNALS filterStack prefix = filter (not . (prefix `isPrefixOf`)) #else-filterStack prefix = id+filterStack _prefix = id #endif #ifdef DEBUG_CYCLES@@ -1499,8 +1540,8 @@ propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x () propagateSubscriberHold h a = do {-# SCC "trace" #-} when debugPropagate $ traceM (Proxy :: Proxy x) $ liftIO $ do- invalidators <- liftIO $ readIORef $ holdInvalidators h- return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)+ InvalidatorList n _ _ <- liftIO $ readIORef $ holdInvalidators h+ return $ "SubscriberHold" <> showNodeId h <> ": " ++ show n v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h case {-# SCC "apply" #-} apply a v of@@ -1512,7 +1553,9 @@ iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v' -data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset+-- | 'CoincidenceSubscribed' is present only when the coincidence raised its height while subscribing to the inner event.+data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a))+data SomeCoincidenceSubscribed x = forall a. SomeCoincidenceSubscribed !(CoincidenceSubscribed x a) runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a runBehaviorM a mwi holdInits = runReaderIO (unBehaviorM a) (mwi, holdInits)@@ -1609,9 +1652,7 @@ occ <- getOcc return (sln, subscribed, occ) -#ifdef USE_TEMPLATE_HASKELL {-# ANN cleanupRootSubscribed "HLint: ignore Redundant bracket" #-}-#endif cleanupRootSubscribed :: RootSubscribed x a -> IO () cleanupRootSubscribed self@RootSubscribed { rootSubscribedKey = k, rootSubscribedCachedSubscribed = cached } = do rootSubscribedUninit self@@ -2052,7 +2093,7 @@ --TODO: Assert that m is not empty subscriberPropagate (_merge_sub m) vals -checkCycle :: HasSpiderTimeline x => EventSubscribed x -> EventM x ()+checkCycle :: EventSubscribed x -> EventM x () checkCycle subscribed = liftIO $ do height <- readIORef (eventSubscribedHeightRef subscribed) @@ -2106,7 +2147,7 @@ {-# INLINE mergeGCheap' #-} mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q) => MergeGetSubscription x s -> MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> DynamicS x p -> Event x (DMap k v)-mergeGCheap' getParent getInitialSubscribers updateFunc destroy d = Event $ \sub -> do+mergeGCheap' _ getInitialSubscribers updateFunc destroy d = Event $ \sub -> do initialParents <- readBehaviorUntracked $ dynamicCurrent d accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized" heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"@@ -2256,8 +2297,6 @@ oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions liftIO $ for_ oldParents $ \oldParent -> do oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent-- print ("updateMe", oldParentHeight) modifyIORef' heightBagRef $ heightBagRemove oldParentHeight return $ IntMap.elems oldParents let changeSubscriber = Subscriber@@ -2273,7 +2312,7 @@ -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain -- its subscription. liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)- let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents+ let unsubscribeAll = traverse_ (unsubscribe . snd) =<< FastMutableIntMap.toList parents return (EventSubscription unsubscribeAll subscribed, occ)@@ -2322,11 +2361,12 @@ toClearIntRef <- newIORef [] toClearRootRef <- newIORef [] coincidenceInfosRef <- newIORef []+ invalidatedCoincidencesRef <- newIORef [] delayedRef <- newIORef IntMap.empty- return $ EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef+ return $ EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef invalidatedCoincidencesRef delayedRef clearEventEnv :: EventEnv x -> IO ()-clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef) = do+clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef invalidatedCoincidencesRef delayedRef) = do writeIORef toAssignRef [] writeIORef holdInitRef [] writeIORef dynInitRef []@@ -2337,6 +2377,7 @@ writeIORef toClearIntRef [] writeIORef toClearRootRef [] writeIORef coincidenceInfosRef []+ writeIORef invalidatedCoincidencesRef [] writeIORef delayedRef IntMap.empty -- | Run an event action outside of a frame@@ -2402,10 +2443,12 @@ writeIORef (switchSubscribedHeight subscribed) $! invalidHeight WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight mapM_ _someMergeUpdate_invalidateHeight mergeUpdates --TODO: In addition to when the patch is completely empty, we should also not run this if it has some Nothing values, but none of them have actually had any effect; potentially, we could even check for Just values with no effect (e.g. by comparing their IORefs and ignoring them if they are unchanged); actually, we could just check if the new height is different- forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do+ forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mInvalidate) -> do unsubscribe subscription- mapM_ invalidateCoincidenceHeight mcs- forM_ coincidenceInfos $ \(SomeResetCoincidence _ mcs) -> mapM_ recalculateCoincidenceHeight mcs+ mapM_ invalidateCoincidenceHeight mInvalidate+ invalidatedCoincidences <- readIORef $ eventEnvInvalidatedCoincidences env+ writeIORef (eventEnvInvalidatedCoincidences env) []+ forM_ invalidatedCoincidences $ \(SomeCoincidenceSubscribed subscribed) -> recalculateCoincidenceHeight subscribed mapM_ _someMergeUpdate_recalculateHeight mergeUpdates forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do height <- calculateSwitchHeight subscribed@@ -2436,11 +2479,13 @@ then invalidHeight else Height $ succ a -invalidateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()+invalidateCoincidenceHeight :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO () invalidateCoincidenceHeight subscribed = do oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed when (oldHeight /= invalidHeight) $ do writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight+ let env = _spiderTimeline_eventEnv (unSTE (spiderTimeline :: SpiderTimelineEnv x))+ modifyIORef' (eventEnvInvalidatedCoincidences env) (SomeCoincidenceSubscribed subscribed :) WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()@@ -2471,8 +2516,8 @@ data SomeSwitchSubscribed x = forall a. SomeSwitchSubscribed {-# NOUNPACK #-} (SwitchSubscribed x a) -invalidate :: IORef [SomeSwitchSubscribed x] -> WeakList (Invalidator x) -> IO (WeakList (Invalidator x))-invalidate toReconnectRef wis = do+invalidate :: IORef [SomeSwitchSubscribed x] -> InvalidatorList x -> IO (InvalidatorList x)+invalidate toReconnectRef (InvalidatorList _ _ wis) = do forM_ wis $ \wi -> do mi <- deRefWeak wi case mi of@@ -2491,7 +2536,7 @@ InvalidatorSwitch subscribed -> do traceInvalidate $ "invalidate: Switch" <> showNodeId subscribed modifyIORef' toReconnectRef (SomeSwitchSubscribed subscribed :)- return [] -- Since we always finalize everything, always return an empty list --TODO: There are some things that will need to be re-subscribed every time; we should try to avoid finalizing them+ return emptyInvalidatorList -- Since we always finalize everything, always return an empty list --TODO: There are some things that will need to be re-subscribed every time; we should try to avoid finalizing them -------------------------------------------------------------------------------- -- Reflex integration@@ -2548,12 +2593,8 @@ instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where- {-# INLINE return #-}- return = pure {-# INLINE (>>=) #-} x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x- {-# INLINE (>>) #-}- (>>) = (*>) #if !MIN_VERSION_base(4,13,0) {-# INLINE fail #-} fail _ = error "Dynamic does not support 'fail'"@@ -2579,9 +2620,7 @@ instance HasSpiderTimeline x => Applicative (Reflex.Class.Dynamic (SpiderTimeline x)) where pure = SpiderDynamic . dynamicConst-#if MIN_VERSION_base(4,10,0) liftA2 f a b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith f (unSpiderDynamic a) (unSpiderDynamic b)-#endif SpiderDynamic a <*> SpiderDynamic b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith ($) a b a *> b = R.unsafeBuildDynamic (R.sample $ R.current b) $ R.leftmost [R.updated b, R.tag (R.current b) $ R.updated a] (<*) = flip (*>) -- There are no effects, so order doesn't matter@@ -2611,8 +2650,8 @@ headE e = runFrame . runSpiderHostFrame $ Reflex.Class.headE e {-# INLINABLE now #-} now = runFrame . runSpiderHostFrame $ Reflex.Class.now- + instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can @@ -2775,7 +2814,7 @@ fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e)) {-# INLINABLE mergeG #-} mergeG- :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k+ :: forall k2 (k :: k2 -> Type) q (v :: k2 -> Type). GCompare k => (forall a. q a -> R.Event (SpiderTimeline x) (v a)) -> DMap k q -> R.Event (SpiderTimeline x) (DMap k v)@@ -2834,15 +2873,12 @@ atomicModifyRef r f = liftIO $ atomicModifyRef r f -- | The monad for actions that manipulate a Spider timeline identified by @x@-newtype SpiderHost (x :: Type) a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)+newtype SpiderHost (x :: Type) a = SpiderHost { unSpiderHost :: IO a }+ deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException) instance Monad (SpiderHost x) where {-# INLINABLE (>>=) #-} SpiderHost x >>= f = SpiderHost $ x >>= unSpiderHost . f- {-# INLINABLE (>>) #-}- SpiderHost x >> SpiderHost y = SpiderHost $ x >> y- {-# INLINABLE return #-}- return x = SpiderHost $ return x #if !MIN_VERSION_base(4,13,0) {-# INLINABLE fail #-} fail = MonadFail.fail@@ -2863,15 +2899,11 @@ runSpiderHostForTimeline (SpiderHost a) _ = a newtype SpiderHostFrame (x :: Type) a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }- deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)+ deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException, MonadMask, MonadThrow, MonadCatch) instance Monad (SpiderHostFrame x) where {-# INLINABLE (>>=) #-} SpiderHostFrame x >>= f = SpiderHostFrame $ x >>= runSpiderHostFrame . f- {-# INLINABLE (>>) #-}- SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y- {-# INLINABLE return #-}- return x = SpiderHostFrame $ return x #if !MIN_VERSION_base(4,13,0) {-# INLINABLE fail #-} fail s = SpiderHostFrame $ fail s
src/Reflex/Time.hs view
@@ -4,13 +4,11 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-}-#ifdef USE_TEMPLATE_HASKELL-{-# LANGUAGE TemplateHaskell #-}-#endif -- | -- Module: -- Reflex.Time@@ -18,30 +16,31 @@ -- Clocks, timers, and other time-related functions. module Reflex.Time where -import Reflex.Class-import Reflex.Dynamic-import Reflex.PerformEvent.Class-import Reflex.PostBuild.Class-import Reflex.TriggerEvent.Class- import Control.Concurrent import qualified Control.Concurrent.Thread.Delay as Concurrent-import Control.Lens hiding ((|>)) import Control.Monad import Control.Monad.Fix import Control.Monad.IO.Class import Data.Align import Data.Data (Data) import Data.Fixed-import Data.Semigroup (Semigroup(..)) import Data.Sequence (Seq, (|>)) import qualified Data.Sequence as Seq import Data.These import Data.Time.Clock-import Data.Typeable import GHC.Generics (Generic) import System.Random +#if !MIN_VERSION_base(4,18,0)+import Data.Semigroup (Semigroup(..))+#endif++import Reflex.Class+import Reflex.Dynamic+import Reflex.PerformEvent.Class+import Reflex.PostBuild.Class+import Reflex.TriggerEvent.Class+ -- | Metadata associated with a timer "tick" data TickInfo = TickInfo { _tickInfo_lastUTC :: UTCTime@@ -51,7 +50,7 @@ , _tickInfo_alreadyElapsed :: NominalDiffTime -- ^ Amount of time that has elapsed in the current tick period. }- deriving (Eq, Ord, Show, Typeable)+ deriving (Eq, Ord, Show) -- | Fires an 'Event' once every time provided interval elapses, approximately. -- The provided 'UTCTime' is used bootstrap the determination of how much time has elapsed with each tick.@@ -284,13 +283,13 @@ data ThrottleState b = ThrottleState_Immediate | ThrottleState_Buffered (ThrottleBuffer b)- deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic, Data, Typeable)+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic, Data) data ThrottleBuffer b = ThrottleBuffer_Empty -- Empty conflicts with lens, and hiding it would require turning -- on PatternSynonyms | ThrottleBuffer_Full b- deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic, Data, Typeable)+ deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic, Data) instance Semigroup b => Semigroup (ThrottleBuffer b) where x <> y = case x of@@ -367,18 +366,14 @@ delayed <- lag (void outE) return outE -#ifdef USE_TEMPLATE_HASKELL-makeLensesWith (lensRules & simpleLenses .~ True) ''TickInfo-#else-tickInfo_lastUTC :: Lens' TickInfo UTCTime+tickInfo_lastUTC :: Functor f => (UTCTime -> f UTCTime) -> TickInfo -> f TickInfo tickInfo_lastUTC f (TickInfo x1 x2 x3) = (\y -> TickInfo y x2 x3) <$> f x1 {-# INLINE tickInfo_lastUTC #-} -tickInfo_n :: Lens' TickInfo Integer+tickInfo_n :: Functor f => (Integer -> f Integer ) -> TickInfo -> f TickInfo tickInfo_n f (TickInfo x1 x2 x3) = (\y -> TickInfo x1 y x3) <$> f x2 {-# INLINE tickInfo_n #-} -tickInfo_alreadyElapsed :: Lens' TickInfo NominalDiffTime-tickInfo_alreadyElapsed f (TickInfo x1 x2 x3) = (\y -> TickInfo x1 x2 y) <$> f x3+tickInfo_alreadyElapsed :: Functor f => (NominalDiffTime -> f NominalDiffTime) -> TickInfo -> f TickInfo+tickInfo_alreadyElapsed f (TickInfo x1 x2 x3) = TickInfo x1 x2 <$> f x3 {-# INLINE tickInfo_alreadyElapsed #-}-#endif
src/Reflex/TriggerEvent/Base.hs view
@@ -1,10 +1,13 @@ -- | This module defines 'TriggerEventT', the standard implementation of -- 'TriggerEvent'.+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+ module Reflex.TriggerEvent.Base ( TriggerEventT (..) , runTriggerEventT@@ -13,17 +16,23 @@ , EventTriggerRef (..) ) where -import Control.Applicative (liftA2) import Control.Concurrent+import Control.Monad.Catch (MonadMask, MonadThrow, MonadCatch) import Control.Monad.Exception+import Control.Monad.Fix import Control.Monad.Primitive import Control.Monad.Reader import Control.Monad.Ref import Data.Coerce import Data.Dependent.Sum import Data.IORef-import Data.Monoid ((<>)) import qualified Data.Semigroup as S++#if !MIN_VERSION_base(4,18,0)+import Control.Applicative (liftA2)+import Data.Monoid ((<>))+#endif+ import Reflex.Class import Reflex.Adjustable.Class import Reflex.Host.Class@@ -40,7 +49,7 @@ -- | A basic implementation of 'TriggerEvent'. newtype TriggerEventT t m a = TriggerEventT { unTriggerEventT :: ReaderT (Chan [DSum (EventTriggerRef t) TriggerInvocation]) m a }- deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException, MonadCatch, MonadThrow, MonadMask) -- | Run a 'TriggerEventT' action. The argument should be a 'Chan' into which -- 'TriggerInvocation's can be passed; it is expected that some other thread
src/Reflex/TriggerEvent/Class.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE UndecidableInstances #-}+ module Reflex.TriggerEvent.Class ( TriggerEvent (..) ) where
src/Reflex/Widget/Basic.hs view
@@ -2,9 +2,6 @@ {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecursiveDo #-}-#ifdef USE_REFLEX_OPTIMIZER-{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}-#endif module Reflex.Widget.Basic where
src/Reflex/Workflow.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-}+ -- | -- Module: -- Reflex.Workflow@@ -7,8 +8,8 @@ -- Provides a convenient way to describe a series of interrelated widgets that -- can send data to, invoke, and replace one another. Useful for modeling user interface -- "workflows."-module Reflex.Workflow (- Workflow (..)+module Reflex.Workflow+ ( Workflow (..) , workflow , workflowView , mapWorkflow@@ -25,17 +26,18 @@ import Reflex.PostBuild.Class -- | A widget in a workflow+-- -- When the 'Event' returned by a 'Workflow' fires, the current 'Workflow' is replaced by the one inside the firing 'Event'. A series of 'Workflow's must share the same return type. newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) } -- | Runs a 'Workflow' and returns the 'Dynamic' result of the 'Workflow' (i.e., a 'Dynamic' of the value produced by the current 'Workflow' node, and whose update 'Event' fires whenever one 'Workflow' is replaced by another).-workflow :: forall t m a. (Reflex t, Adjustable t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a)+workflow :: forall t m a. (Adjustable t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a) workflow w0 = do rec eResult <- networkHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult return $ fmap fst eResult -- | Similar to 'workflow', but outputs an 'Event' that fires at post-build time and whenever the current 'Workflow' is replaced by the next 'Workflow'.-workflowView :: forall t m a. (Reflex t, NotReady t m, Adjustable t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a)+workflowView :: forall t m a. (NotReady t m, Adjustable t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a) workflowView w0 = do rec eResult <- networkView . fmap unWorkflow =<< holdDyn w0 eReplace eReplace <- fmap switch $ hold never $ fmap snd eResult
test/DebugCycles.hs view
@@ -29,7 +29,7 @@ import Test.Run import Test.Hspec import Reflex.Spider.Internal (EventLoopException)-import Data.Witherable (Filterable)+import Witherable (Filterable) #if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0)) import Data.These.Lens
test/QueryT.hs view
@@ -17,6 +17,7 @@ import qualified Data.Map as Map import Data.Map.Monoidal (MonoidalMap) import Data.Semigroup+import Data.Semigroup.Commutative import Data.These #if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))@@ -28,7 +29,7 @@ import Test.Run newtype MyQuery = MyQuery SelectedCount- deriving (Show, Read, Eq, Ord, Monoid, Semigroup, Additive, Group)+ deriving (Show, Read, Eq, Ord, Monoid, Semigroup, Commutative, Group) instance Query MyQuery where type QueryResult MyQuery = ()@@ -62,7 +63,7 @@ instance (Eq a, Ord k, Group a, Align (MonoidalMap k)) => Group (Selector k a) where negateG = fmap negateG -instance (Eq a, Ord k, Group a, Align (MonoidalMap k)) => Additive (Selector k a)+instance (Eq a, Ord k, Group a, Align (MonoidalMap k)) => Commutative (Selector k a) main :: IO () main = do
test/Reflex/Bench/Focused.hs view
@@ -8,6 +8,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE TypeApplications #-} module Reflex.Bench.Focused where @@ -376,6 +377,12 @@ counters = countMany =<< sparse ---+-- Stress-test sampling a single behavior through a large, shared set of pulls,+-- exercising the invalidator-list pruning path.+sharedInvalidators :: Word -> [(String, TestCase)]+sharedInvalidators width =+ [ testB "sumPulls" $ do+ b <- current <$> (count @_ @_ @Int =<< events 10)+ let ps = [ (+ fromIntegral i) <$> b | i <- [1 .. width] ]+ return $ pull $ sum <$> traverse sample ps+ ]
test/Reflex/Plan/Reflex.hs view
@@ -34,6 +34,7 @@ import Control.Applicative import Control.Monad+import Control.Monad.Fix import Control.Monad.Identity import Control.Monad.State.Strict
test/Reflex/Test/CrossImpl.hs view
@@ -24,6 +24,8 @@ import qualified Reflex.Profiled as Prof import Control.Arrow (second, (&&&))+import Control.Monad+import Control.Monad.Fix import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_) import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_) import Data.Dependent.Sum (DSum (..))
test/Reflex/Test/Micro.hs view
@@ -20,7 +20,9 @@ import Data.Foldable import Data.Functor.Misc import qualified Data.Map as Map+import qualified Data.IntMap as IntMap import Data.Monoid+import Reflex.Patch.MapWithMove (moveMapKey, insertMapKey, deleteMapKey) import Prelude @@ -214,6 +216,41 @@ e <- events1 return $ coincidence (deep e <$ e) + , testE "coincidence-incremental-height" $ do+ tick <- ticks+ e2 <- mergeMapIncremental+ <$> holdIncremental mempty ((mempty :: PatchMap Int (Event t ())) <$ tick)+ pure (leftmost [ void $ coincidence (e2 <$ leftmost [tick, tick])+ , tick])++ , testE "coincidence-int-incremental-height" $ do+ tick <- ticks+ h <- mergeIntIncremental+ <$> holdIncremental+ (IntMap.singleton 1 (void tick))+ (PatchIntMap (IntMap.singleton 1 (Just (void tick))) <$ tick)+ pure (leftmost [ void $ coincidence (void h <$ leftmost [tick, tick])+ , tick])++ , testE "coincidence-switch-reconnect-height" $ do+ tick <- ticks+ flag <- foldDyn (\_ b -> not b) False tick+ let hi = leftmost [tick, tick]+ pure (leftmost [void (coincidence (switch (current $ (\b -> if b then hi else tick) <$> flag) <$ hi)), tick])++ , testE "mergeWithMove-height" $ do+ tick <- ticks+ let lo = tick+ hi = leftmost [tick, tick]+ patches <- plan+ [ (1, insertMapKey 1 hi)+ , (2, deleteMapKey 0)+ , (3, insertMapKey 0 lo)+ , (4, moveMapKey 1 2)+ , (5, deleteMapKey 2) ]+ mergeMapIncrementalWithMove+ <$> holdIncremental (Map.singleton (0 :: Int) lo) patches+ , testB "holdWhileFiring" $ do e <- events1 eo <- headE e@@ -336,6 +373,11 @@ events1 = plan [(1, "a"), (2, "b"), (5, "c"), (7, "d"), (8, "e")] events2 = plan [(1, "e"), (3, "d"), (4, "c"), (6, "b"), (7, "a")] events3 = liftA2 mappend events1 events2++ -- Unit-valued event occurrences on consecutive frames, for the height/teardown+ -- regression tests below (which need occurrences but not their values).+ ticks :: TestPlan t m => m (Event t ())+ ticks = plan [(1, ()), (2, ()), (3, ()), (4, ()), (5, ()), (6, ())] eithers :: TestPlan t m => m (Event t (Either String String)) eithers = plan [(1, Left "e"), (3, Left "d"), (4, Right "c"), (6, Right "b"), (7, Left "a")]
test/RequesterT.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -44,6 +45,17 @@ data RequestInt a where RequestInt :: Int -> RequestInt Int +data TestRequest a where+ TestRequest_Reverse :: String -> TestRequest String+ TestRequest_Increment :: Int -> TestRequest Int++deriveArgDict ''TestRequest++instance Show (TestRequest a) where+ show = \case+ TestRequest_Reverse str -> "reverse " <> str+ TestRequest_Increment i -> "increment " <> show i+ main :: IO () main = do os1 <- runApp' (unwrapApp testOrdering) $@@ -196,10 +208,6 @@ (_, pulse') <- runWithReplace (pure ()) $ pure (RequestInt 1) <$ pulse requestingIdentity pulse' -data TestRequest a where- TestRequest_Reverse :: String -> TestRequest String- TestRequest_Increment :: Int -> TestRequest Int- testMatchRequestsWithResponses :: forall m t req a . ( MonadFix m@@ -226,10 +234,3 @@ ( whichever @Show @req @a $ show r , \x -> has @Read r $ readMaybe x )--deriveArgDict ''TestRequest--instance Show (TestRequest a) where- show = \case- TestRequest_Reverse str -> "reverse " <> str- TestRequest_Increment i -> "increment " <> show i
+ test/behaviorLeak.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++-- | Test whether Applicative combination of Behaviors leaks memory when one of+-- the Behaviors' source events never occurs.+-- (https://github.com/reflex-frp/reflex/issues/490)++import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Primitive (touch)+import Control.Monad.Ref+import Data.Dependent.Sum+import Data.Functor.Identity+import Data.Maybe (fromJust)+import GHC.Stats+import Reflex+import Reflex.Host.Class+import System.Exit+import System.Mem (performMajorGC)+import Text.Printf++warmupTicks :: Int+warmupTicks = 200000+windowTicks :: Int+windowTicks = 200000+samplesPerWindow :: Int+samplesPerWindow = 20+ticksBetweenWindows :: Int+ticksBetweenWindows = 9 * windowTicks+allowedGrowthBytes :: Integer+allowedGrowthBytes = 512 * 1024++testCase :: (Reflex t, MonadHold t m) => Event t b -> m (Behavior t (Int, Int))+testCase tickE = do+ a <- hold (0 :: Int) (0 <$ tickE)+ c <- hold (0 :: Int) never+ pure $ (,) <$> a <*> c++main :: IO ()+main = do+ enabled <- getRTSStatsEnabled+ unless enabled $ do+ putStrLn "Failed: RTS stats not enabled (run with +RTS -T)"+ exitFailure++ runSpiderHost $ do+ (tickE, tickTriggerRef) <- newEventWithTriggerRef+ b <- runHostFrame $ testCase tickE+ trigger <- fromJust <$> readRef tickTriggerRef+ let fireOnce = void $ fireEventsAndRead [trigger :=> Identity ()] $ do+ v <- sample b+ v `seq` pure ()+ liveBytes = liftIO $ do+ performMajorGC+ fromIntegral . gcdetails_live_bytes . gc <$> getRTSStats :: IO Integer+ measureWindow = do+ let chunk = windowTicks `div` samplesPerWindow+ samples <- replicateM samplesPerWindow $ do+ replicateM_ chunk fireOnce+ liveBytes+ pure $ sum samples `div` fromIntegral samplesPerWindow++ replicateM_ warmupTicks fireOnce+ firstWindowAvg <- measureWindow+ replicateM_ ticksBetweenWindows fireOnce+ secondWindowAvg <- measureWindow+ liftIO $ touch b+ liftIO $ do+ let growth = secondWindowAvg - firstWindowAvg+ if growth <= allowedGrowthBytes+ then putStrLn "Succeeded"+ else do+ printf "Failed: Behavior Applicative space leak\n"+ printf " first-window avg live bytes: %d\n" firstWindowAvg+ printf " second-window avg live bytes: %d\n" secondWindowAvg+ printf " growth over %d intervening ticks: %d bytes (allowed %d)\n"+ ticksBetweenWindows growth allowedGrowthBytes+ exitFailure
test/hlint.hs view
@@ -21,7 +21,7 @@ , "--ignore=Use ." , "--ignore=Use unless" , "--ignore=Reduce duplication"- , "--cpp-define=USE_TEMPLATE_HASKELL"+ , "--ignore=Replace case with maybe" , "--cpp-define=DEBUG" , "--ignore=Use tuple-section" ]