git.iko.soy/reflex
on bb39b6e help sign in
90891e1
swap
0 ahead, 637 behind
82 files changed+2922−4704
since splitsnapshots
unifiedsplit
.github/workflows/haskell.yml−41 .travis.yml+16 CONTRIBUTING.md−66 ChangeLog.md−151 Quickref.md+10−39 README.md+11−15 bench-cbits/checkCapability.c+12−11 bench/Main.hs+6−7 bench/RunAll.hs+1−1 cabal.haskell-ci−23 cabal.project−1 default.nix+38 dep/reflex-platform/default.nix−7 dep/reflex-platform/github.json−7 reflex.cabal+56−261 release.nix−58 src/Control/Monad/ReaderIO.hs−60 src/Data/AppendMap.hs+382−58 src/Data/FastMutableIntMap.hs+4−25 src/Data/FastWeakBag.hs+11−15 src/Data/Functor/Misc.hs+287 src/Data/Map/Misc.hs+10−26 src/Data/WeakBag.hs+9−13 src/Reflex.hs−4 src/Reflex/Adjustable/Class.hs+15−84 src/Reflex/BehaviorWriter/Base.hs−211 src/Reflex/BehaviorWriter/Class.hs−31 src/Reflex/Class.hs+203−718 src/Reflex/Collection.hs+53−158 src/Reflex/Dynamic.hs+207−66 src/Reflex/Dynamic/TH.hs+28−4 src/Reflex/DynamicWriter/Base.hs+8−40 src/Reflex/DynamicWriter/Class.hs+6−10 src/Reflex/EventWriter/Base.hs+63−99 src/Reflex/EventWriter/Class.hs+1 src/Reflex/FastWeak.hs+5−69 src/Reflex/FunctorMaybe.hs+18−32 src/Reflex/Host/Class.hs+1 src/Reflex/Host/Headless.hs−128 src/Reflex/Network.hs+7−14 src/Reflex/NotReady/Class.hs+1−10 src/Reflex/Optimizer.hs+4−13 src/Reflex/Patch.hs+39 src/Reflex/Patch/Class.hs+22 src/Reflex/Patch/DMap.hs+68 src/Reflex/Patch/DMapWithMove.hs+367 src/Reflex/Patch/IntMap.hs+49 src/Reflex/Patch/Map.hs+64 src/Reflex/Patch/MapWithMove.hs+156 src/Reflex/PerformEvent/Base.hs+4−7 src/Reflex/PerformEvent/Class.hs+2−6 src/Reflex/PostBuild/Base.hs+1−3 src/Reflex/PostBuild/Class.hs+2 src/Reflex/Profiled.hs+19−89 src/Reflex/Pure.hs+27−38 src/Reflex/Query/Base.hs+49−108 src/Reflex/Query/Class.hs+9−91 src/Reflex/Requester/Base.hs+19−198 src/Reflex/Requester/Class.hs+1 src/Reflex/Spider.hs+2−5 src/Reflex/Spider/Internal.hs+469−774 src/Reflex/Time.hs+15−115 src/Reflex/TriggerEvent/Base.hs−3 src/Reflex/TriggerEvent/Class.hs+1−6 src/Reflex/Widget/Basic.hs+1−3 src/Reflex/Workflow.hs+1−14 test/Adjustable.hs−62 test/DebugCycles.hs−171 test/EventWriterT.hs+3−92 test/GC.hs+5−6 test/Headless.hs−10 test/QueryT.hs+8−19 test/Reflex/Bench/Focused.hs+1−13 test/Reflex/Plan/Pure.hs+4−5 test/Reflex/Plan/Reflex.hs+2−2 test/Reflex/Test/CrossImpl.hs+12−24 test/Reflex/Test/Micro.hs+4−71 test/Reflex/TestPlan.hs+2−2 test/RequesterT.hs+11−179 test/Test/Run.hs−8 test/hlint.hs+8−4 test/semantics.hs+2
.github/workflows/haskell.ymldeleted−41
@@ -1,41 +0,0 @@
1−name: github-action
2−
3−on: [push, pull_request]
4−
5−jobs:
6− build:
7− strategy:
8− matrix:
9− ghc: ['8.4.4', '8.6.5', '8.8.4', '8.10.2']
10− os: ['ubuntu-latest', 'macos-latest']
11− runs-on: ${{ matrix.os }}
12−
13− name: GHC ${{ matrix.ghc }} on ${{ matrix.os }}
14− steps:
15− - uses: actions/checkout@v2
16− - uses: actions/setup-haskell@v1
17− with:
18− ghc-version: ${{ matrix.ghc }}
19− - name: Cache
20− uses: actions/cache@v1
21− env:
22− cache-name: cache-cabal
23− with:
24− path: ~/.cabal
25− key: ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }}
26− restore-keys: |
27− ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-
28− ${{ runner.os }}-${{ matrix.ghc }}-build-
29− ${{ runner.os }}-${{ matrix.ghc }}-
30− ${{ runner.os }}
31−
32− - name: Install dependencies
33− run: |
34− cabal update
35− cabal build --only-dependencies --enable-tests --enable-benchmarks
36− - name: Build
37− run: cabal build --enable-tests --enable-benchmarks all
38− - name: Run tests
39− run: cabal test all
40− - name: Build Docs
41− run: cabal haddock
.travis.ymlnew file+16
@@ -0,0 +1,16 @@
1+# Cache Buster: 0
2+language: nix
3+cache:
4+ directories:
5+ - /nix
6+matrix:
7+ include:
8+ - env: COMPILER=ghc7103
9+ - env: COMPILER=ghc821
10+ - env: COMPILER=ghc802
11+ - env: COMPILER=ghcjs
12+script:
13+ - set -e
14+ - nix-build -E "with (import <nixpkgs> {}); pkgs.haskell.packages.$COMPILER.callPackage ./default.nix { }"
15+ - nix-collect-garbage -d # This is important to do right before 'script' ends so the cache gets GCed
16+
CONTRIBUTING.mddeleted−66
@@ -1,66 +0,0 @@
1−# Contribution Guide
2−
3−Contributions and issue reports are encouraged and appreciated!
4−
5−- [Opening Issues](#opening-issues)
6−- [Submitting Changes](#submitting-changes)
7− - [Guidelines for Commit Messages](#guidelines-for-commit-messages)
8− - [Guidelines for Pull Requests](#guidelines-for-pull-requests)
9− - [Code Quality](#code-quality)
10− - [Documentation](#documentation)
11−
12−## Opening Issues
13−
14−Before opening an issue, please check whether your issue has already been reported. Assuming it has not:
15−
16−* Describe the issue you're encountering or the suggestion you're making
17−* Include any relevant steps to reproduce or code samples you can. It's always easier for us to debug if we have something that demonstrates the error.
18−* Let us know what version of reflex you were using. If you're using a github checkout, provide the git hash.
19−* Describe how you're building reflex (i.e., via reflex-platform, cabal install, stack, obelisk, etc.). If you're using reflex-platform or obelisk, provide the git hash of your checkout.
20−
21−## Submitting Changes
22−
23−### Guidelines for Commit Messages
24−
25−#### Summary Line
26−The summary line of your commit message should summarize the changes being made. Commit messages should be written in the imperative mood and should describe what happens when the commit is applied.
27−
28−One way to think about it is that your commit message should be able to complete the sentence:
29−"When applied, this commit will..."
30−
31−#### Body
32−For breaking changes, new features, refactors, or other major changes, the body of the commit message should describe the motivation behind the change in greater detail and may include references to the issue tracker. The body shouldn't repeat code/comments from the diff.
33−
34−### Guidelines for Pull Requests
35−
36−Wherever possible, pull requests should add a single feature or fix a single bug. Pull requests should not bundle several unrelated changes.
37−
38−### Code Quality
39−
40−#### Warnings
41−
42−Your pull request should add no new warnings to the project. It should also generally not disable any warnings.
43−
44−#### Build and Test
45−
46−Make sure the project builds and that the tests pass! This will generally also be checked by CI before merge, but trying it yourself first means you'll catch problems earlier and your contribution can be merged that much sooner!
47−
48−#### Dependencies
49−
50−Include version bounds whenever adding a dependency to the library stanza of the cabal file. Note that libraries added to reflex.cabal also need to be added to default.nix.
51−
52−### Documentation
53−
54−#### In the code
55−We're always striving to improve documentation. Please include [haddock](https://haskell-haddock.readthedocs.io/en/latest/index.html) documentation for any added code, and update the documentation for any code you modify.
56−
57−#### In the [Changelog](ChangeLog.md)
58−Add an entry to the changelog when your PR:
59−* Adds a feature
60−* Deprecates something
61−* Includes a breaking change
62−* Makes any other change that will impact users
63−
64−#### In the [Readme](README.md)
65−The readme is the first place a lot of people look for information about the repository. Update any parts of the readme that are affected by your PR.
66−
ChangeLog.mddeleted−151
@@ -1,151 +0,0 @@
1−# Revision history for reflex
2−
3−## 0.8.2.0
4−
5−* Add `matchResponseMapWithRequests`, which it similar to `matchResponsesWithRequests` but allows processing of multiple responses at once.
6−
7−## 0.8.1.1
8−
9−* Allow newer hlint for older GHCs, and add upper bound for newer GHCs
10−
11−## 0.8.1.0
12−
13−* Add support for GHC 8.10
14−* Drop support for GHC < 8.4
15−
16−## 0.8.0.0
17−
18−* Replace 0.7.2.0 with 0.8.0.0 to reflect the `MonadHold` interface change. Deprecates 0.7.2.0.
19−
20−## 0.7.2.0 -- *Deprecated*
21−
22−* ([#416](https://github.com/reflex-frp/reflex/pull/416)) Add `now :: m (Event t ())` to `MonadHold`.
23−* Extend some dependency version bounds
24−* Fix HLint 3 test
25−
26−## 0.7.1.1
27−
28−*Backport release*.
29−Changes do not carry forward to 0.7.2.0.
30−
31−* Add support for GHC 8.10
32−* Drop support for GHC < 8.4
33−* Extend some dependency version bounds
34−* Fix HLint 3 test
35−
36−## 0.7.1.0
37−
38−* ([#413](https://github.com/reflex-frp/reflex/pull/413), [#417](https://github.com/reflex-frp/reflex/pull/417)) Add `Reflex.Host.Headless` module which provides `runHeadlessApp` as an easy way to run a Reflex network in a "headless" environment.
39−* ([#420](https://github.com/reflex-frp/reflex/pull/420)) Add a [`Data.Zip.Unzip`](https://hackage.haskell.org/package/semialign-1.1/docs/Data-Zip.html#t:Unzip) instance for `Event`.
40−* ([#419](https://github.com/reflex-frp/reflex/pull/419)) Add `distributeIntMapOverDynPure` and `joinDynThroughIntMap` as convenience functions for working with `Dynamic` `IntMap`s.
41−
42−
43−## 0.7.0.0
44−
45−* Add lifting instances for most classes to `Reflex.Profiled.Profiled`. ([#398](https://github.com/reflex-frp/reflex/pull/398))
46−* Class `MonadQuery t q m` now has a `Monad m` superclass constraint. ([#400](https://github.com/reflex-frp/reflex/pull/400))
47−* **(Breaking change)** Rename class `MonadBehaviorWriter` -> `BehaviorWriter` for consistency with `EventWriter`/`DynamicWriter`. ([#401](https://github.com/reflex-frp/reflex/pull/401))
48−* Introduce deprecated alias `MonadBehaviorWriter = BehaviorWriter`. ([#401](https://github.com/reflex-frp/reflex/pull/401))
49−* Fix bug in spider where event subscriptions would be prematurely finalized due to over-aggressive inlining. ([#409](https://github.com/reflex-frp/reflex/pull/409))
50−* Add instances of `PerformEvent` and `TriggerEvent` for `MaybeT`. ([#395](https://github.com/reflex-frp/reflex/pull/395))
51−
52−## 0.6.4.1
53−
54−* Fix a bug in the Reflex Profiled transformer where
55− `Reflex.Class.mergeIncrementalG` and
56− `Reflex.Class.mergeIncrementalWithMoveG` implementations referenced
57− itself instead of the inner transformed timeline, causing an
58− infinite loop.
59−
60−## 0.6.4
61−
62−* Support GHC 8.8
63−
64−* Add `Reflex.Query.Base.mapQueryT`. See that module for documentation
65−
66−* The `Reflex.Patch.*` modules were moved to the `patch` library.
67− They are `Data.Patch.*` there, but reexported under their old names for backwards compatability here.
68−
69−* Additional instances for `Query` classes for basic types.
70−
71−* Add cabal flags `debug-propagation` and `debug-event-cycles` to build in debugging
72− code for performance and for cyclic dependencies between events
73−
74−## 0.6.3
75−
76−* `Data.WeakBag.traverse` and `Data.FastWeakBag.traverse` have been deprecated.
77− They are replaced with `Data.WeakBag.traverse_` and `Data.FastWeakBag.traverse_`, respectively.
78−
79−* Fixes a bug in `Reflex.Patch.MapWithMove.patchThatSortsMapWith` that was producing invalid `PatchMapWithMove`.
80−
81−* Add missing `NotReady` instances:
82− - `instance NotReady (SpiderTimeline x) (SpiderHost x)`
83− - `instance HasSpiderTimeline x => NotReady (SpiderTimeline x) (PerformEventT (SpiderTimeline x) (SpiderHost x))`
84−
85−## 0.6.2.4
86−
87−* Update to monoidal-containers 0.6
88−
89−## 0.6.2.3
90−
91−* Add an upper-bound to witherable
92−
93−## 0.6.2.2
94−
95−* Support these >= 1. Add `split-these` flag to control whether to use new these/semialign combination or not.
96−
97−* Update version bounds to fix some CI failures
98−
99−* Add travis CI configuration
100−
101−## 0.6.2.1
102−
103−* Generalize `fan` to `fanG` to take a `DMap` with non-`Identity`
104− functor:
105− * `fan` to `fanG`
106− * `EventSelectorG` for `fanG` result selector.
107−
108−* Reduce the amount of unsafeCoerce in coercing newtypes under Event/Dynamic/Behavior.
109− * Add fused ReaderIO for the purpose of coercion (ReaderT's third argument has nominal role preventing automated coerce)
110− * Add incrementalCoercion/coerceIncremental to go with dynamicCoercion/coerceDynamic
111−
112−* Generalize merging functions:
113− `merge` to `mergeG`,
114− `mergeIncremental` to `mergeIncrementalG`,
115− `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`.
116−
117−* Generalize distribute function:
118− `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`,
119−
120−## 0.6.2.0
121−
122−* Fix `holdDyn` so that it is lazy in its event argument
123− These produce `DMap`s whose values needn't be `Identity`.
124−
125−* Stop using the now-deprecated `*Tag` classes (e.g., `ShowTag`).
126−
127−* Fix `holdDyn` so that it is lazy in its event argument.
128−
129−## 0.6.1.0
130−
131−* Re-export all of `Data.Map.Monoidal`
132−
133−* Fix `QueryT` and `RequesterT` tests
134−
135−## 0.6.0.0 -- 2019-03-20
136−
137−* Deprecate `FunctorMaybe` in favor of `Data.Witherable.Filterable`. We still export `fmapMaybe`, `ffilter`, etc., but they all rely on `Filterable` now.
138−
139−* Rename `MonadDynamicWriter` to `DynamicWriter` and add a deprecation for the old name.
140−
141−* Remove many deprecated functions.
142−
143−* Add a `Num` instance for `Dynamic`.
144−
145−* Add `matchRequestsWithResponses` to make it easier to use `Requester` with protocols that don't do this matching for you.
146−
147−* Add `withRequesterT` to map functions over the request and response of a `RequesterT`.
148−
149−* Suppress nil patches in `QueryT` as an optimization. The `Query` type must now have an `Eq` instance.
150−
151−* Add `throttleBatchWithLag` to `Reflex.Time`. See that module for details.
Quickref.md+10−39
@@ -54,19 +54,18 @@ Since MonadHold depends on MonadSample, any [S] function also runs in [H] contex
5454[ ] difference :: Event a -> Event b -> Event a
5555[ ] align :: Event a -> Event b -> Event (These a b)
5656[ ] alignWith :: (These a b -> c) -> Event a -> Event b -> Event c
57− -- Note align functions from Data.Align in semialign package
5857[ ] mergeWith :: (a -> a -> a) -> [Event a] -> Event a
5958[ ] leftmost :: [Event a] -> Event a
6059[ ] mergeList :: [Event a] -> Event (NonEmpty a)
61−[ ] merge :: GCompare k => DMap k Event -> Event (DMap k Identity)
60+[ ] merge :: GCompare k => DMap (WrapArg Event k) -> Event (DMap k)
6261[ ] mergeMap :: Ord k => Map k (Event a) -> Event (Map k a)
6362
6463-- Efficient one-to-many fanout
65−[ ] fanMap :: Ord k => Event (Map k a) -> EventSelector (Const2 k a)
66−[ ] fan :: GCompare k => Event (DMap k Identity) -> EventSelector k
67−[ ] select :: EventSelector k -> k a -> Event a
68−[ ] fanEither :: Event (Either a b) -> (Event a, Event b)
69−[ ] fanThese :: Event (These a b) -> (Event a, Event b)
64+[ ] fanMap :: Ord k => Event (Map k a) -> EventSelector (Const2 k a)
65+[ ] fan :: GCompare k => Event (DMap k) -> EventSelector k
66+[ ] select :: EventSelector k -> k a -> Event a
67+[ ] fanEither :: Event (Either a b) -> (Event a, Event b)
68+[ ] fanThese :: Event (These a b) -> (Event a, Event b)
7069
7170-- Event to Event via function that can sample current values
7271[ ] push :: (a -> m (Maybe b)) -> Event a -> Event b
@@ -99,10 +98,6 @@ Since MonadHold depends on MonadSample, any [S] function also runs in [H] contex
9998[ ] <> :: Monoid a => Behavior a -> Behavior a -> Behavior a
10099-- ... plus many more due to typeclass membership
101100
102−-- Combine multiple behaviors via applicative instance
103−[ ] ffor2 :: Behavior a -> Behavior b -> (a -> b -> c) -> Behavior c
104−[ ] ffor3 :: Behavior a -> Behavior b -> Behavior c -> (a -> b -> c -> d) -> Behavior d
105−
106101-- Behavior to Behavior by sampling current values
107102[S] sample :: Behavior a -> m a
108103[ ] pull :: m a -> Behavior a
@@ -140,10 +135,6 @@ Since MonadHold depends on MonadSample, any [S] function also runs in [H] contex
140135[ ] >>= :: Dynamic a -> (a -> Dynamic b) -> Dynamic b
141136[ ] zipDynWith :: (a -> b -> c) -> Dynamic a -> Dynamic b -> Dynamic c
142137
143−-- Combine multiple dynamics via applicative instance
144−[ ] ffor2 :: Dynamic a -> Dynamic b -> (a -> b -> c) -> Dynamic c
145−[ ] ffor3 :: Dynamic a -> Dynamic b -> Dynamic c -> (a -> b -> c -> d) -> Dynamic d
146−
147138-- Efficient one-to-many fanout
148139[ ] demux :: Ord k => Dynamic k -> Demux k
149140[ ] demuxed :: Eq k => Demux k -> k -> Dynamic Bool
@@ -167,7 +158,7 @@ For Events, the returned Event fires whenever the latest Event supplied by the w
167158-- Flatten Behavior-of-Event to Event. Old Event is used during switchover.
168159[ ] switch :: Behavior (Event a) -> Event a
169160
170−-- Flatten Dynamic-of-Event to Event. New Event is used immediately.
161+-- Flatten Dyanmic-of-Event to Event. New Event is used immediately.
171162[ ] switchDyn :: Dynamic (Event a) -> Event a
172163
173164-- Flatten Event-of-Event to Event that fires when both wrapper AND new Event fire.
@@ -199,7 +190,7 @@ For Events, the returned Event fires whenever the latest Event supplied by the w
199190The functions mentioned above are used to create a static FRP network.
200191There are additional typeclasses that can be used to modify the FRP network, to have it interact with IO action, or to introspect the building of the network.
201192
202−The typeclasses and their associated annotations include:
193+Th typeclasses and their associated annotations include:
203194
204195- `PostBuild`
205196 Fire an Event when an FRP network has been set up.
@@ -207,7 +198,7 @@ The typeclasses and their associated annotations include:
207198 [B] -- Function runs in any monad supporting PostBuild
208199 ```
209200
210−- `Adjustable`
201+- `Adjustable`
211202 Use Events to add or remove pieces of an FRP network.
212203 ```haskell
213204 [A] -- Function runs in any monad supporting Adjustable
@@ -272,7 +263,7 @@ The typeclasses and their associated annotations include:
272263```haskell
273264-- Run side-effecting actions in Event when it occurs; returned Event contains
274265-- results. Side effects run in the (Performable m) monad which is associated with
275−-- the (PerformEvent t m) typeclass constraint.
266+-- the (PerformEvent t m) typeclass constraint.
276267-- This allows for working with IO when a ((MonadIO (Performable m)) constraint is available.
277268[P] performEvent :: Event (Performable m a ) -> m (Event a)
278269
@@ -293,23 +284,3 @@ The typeclasses and their associated annotations include:
293284[P,T] delay :: NominalDiffTime -> Event t a -> m (Event t a)
294285```
295286
296−## Networks
297−
298−```haskell
299−-- Functions from Reflex.Adjustable / Reflex.Network used to deal with Dynamics/Events carrying (m a)
300−
301−[A] runWithReplace :: m a -> Event t (m b) -> m (a, Event t b)
302−
303−-- Given a Dynamic of network-creating actions, create a network that is recreated whenever the Dynamic updates.
304−-- The returned Event of network results occurs when the Dynamic does. Note: Often, the type a is an Event,
305−-- in which case the return value is an Event-of-Events that would typically be flattened (via switchHold).
306−[P,A] networkView :: Dynamic (m a) -> m (Event a)
307−
308−-- Given an initial network and an Event of network-creating actions, create a network that is recreated whenever the
309−-- Event fires. The returned Dynamic of network results occurs when the Event does. Note: Often, the type a is an
310−-- Event, in which case the return value is a Dynamic-of-Events that would typically be flattened.
311−[H,A] networkHold :: m a -> Event (m a) -> m (Dynamic a)
312−
313−-- Render a placeholder network to be shown while another network is not yet done building
314−[P,A] untilReady :: m a -> m b -> m (a, Event b)
315−```
README.md+11−15
@@ -1,23 +1,19 @@
1−# [Reflex](https://reflex-frp.org/)
1+## Reflex
2+### Practical Functional Reactive Programming
23
3−[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/reflex.svg)](https://hackage.haskell.org/package/reflex) [![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/reflex/badge)](https://matrix.hackage.haskell.org/#/package/reflex) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](https://github.com/reflex-frp/reflex/blob/master/LICENSE)
4+Reflex is an fully-deterministic, higher-order Functional Reactive Programming (FRP) interface and an engine that efficiently implements that interface.
45
5−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.
6+[Reflex-DOM](https://github.com/reflex-frp/reflex-dom) is a framework built on Reflex that facilitates the development of web pages, including highly-interactive single-page apps.
67
7−Reflex is a fully-deterministic, higher-order Functional Reactive Programming interface and an engine that efficiently implements that interface.
8+Comprehensive documentation is still a work in progress, but a tutorial for Reflex and Reflex-DOM is available at https://github.com/reflex-frp/reflex-platform and an introductory talk given at the New York Haskell Meetup is available here: [Part 1](https://www.youtube.com/watch?v=mYvkcskJbc4) / [Part 2](https://www.youtube.com/watch?v=3qfc9XFVo2c).
89
9−**Visit https://reflex-frp.org for more information, tutorials, documentation and [examples](https://examples.reflex-frp.org/).**
10+A summary of Reflex functions is available in the [quick reference](Quickref.md).
1011
11−## Resources
12+### Additional resources
13+[Get started with Reflex](https://github.com/reflex-frp/reflex-platform)
1214
13−* [Official Website](https://reflex-frp.org)
14−* [Quick Reference](Quickref.md)
15−* [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.
16−* [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.
17−* [Get started with Reflex](https://github.com/reflex-frp/reflex-platform)
18−* [/r/reflexfrp](https://www.reddit.com/r/reflexfrp)
19−* [irc.freenode.net #reflex-frp](http://webchat.freenode.net?channels=%23reflex-frp&uio=d4)
15+[/r/reflexfrp](https://www.reddit.com/r/reflexfrp)
2016
21−## Hacking
17+[hackage](https://hackage.haskell.org/package/reflex)
2218
23−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.
19+[irc.freenode.net #reflex-frp](http://webchat.freenode.net?channels=%23reflex-frp&uio=d4)
bench-cbits/checkCapability.c+12−11
@@ -42,7 +42,7 @@ typedef struct Task_ {
4242 // or just continue immediately. It's a workaround for the fact
4343 // that signalling a condition variable doesn't do anything if the
4444 // thread is already running, but we want it to be sticky.
45− HsBool wakeup;
45+ rtsBool wakeup;
4646#endif
4747
4848 // This points to the Capability that the Task "belongs" to. If
@@ -62,14 +62,14 @@ typedef struct Task_ {
6262 // The current top-of-stack InCall
6363 struct InCall_ *incall;
6464
65− uint32_t n_spare_incalls;
65+ nat n_spare_incalls;
6666 struct InCall_ *spare_incalls;
6767
68− HsBool worker; // == rtsTrue if this is a worker Task
69− HsBool stopped; // this task has stopped or exited Haskell
68+ rtsBool worker; // == rtsTrue if this is a worker Task
69+ rtsBool stopped; // this task has stopped or exited Haskell
7070
7171 // So that we can detect when a finalizer illegally calls back into Haskell
72− HsBool running_finalizers;
72+ rtsBool running_finalizers;
7373
7474 // Links tasks on the returning_tasks queue of a Capability, and
7575 // on spare_workers.
@@ -88,7 +88,7 @@ struct Capability_ {
8888 StgFunTable f;
8989 StgRegTable r;
9090
91− uint32_t no; // capability number.
91+ nat no; // capability number.
9292
9393 // The Task currently holding this Capability. This task has
9494 // exclusive access to the contents of this Capability (apart from
@@ -98,12 +98,12 @@ struct Capability_ {
9898
9999 // true if this Capability is running Haskell code, used for
100100 // catching unsafe call-ins.
101− HsBool in_haskell;
101+ rtsBool in_haskell;
102102
103103 // Has there been any activity on this Capability since the last GC?
104− uint32_t idle;
104+ nat idle;
105105
106− HsBool disabled;
106+ rtsBool disabled;
107107
108108 // The run queue. The Task owning this Capability has exclusive
109109 // access to its run queue, so can wake up threads without
@@ -159,7 +159,7 @@ struct Capability_ {
159159#if defined(THREADED_RTS)
160160 // Worker Tasks waiting in the wings. Singly-linked.
161161 Task *spare_workers;
162− uint32_t n_spare_workers; // count of above
162+ nat n_spare_workers; // count of above
163163
164164 // This lock protects:
165165 // running_task
@@ -192,9 +192,10 @@ struct Capability_ {
192192
193193 // Per-capability STM-related data
194194 StgTVarWatchQueue *free_tvar_watch_queues;
195+ StgInvariantCheckQueue *free_invariant_check_queues;
195196 StgTRecChunk *free_trec_chunks;
196197 StgTRecHeader *free_trec_headers;
197− uint32_t transaction_tokens;
198+ nat transaction_tokens;
198199} // typedef Capability is defined in RtsAPI.h
199200 // We never want a Capability to overlap a cache line with anything
200201 // else, so round it up to a cache line size:
bench/Main.hs+6−7
@@ -20,7 +20,6 @@ import qualified Data.Dependent.Map as DMap
2020import Data.Dependent.Sum
2121import Data.Functor.Misc
2222import Data.IORef
23−import Data.Maybe (fromJust)
2423import Reflex
2524import Reflex.Host.Class
2625
@@ -71,7 +70,7 @@ micros =
7170 , withSetupWHNF "fireEventsOnly"
7271 (newEventWithTriggerRef >>= subscribePair)
7372 (\(_, trigger) -> do
74− key <- fromJust <$> liftIO (readIORef trigger)
73+ Just key <- liftIO $ readIORef trigger
7574 fireEvents [key :=> Identity (42 :: Int)])
7675 , withSetupWHNF "fireEventsAndRead(head/merge1)"
7776 (setupMerge 1 >>= subscribePair)
@@ -85,14 +84,14 @@ micros =
8584 , withSetupWHNF "fireEventsOnly(head/merge100)"
8685 (setupMerge 100 >>= subscribePair)
8786 (\(_, t:_) -> do
88− key <- fromJust <$> liftIO (readIORef t)
87+ Just key <- liftIO $ readIORef t
8988 fireEvents [key :=> Identity (42 :: Int)])
9089 , withSetupWHNF "hold" newEventWithTriggerRef $ \(ev, _) -> hold (42 :: Int) ev
9190 , withSetupWHNF "sample" (newEventWithTriggerRef >>= hold (42 :: Int) . fst) sample
9291 ]
9392
9493setupMerge :: Int
95− -> SpiderHost Global ( Event (SpiderTimeline Global) (DMap (Const2 Int a) Identity)
94+ -> SpiderHost Global ( Event (SpiderEnv Global) (DMap (Const2 Int a) Identity)
9695 , [IORef (Maybe (EventTrigger Spider a))]
9796 )
9897setupMerge num = do
@@ -100,11 +99,11 @@ setupMerge num = do
10099 let !m = DMap.fromList [Const2 i :=> v | (i,v) <- zip [0..] evs]
101100 pure (merge m, triggers)
102101
103−subscribePair :: (Event (SpiderTimeline Global) a, b) -> SpiderHost Global (EventHandle (SpiderTimeline Global) a, b)
102+subscribePair :: (Event (SpiderEnv Global) a, b) -> SpiderHost Global (EventHandle (SpiderEnv Global) a, b)
104103subscribePair (ev, b) = (,b) <$> subscribeEvent ev
105104
106−fireAndRead :: IORef (Maybe (EventTrigger (SpiderTimeline Global) a)) -> a -> EventHandle (SpiderTimeline Global) b
105+fireAndRead :: IORef (Maybe (EventTrigger (SpiderEnv Global) a)) -> a -> EventHandle (SpiderEnv Global) b
107106 -> SpiderHost Global (Maybe b)
108107fireAndRead trigger val subd = do
109− key <- fromJust <$> liftIO (readIORef trigger)
108+ Just key <- liftIO $ readIORef trigger
110109 fireEventsAndRead [key :=> Identity val] $ readEvent subd >>= sequence
bench/RunAll.hs+1−1
@@ -136,7 +136,7 @@ benchmarks = implGroup "spider" runSpiderHost cases
136136pattern RunTestCaseFlag = "--run-test-case"
137137
138138spawnBenchmark :: String -> Benchmark
139−spawnBenchmark name = bench name . toBenchmarkable $ \n -> do
139+spawnBenchmark name = Benchmark name $ Benchmarkable $ \n -> do
140140 self <- getExecutablePath
141141 callProcess self [RunTestCaseFlag, name, show n, "+RTS", "-N1"]
142142
cabal.haskell-cideleted−23
@@ -1,23 +0,0 @@
1−distribution: xenial
2−benchmarks: False
3−unconstrained: False
4−installed: -all
5−
6−-- https://github.com/haskell/cabal/issues/6106
7−install-dependencies: False
8−
9−constraint-set no-th
10− constraints: reflex -use-template-haskell
11−
12−constraint-set old-these
13− ghc: <8.8
14− constraints: these <1
15−
16−constraint-set old-witherable
17− constraints: witherable <0.3.2
18−
19−constraint-set debug-propagation
20− constraints: reflex +debug-propagation
21−
22−constraint-set debug-cycles
23− constraints: reflex +debug-cycles
cabal.projectdeleted−1
@@ -1 +0,0 @@
1−packages: .
default.nixnew file+38
@@ -0,0 +1,38 @@
1+{ mkDerivation, ghc, base, bifunctors, containers, deepseq
2+, dependent-map, dependent-sum, exception-transformers
3+, haskell-src-exts, haskell-src-meta, hlint, lens, MemoTrie
4+, monad-control, mtl, primitive, random, ref-tf
5+, semigroupoids , semigroups, split, stdenv, stm, syb
6+, template-haskell , these, time, transformers
7+, transformers-compat, unbounded-delays, prim-uniq
8+, data-default , filepath, directory, filemanip, ghcjs-base
9+, useTemplateHaskell ? true
10+}:
11+mkDerivation {
12+ pname = "reflex";
13+ version = "0.5.0";
14+ src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.;
15+ libraryHaskellDepends = [
16+ base bifunctors containers dependent-map dependent-sum
17+ exception-transformers lens
18+ MemoTrie monad-control mtl primitive ref-tf semigroupoids
19+ semigroups stm syb template-haskell these transformers
20+ transformers-compat prim-uniq
21+ base bifunctors containers deepseq dependent-map dependent-sum
22+ mtl ref-tf split transformers data-default
23+ random time unbounded-delays
24+ ] ++ (if ghc.isGhcjs or false then [
25+ ghcjs-base
26+ ] else []) ++ (if !useTemplateHaskell then [] else [
27+ haskell-src-exts haskell-src-meta
28+ ]);
29+ testHaskellDepends = if ghc.isGhcjs or false then [] else [
30+ hlint filepath directory filemanip
31+ ];
32+ configureFlags = if useTemplateHaskell then [] else [
33+ "-f-use-template-haskell"
34+ ];
35+ homepage = "https://github.com/reflex-frp/reflex";
36+ description = "Higher-order Functional Reactive Programming";
37+ license = stdenv.lib.licenses.bsd3;
38+}
dep/reflex-platform/default.nixdeleted−7
@@ -1,7 +0,0 @@
1−# DO NOT HAND-EDIT THIS FILE
2−import ((import <nixpkgs> {}).fetchFromGitHub (
3− let json = builtins.fromJSON (builtins.readFile ./github.json);
4− in { inherit (json) owner repo rev sha256;
5− private = json.private or false;
6− }
7−))
dep/reflex-platform/github.jsondeleted−7
@@ -1,7 +0,0 @@
1−{
2− "owner": "reflex-frp",
3− "repo": "reflex-platform",
4− "branch": "develop",
5− "rev": "f628398d076243a0851b27e625b37f65dff9b89b",
6− "sha256": "0sl0hf1glgyb1vmf2mhw4r9ipmcqk1y19d3wsic7dix2jwywzrh9"
7−}
reflex.cabal+56−261
@@ -1,17 +1,7 @@
11Name: reflex
2−Version: 0.8.2.0
2+Version: 0.5
33Synopsis: Higher-order Functional Reactive Programming
4−Description:
5− Interactive programs without callbacks or side-effects.
6− Functional Reactive Programming (FRP) uses composable events and time-varying
7− values to describe interactive systems as pure functions.
8− Just like other pure functional code, functional reactive code is easier
9− to get right on the first try, maintain, and reuse.
10− .
11− Reflex is a fully-deterministic, higher-order Functional Reactive Programming
12− interface and an engine that efficiently implements that interface.
13− .
14− <https://reflex-frp.org>
4+Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system
155License: BSD3
166License-file: LICENSE
177Author: Ryan Trinkle
@@ -19,17 +9,9 @@ Maintainer: ryan.trinkle@gmail.com
199Stability: Experimental
2010Category: FRP
2111Build-type: Simple
22−Cabal-version: 1.22
23−homepage: https://reflex-frp.org
12+Cabal-version: >=1.9.2
13+homepage: https://github.com/reflex-frp/reflex
2414bug-reports: https://github.com/reflex-frp/reflex/issues
25−extra-source-files:
26− README.md
27− Quickref.md
28− ChangeLog.md
29−
30−tested-with:
31− GHC ==8.4.4 || ==8.6.5 || ==8.8.1 || ==8.10.2,
32− GHCJS ==8.6
3315
3416flag use-reflex-optimizer
3517 description: Use the GHC plugin Reflex.Optimizer on some of the modules in the package. This is still experimental.
@@ -51,74 +33,44 @@ flag fast-weak
5133 default: False
5234 manual: True
5335
54−flag debug-propagation
55− description: Enable debugging of spider internals
56− default: False
57− manual: True
58−
59−flag debug-cycles
60− description: Enable debugging of event cycles
61− default: False
62− manual: True
63−
64−flag split-these
65− description: Use split these/semialign packages
66− manual: False
67− default: True
68−
6936library
70− default-language: Haskell2010
7137 hs-source-dirs: src
7238 build-depends:
7339 MemoTrie == 0.6.*,
74− base >= 4.11 && < 4.15,
40+ base >= 4.7 && < 4.12,
7541 bifunctors >= 5.2 && < 5.6,
76− comonad >= 5.0.4 && < 5.1,
77− constraints >= 0.10 && <0.14,
78− constraints-extras >= 0.3 && < 0.4,
79− containers >= 0.6 && < 0.7,
42+ comonad,
43+ containers == 0.5.*,
8044 data-default >= 0.5 && < 0.8,
81− dependent-map >= 0.3 && < 0.5,
45+ dependent-map >= 0.2.4 && < 0.3,
8246 exception-transformers == 0.4.*,
8347 lens >= 4.7 && < 5,
84− mmorph >= 1.0 && < 1.2,
8548 monad-control >= 1.0.1 && < 1.1,
8649 mtl >= 2.1 && < 2.3,
87− patch >= 0.0.1 && < 0.1,
88− prim-uniq >= 0.1.0.1 && < 0.3,
89− primitive >= 0.5 && < 0.8,
90− profunctors >= 5.3 && < 5.7,
50+ prim-uniq >= 0.1.0.1 && < 0.2,
51+ primitive >= 0.5 && < 0.7,
9152 random == 1.1.*,
9253 ref-tf == 0.4.*,
9354 reflection == 2.1.*,
9455 semigroupoids >= 4.0 && < 6,
95− stm >= 2.4 && < 2.6,
56+ semigroups >= 0.16 && < 0.19,
57+ stm == 2.4.*,
9658 syb >= 0.5 && < 0.8,
97− time >= 1.4 && < 1.10,
98− transformers >= 0.5.6.0 && < 0.6,
99− unbounded-delays >= 0.1.0.0 && < 0.2,
100− witherable >= 0.3 && < 0.5
101−
102− if flag(split-these)
103− build-depends: these >= 1 && <1.2,
104− semialign >=1 && <1.2,
105− monoidal-containers >= 0.6 && < 0.7
106− else
107− build-depends: these >= 0.4 && <0.9,
108− monoidal-containers == 0.4.0.0
59+ these >= 0.4 && < 0.8,
60+ time >= 1.4 && < 1.9,
61+ transformers >= 0.2,
62+ transformers-compat >= 0.3,
63+ unbounded-delays >= 0.1.0.0 && < 0.2
10964
11065 exposed-modules:
111− Control.Monad.ReaderIO
11266 Data.AppendMap,
11367 Data.FastMutableIntMap,
11468 Data.FastWeakBag,
69+ Data.Functor.Misc,
11570 Data.Map.Misc,
11671 Data.WeakBag,
11772 Reflex,
11873 Reflex.Class,
119− Reflex.Adjustable.Class,
120− Reflex.BehaviorWriter.Base,
121− Reflex.BehaviorWriter.Class,
12274 Reflex.Collection,
12375 Reflex.Dynamic,
12476 Reflex.Dynamic.Uniq,
@@ -131,9 +83,15 @@ library
13183 Reflex.FastWeak,
13284 Reflex.FunctorMaybe,
13385 Reflex.Host.Class,
134− Reflex.Host.Headless,
13586 Reflex.Network,
13687 Reflex.NotReady.Class,
88+ Reflex.Patch,
89+ Reflex.Patch.Class,
90+ Reflex.Patch.DMap,
91+ Reflex.Patch.DMapWithMove,
92+ Reflex.Patch.IntMap,
93+ Reflex.Patch.Map,
94+ Reflex.Patch.MapWithMove,
13795 Reflex.PerformEvent.Base,
13896 Reflex.PerformEvent.Class,
13997 Reflex.PostBuild.Base,
@@ -152,57 +110,39 @@ library
152110 Reflex.Widget.Basic,
153111 Reflex.Workflow
154112
155− reexported-modules:
156− patch:Data.Functor.Misc,
157− patch:Data.Patch as Reflex.Patch,
158− patch:Data.Patch.Class as Reflex.Patch.Class,
159− patch:Data.Patch.DMap as Reflex.Patch.DMap,
160− patch:Data.Patch.DMapWithMove as Reflex.Patch.DMapWithMove,
161− patch:Data.Patch.IntMap as Reflex.Patch.IntMap,
162− patch:Data.Patch.Map as Reflex.Patch.Map,
163− patch:Data.Patch.MapWithMove as Reflex.Patch.MapWithMove
164−
165− ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively
113+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively -ddump-simpl -ddump-to-file -dsuppress-coercions -dsuppress-idinfo
114+ ghc-prof-options: -fprof-auto
166115
167116 if flag(debug-trace-events)
168117 cpp-options: -DDEBUG_TRACE_EVENTS
169− build-depends:
170− bytestring >= 0.10.8 && < 0.11
118+ build-depends: bytestring
171119
172120 if flag(use-reflex-optimizer)
173121 cpp-options: -DUSE_REFLEX_OPTIMIZER
174122 build-depends: ghc
175123 exposed-modules: Reflex.Optimizer
176124
177− if flag(debug-propagation)
178− cpp-options: -DDEBUG -DDEBUG_TRACE_PROPAGATION -DDEBUG_TRACE_INVALIDATION
179−
180− if flag(debug-cycles)
181− cpp-options: -DDEBUG_CYCLES
182−
183125 if flag(use-template-haskell)
184126 cpp-options: -DUSE_TEMPLATE_HASKELL
185127 build-depends:
186− dependent-sum >= 0.6 && < 0.8,
187− haskell-src-exts >= 1.16 && < 1.24,
128+ dependent-sum >= 0.3 && < 0.5,
129+ haskell-src-exts >= 1.16 && < 1.21,
188130 haskell-src-meta >= 0.6 && < 0.9,
189− template-haskell >= 2.9 && < 2.17
131+ template-haskell >= 2.9 && < 2.14
190132 exposed-modules:
191133 Reflex.Dynamic.TH
192134 other-extensions: TemplateHaskell
193135 else
194136 build-depends:
195− dependent-sum >= 0.6 && < 0.8
137+ dependent-sum == 0.4.*
196138
197139 if flag(fast-weak) && impl(ghcjs)
198− cpp-options: -DGHCJS_FAST_WEAK
140+ ghc-options: -DGHCJS_FAST_WEAK
199141
200142 if impl(ghcjs)
201− build-depends:
202− ghcjs-base == 0.2.*
143+ build-depends: ghcjs-base
203144
204145test-suite semantics
205− default-language: Haskell2010
206146 type: exitcode-stdio-1.0
207147 main-is: semantics.hs
208148 hs-source-dirs: test
@@ -211,46 +151,29 @@ test-suite semantics
211151 base,
212152 bifunctors,
213153 containers,
214− deepseq,
154+ deepseq >= 1.3 && < 1.5,
215155 dependent-map,
216156 dependent-sum,
217157 mtl,
218158 ref-tf,
219159 reflex,
220160 split,
221− transformers
222− other-modules:
223− Reflex.Bench.Focused
224− Reflex.Plan.Pure
225− Reflex.Plan.Reflex
226− Reflex.Test
227− Reflex.Test.Micro
228− Reflex.TestPlan
161+ transformers >= 0.3
229162
230163test-suite CrossImpl
231− default-language: Haskell2010
232164 type: exitcode-stdio-1.0
233165 main-is: Reflex/Test/CrossImpl.hs
234166 hs-source-dirs: test
235− ghc-options: -O2 -Wall -rtsopts
167+ ghc-options: -O2 -Wall -rtsopts -main-is Reflex.Test.CrossImpl.test
236168 build-depends:
237169 base,
238170 containers,
239171 dependent-map,
240− dependent-sum,
241− deepseq,
242172 mtl,
243− transformers,
244173 ref-tf,
245174 reflex
246− other-modules:
247− Reflex.Test
248− Reflex.TestPlan
249− Reflex.Plan.Reflex
250− Reflex.Plan.Pure
251175
252176test-suite hlint
253− default-language: Haskell2010
254177 type: exitcode-stdio-1.0
255178 main-is: hlint.hs
256179 hs-source-dirs: test
@@ -258,226 +181,102 @@ test-suite hlint
258181 , directory
259182 , filepath
260183 , filemanip
261− if impl(ghc >= 8.8)
262− build-depends: hlint >= 3 && < 4
263− else
264− build-depends: hlint (< 2.1 || >= 2.2.2) && < 4
184+ , hlint
265185 if impl(ghcjs)
266186 buildable: False
267187
268188test-suite EventWriterT
269− default-language: Haskell2010
270189 type: exitcode-stdio-1.0
271190 main-is: EventWriterT.hs
272191 hs-source-dirs: test
273192 build-depends: base
274− , containers
275− , deepseq
276− , dependent-map
277− , dependent-sum
278− , lens
279− , mtl
280− , these
281− , transformers
282− , reflex
283− , ref-tf
284−
285− if flag(split-these)
286− build-depends: these-lens
287−
288− other-modules:
289− Test.Run
290−
291−
292−test-suite DebugCycles
293− default-language: Haskell2010
294− type: exitcode-stdio-1.0
295− main-is: DebugCycles.hs
296− hs-source-dirs: test
297− ghc-options: -threaded
298− build-depends: base
299− , containers
300− , deepseq
301− , dependent-map
302193 , dependent-sum
303− , hspec
304194 , lens
305− , mtl
306195 , these
307196 , transformers
308197 , reflex
309198 , ref-tf
310− , witherable
311− , proctest
312−
313−
314− if flag(split-these)
315− build-depends: these-lens, semialign
316−
317− other-modules:
318− Test.Run
319−
320199
321200test-suite RequesterT
322− default-language: Haskell2010
323201 type: exitcode-stdio-1.0
324202 main-is: RequesterT.hs
325203 hs-source-dirs: test
326204 build-depends: base
327− , constraints
328− , constraints-extras
329− , containers
330− , deepseq
331− , dependent-map
332205 , dependent-sum
206+ , dependent-map
333207 , lens
334− , mtl
335− , ref-tf
336− , reflex
337− , text
338208 , these
339209 , transformers
340−
341− if flag(split-these)
342− build-depends: these-lens
343−
344− other-modules:
345− Reflex.TestPlan
346− Reflex.Plan.Pure
347− Test.Run
348−
349−test-suite Headless
350− default-language: Haskell2010
351− type: exitcode-stdio-1.0
352− main-is: Headless.hs
353− hs-source-dirs: test
354− build-depends: base
355− , reflex
356−
357−test-suite Adjustable
358− default-language: Haskell2010
359− type: exitcode-stdio-1.0
360− main-is: Adjustable.hs
361− hs-source-dirs: test
362− build-depends: base
363− , containers
364− , dependent-sum
365210 , reflex
366211 , ref-tf
367− , these
368−
369− other-modules:
370− Test.Run
212+ buildable: False
371213
372214test-suite QueryT
373− default-language: Haskell2010
374215 type: exitcode-stdio-1.0
375216 main-is: QueryT.hs
376217 hs-source-dirs: test
377218 build-depends: base
378219 , containers
379− , dependent-map
380220 , dependent-sum
381− , deepseq
221+ , dependent-map
382222 , lens
383− , monoidal-containers
384− , mtl
385− , patch
386− , ref-tf
387− , reflex
388223 , these
389224 , transformers
390−
391− if flag(split-these)
392− build-depends: semialign, these-lens
393−
394− other-modules:
395− Test.Run
396− Reflex.TestPlan
397− Reflex.Plan.Reflex
398− Reflex.Plan.Pure
225+ , semigroups
226+ , reflex
227+ , ref-tf
228+ other-modules: Test.Run
399229
400230test-suite GC-Semantics
401− default-language: Haskell2010
402231 type: exitcode-stdio-1.0
403232 main-is: GC.hs
404233 hs-source-dirs: test
405234 build-depends: base
406− , containers
407235 , dependent-sum
408236 , dependent-map
409− , deepseq
410− , mtl
411− , patch
412237 , these
413238 , transformers
414239 , reflex
415240 , ref-tf
416−
417− if flag(split-these)
418− build-depends: semialign
419−
420− other-modules:
421− Reflex.Plan.Pure
422− Reflex.Plan.Reflex
423− Reflex.TestPlan
424− Test.Run
241+ if impl(ghc < 8)
242+ build-depends: semigroups
425243
426244test-suite rootCleanup
427− default-language: Haskell2010
428245 type: exitcode-stdio-1.0
429246 main-is: rootCleanup.hs
430247 hs-source-dirs: test
431248 build-depends: base
432− , containers
433− , deepseq
434− , dependent-sum
435− , mtl
436249 , reflex
437− , ref-tf
438− , these
439− other-modules:
440− Reflex.Plan.Pure
441− Reflex.TestPlan
442− Test.Run
443250
444251benchmark spider-bench
445− default-language: Haskell2010
446252 type: exitcode-stdio-1.0
447− hs-source-dirs: bench test
253+ hs-source-dirs: bench
448254 main-is: Main.hs
449255 ghc-options: -Wall -O2 -rtsopts
450256 build-depends:
451257 base,
452− containers,
453− criterion,
454− deepseq,
258+ criterion == 1.1.*,
259+ deepseq >= 1.3 && < 1.5,
455260 dependent-map,
456261 dependent-sum,
457− ref-tf,
458262 mtl,
459263 primitive,
460264 reflex,
461− split,
462265 stm,
463− transformers
464− other-modules:
465− Reflex.TestPlan
466− Reflex.Plan.Reflex
467− Reflex.Bench.Focused
266+ transformers >= 0.3
468267
469268benchmark saulzar-bench
470− default-language: Haskell2010
471269 type: exitcode-stdio-1.0
472270 hs-source-dirs: bench test
473271 c-sources: bench-cbits/checkCapability.c
474272 main-is: RunAll.hs
475273 ghc-options: -Wall -O2 -rtsopts -threaded
274+ ghc-prof-options: -fprof-auto
476275 build-depends:
477276 base,
478− containers,
479− criterion,
480− deepseq,
277+ containers == 0.5.*,
278+ criterion == 1.1.*,
279+ deepseq >= 1.3 && < 1.5,
481280 dependent-map,
482281 dependent-sum,
483282 loch-th,
@@ -489,11 +288,7 @@ benchmark saulzar-bench
489288 split,
490289 stm,
491290 time,
492− transformers
493− other-modules:
494− Reflex.TestPlan
495− Reflex.Plan.Reflex
496− Reflex.Bench.Focused
291+ transformers >= 0.3
497292
498293source-repository head
499294 type: git
release.nixdeleted−58
@@ -1,58 +0,0 @@
1−{ reflex-platform-fun ? import ./dep/reflex-platform
2−, supportedSystems ? ["x86_64-linux" "x86_64-darwin"]
3−}:
4−
5−let
6− native-reflex-platform = reflex-platform-fun {};
7− inherit (native-reflex-platform.nixpkgs) lib;
8−
9− perPlatform = lib.genAttrs supportedSystems (system: let
10− reflex-platform = reflex-platform-fun { inherit system; };
11− compilers = [
12− "ghc"
13− "ghcjs"
14− ] ++ lib.optionals (reflex-platform.androidSupport) [
15− "ghcAndroidAarch64"
16− "ghcAndroidAarch32"
17− ] ++ lib.optionals (reflex-platform.iosSupport) [
18− "ghcIosAarch64"
19− ];
20− variations = map (v: "reflex" + v) [
21− "-dontUseTemplateHaskell"
22− ""
23− ];
24− compilerPkgs = lib.genAttrs compilers (ghc: let
25− variationPkgs = lib.genAttrs variations (variation: let
26− reflex-platform = reflex-platform-fun {
27− inherit system;
28− __useTemplateHaskell = variation == "reflex"; # TODO hack
29− haskellOverlays = [
30− # Use this package's source for reflex
31− (self: super: {
32− _dep = super._dep // {
33− reflex = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [
34− "release.nix"
35− ".git"
36− "dist"
37− "cabal.haskell-ci"
38− "cabal.project"
39− ".travis.yml"
40− ])) ./.;
41− };
42− })
43− ];
44− };
45− in reflex-platform.${ghc}.reflex);
46− in variationPkgs // {
47− cache = reflex-platform.pinBuildInputs "reflex-${system}-${ghc}"
48− (builtins.attrValues variationPkgs);
49− });
50− in compilerPkgs // {
51− cache = reflex-platform.pinBuildInputs "reflex-${system}"
52− (map (a: a.cache) (builtins.attrValues compilerPkgs));
53− });
54−
55− metaCache = native-reflex-platform.pinBuildInputs "reflex-everywhere"
56− (map (a: a.cache) (builtins.attrValues perPlatform));
57−
58−in perPlatform // { inherit metaCache; }
src/Control/Monad/ReaderIO.hsdeleted−60
@@ -1,60 +0,0 @@
1−{-# language RoleAnnotations #-}
2−{-# language MultiParamTypeClasses #-}
3−{-# language FlexibleInstances #-}
4−{-# language CPP #-}
5−module Control.Monad.ReaderIO
6− (
7− ReaderIO (..)
8− )
9− where
10−
11−import Control.Monad.Fix
12−#if MIN_VERSION_base(4,10,0)
13−import Control.Applicative
14−#endif
15−import Control.Monad
16−import Control.Monad.Reader.Class
17−import Control.Monad.IO.Class
18−
19−-- | An approximate clone of @RIO@ from the @rio@ package, but not based on
20−-- @ReaderT@. The trouble with @ReaderT@ is that its third type argument has a
21−-- @nominal@ role, so we can't coerce through it when it's wrapped in some
22−-- other @data@ type. Ugh.
23−newtype ReaderIO e a = ReaderIO { runReaderIO :: e -> IO a }
24−type role ReaderIO representational representational
25−
26−instance Functor (ReaderIO e) where
27− fmap = liftM
28− {-# INLINE fmap #-}
29− a <$ m = m >> pure a
30− {-# INLINE (<$) #-}
31−
32−instance Applicative (ReaderIO e) where
33− pure a = ReaderIO $ \_ -> pure a
34− {-# INLINE pure #-}
35− (<*>) = ap
36− {-# INLINE (<*>) #-}
37−#if MIN_VERSION_base(4,10,0)
38− liftA2 = liftM2
39− {-# INLINE liftA2 #-}
40−#endif
41− (*>) = (>>)
42− {-# INLINE (*>) #-}
43−
44−instance Monad (ReaderIO e) where
45− ReaderIO q >>= f = ReaderIO $ \e -> q e >>= \a -> runReaderIO (f a) e
46− {-# INLINE (>>=) #-}
47−
48−instance MonadFix (ReaderIO e) where
49− mfix f = ReaderIO $ \e -> mfix $ \r -> runReaderIO (f r) e
50− {-# INLINE mfix #-}
51−
52−instance MonadIO (ReaderIO e) where
53− liftIO m = ReaderIO $ \_ -> m
54− {-# INLINE liftIO #-}
55−
56−instance MonadReader e (ReaderIO e) where
57− ask = ReaderIO pure
58− {-# INLINE ask #-}
59− local f (ReaderIO m) = ReaderIO (m . f)
60− {-# INLINE local #-}
src/Data/AppendMap.hs+382−58
@@ -1,84 +1,408 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DeriveTraversable #-}
24{-# LANGUAGE FlexibleContexts #-}
35{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
47{-# LANGUAGE MultiParamTypeClasses #-}
5−{-# LANGUAGE PatternSynonyms #-}
68{-# LANGUAGE RoleAnnotations #-}
79{-# LANGUAGE ScopedTypeVariables #-}
810{-# LANGUAGE TypeFamilies #-}
9−{-# OPTIONS_GHC -fno-warn-orphans #-}
10−-- |
11−-- Module:
12−-- Data.AppendMap
13−-- Description:
14−-- Instances and convenience functions for 'Data.Map.Monoidal'. We use
15−-- monoidal-containers to take advantage of its better monoid instance.
16−-- 'Data.Map' has @mappend = union@, which is left-biased. 'MonoidalMap'
17−-- has @mappend = unionWith mappend@ instead.
18−module Data.AppendMap
19− ( module Data.AppendMap
20− , module Data.Map.Monoidal
21− ) where
22−
23−import Prelude hiding (null)
11+-- | 'Data.Map' with a better 'Monoid' instance
12+--
13+-- 'Data.Map' has @mappend = union@, which is left-biased. AppendMap has
14+-- @mappend = unionWith mappend@ instead.
15+module Data.AppendMap where
2416
17+import Prelude hiding (map)
18+
19+import Control.Lens
20+import Data.Align
2521import Data.Coerce
2622import Data.Default
2723import Data.Map (Map)
28−#if MIN_VERSION_containers(0,5,11)
29−import qualified Data.Map.Internal.Debug as Map (showTree, showTreeWith)
30−#else
31−import qualified Data.Map as Map (showTree, showTreeWith)
32−#endif
33−import qualified Data.Witherable as W
34−import Data.Map.Monoidal
35−import qualified Data.Map.Monoidal as MonoidalMap
36−
37−
38−{-# DEPRECATED AppendMap "Use 'MonoidalMap' instead" #-}
39−-- | AppendMap is a synonym for 'Data.Map.Monoidal.MonoidalMap'
40−type AppendMap = MonoidalMap
41−
42−{-# DEPRECATED _unAppendMap "Use 'getMonoidalMap' instead" #-}
43−-- | A synonym for 'getMonoidalMap'
44−_unAppendMap :: MonoidalMap k v -> Map k v
45−_unAppendMap = getMonoidalMap
46−
47−-- | Pattern synonym for 'MonoidalMap'
48−pattern AppendMap :: Map k v -> MonoidalMap k v
49−pattern AppendMap m = MonoidalMap m
50−
51−#if !MIN_VERSION_witherable(0,3,2)
52−instance W.Filterable (MonoidalMap k) where
53− mapMaybe = MonoidalMap.mapMaybe
54−#endif
24+import qualified Data.Map as Map
25+import Data.Semigroup
26+import Data.Set (Set)
27+import Data.Typeable
28+import GHC.Generics (Generic)
29+import Reflex.Class (FunctorMaybe (..))
30+import Reflex.Patch (Additive, Group (..))
31+
32+newtype AppendMap k m = AppendMap { _unAppendMap :: Map k m }
33+ deriving (Eq, Ord, Show, Read, Typeable, Generic, Functor, Foldable, Traversable, Align)
34+
35+type instance (Index (AppendMap k m)) = k
36+type instance (IxValue (AppendMap k m)) = m
37+
38+instance Ord k => Ixed (AppendMap k m) where
39+ ix i = _Wrapped . ix i
40+
41+instance Ord k => At (AppendMap k m) where
42+ at i = _Wrapped . at i
43+
44+instance FunctorMaybe (AppendMap k) where
45+ fmapMaybe = mapMaybe
5546
5647-- | Deletes a key, returning 'Nothing' if the result is empty.
57−nonEmptyDelete :: Ord k => k -> MonoidalMap k a -> Maybe (MonoidalMap k a)
48+nonEmptyDelete :: Ord k => k -> AppendMap k a -> Maybe (AppendMap k a)
5849nonEmptyDelete k vs =
5950 let deleted = delete k vs
60− in if null deleted
51+ in if Data.AppendMap.null deleted
6152 then Nothing
6253 else Just deleted
6354
64−-- | Like 'mapMaybe' but indicates whether the resulting container is empty
6555mapMaybeNoNull :: (a -> Maybe b)
66− -> MonoidalMap token a
67− -> Maybe (MonoidalMap token b)
56+ -> AppendMap token a
57+ -> Maybe (AppendMap token b)
6858mapMaybeNoNull f as =
69− let bs = mapMaybe f as
70− in if null bs
59+ let bs = fmapMaybe f as
60+ in if Data.AppendMap.null bs
7161 then Nothing
7262 else Just bs
7363
74−-- TODO: Move instances to `Data.Patch`
75−-- | Displays a 'MonoidalMap' as a tree. See 'Data.Map.Lazy.showTree' for details.
76−showTree :: forall k a. (Show k, Show a) => MonoidalMap k a -> String
77−showTree = coerce (Map.showTree :: Map k a -> String)
64+instance FunctorWithIndex k (AppendMap k) where
65+ imap f = AppendMap . imap f . _unAppendMap
66+ imapped = _Wrapped . imapped
67+
68+instance FoldableWithIndex k (AppendMap k) where
69+ ifolded = _Wrapped . ifolded
70+
71+instance TraversableWithIndex k (AppendMap k) where
72+ itraverse = itraverseOf itraversed
73+ itraversed = _Wrapped . itraversed
74+
75+instance (Ord k, Semigroup m) => Semigroup (AppendMap k m) where
76+ (AppendMap m0) <> (AppendMap m1) = AppendMap $ Map.unionWith (<>) m0 m1
77+
78+instance (Ord k, Semigroup m) => Monoid (AppendMap k m) where
79+ mempty = empty
80+ mappend = (<>)
81+
82+instance (Ord k, Group q) => Group (AppendMap k q) where
83+ negateG = map negateG
84+
85+instance (Ord k, Additive q) => Additive (AppendMap k q)
86+
87+(!) :: forall k a. Ord k => AppendMap k a -> k -> a
88+(!) = coerce ((Map.!) :: Map k a -> k -> a)
89+infixl 9 !
90+
91+(\\) :: forall k a b. Ord k => AppendMap k a -> AppendMap k b -> AppendMap k a
92+(\\) = coerce ((Map.\\) :: Map k a -> Map k b -> Map k a)
93+infixl 9 \\
94+
95+null :: forall k a. AppendMap k a -> Bool
96+null = coerce (Map.null :: Map k a -> Bool)
97+
98+size :: forall k a. AppendMap k a -> Int
99+size = coerce (Map.size :: Map k a -> Int)
100+
101+member :: forall k a. Ord k => k -> AppendMap k a -> Bool
102+member = coerce (Map.member :: k -> Map k a -> Bool)
103+
104+notMember :: forall k a. Ord k => k -> AppendMap k a -> Bool
105+notMember = coerce (Map.notMember :: k -> Map k a -> Bool)
106+
107+lookup :: forall k a. Ord k => k -> AppendMap k a -> Maybe a
108+lookup = coerce (Map.lookup :: k -> Map k a -> Maybe a)
109+
110+findWithDefault :: forall k a. Ord k => a -> k -> AppendMap k a -> a
111+findWithDefault = coerce (Map.findWithDefault :: a -> k -> Map k a -> a)
112+
113+lookupLT :: forall k a. Ord k => k -> AppendMap k a -> Maybe (k, a)
114+lookupLT = coerce (Map.lookupLT :: k -> Map k a -> Maybe (k,a))
115+
116+lookupGT :: forall k a. Ord k => k -> AppendMap k a -> Maybe (k, a)
117+lookupGT = coerce (Map.lookupGT :: k -> Map k a -> Maybe (k,a))
118+
119+lookupLE :: forall k a. Ord k => k -> AppendMap k a -> Maybe (k, a)
120+lookupLE = coerce (Map.lookupLE :: k -> Map k a -> Maybe (k,a))
121+
122+lookupGE :: forall k a. Ord k => k -> AppendMap k a -> Maybe (k, a)
123+lookupGE = coerce (Map.lookupGE :: k -> Map k a -> Maybe (k,a))
124+
125+empty :: forall k a. AppendMap k a
126+empty = coerce (Map.empty :: Map k a)
127+
128+singleton :: forall k a. k -> a -> AppendMap k a
129+singleton = coerce (Map.singleton :: k -> a -> Map k a)
130+
131+insert :: forall k a. Ord k => k -> a -> AppendMap k a -> AppendMap k a
132+insert = coerce (Map.insert :: k -> a -> Map k a -> Map k a)
133+
134+insertWith :: forall k a. Ord k => (a -> a -> a) -> k -> a -> AppendMap k a -> AppendMap k a
135+insertWith = coerce (Map.insertWith :: (a -> a -> a) -> k -> a -> Map k a -> Map k a)
136+
137+insertWithKey :: forall k a. Ord k => (k -> a -> a -> a) -> k -> a -> AppendMap k a -> AppendMap k a
138+insertWithKey = coerce (Map.insertWithKey :: (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a)
139+
140+insertLookupWithKey :: forall k a. Ord k => (k -> a -> a -> a) -> k -> a -> AppendMap k a -> (Maybe a, AppendMap k a)
141+insertLookupWithKey = coerce (Map.insertLookupWithKey :: (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a))
142+
143+delete :: forall k a. Ord k => k -> AppendMap k a -> AppendMap k a
144+delete = coerce (Map.delete :: k -> Map k a -> Map k a)
145+
146+adjust :: forall k a. Ord k => (a -> a) -> k -> AppendMap k a -> AppendMap k a
147+adjust = coerce (Map.adjust :: (a -> a) -> k -> Map k a -> Map k a)
148+
149+adjustWithKey :: forall k a. Ord k => (k -> a -> a) -> k -> AppendMap k a -> AppendMap k a
150+adjustWithKey = coerce (Map.adjustWithKey :: (k -> a -> a) -> k -> Map k a -> Map k a)
151+
152+update :: forall k a. Ord k => (a -> Maybe a) -> k -> AppendMap k a -> AppendMap k a
153+update = coerce (Map.update :: (a -> Maybe a) -> k -> Map k a -> Map k a)
154+
155+updateWithKey :: forall k a. Ord k => (k -> a -> Maybe a) -> k -> AppendMap k a -> AppendMap k a
156+updateWithKey = coerce (Map.updateWithKey :: (k -> a -> Maybe a) -> k -> Map k a -> Map k a)
157+
158+updateLookupWithKey :: forall k a. Ord k => (k -> a -> Maybe a) -> k -> AppendMap k a -> (Maybe a, AppendMap k a)
159+updateLookupWithKey = coerce (Map.updateLookupWithKey :: (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a))
160+
161+alter :: forall k a. Ord k => (Maybe a -> Maybe a) -> k -> AppendMap k a -> AppendMap k a
162+alter = coerce (Map.alter :: (Maybe a -> Maybe a) -> k -> Map k a -> Map k a)
163+
164+unionWith :: forall k a. Ord k => (a -> a -> a) -> AppendMap k a -> AppendMap k a -> AppendMap k a
165+unionWith = coerce (Map.unionWith :: (a -> a -> a) -> Map k a -> Map k a -> Map k a)
166+
167+unionWithKey :: forall k a. Ord k => (k -> a -> a -> a) -> AppendMap k a -> AppendMap k a -> AppendMap k a
168+unionWithKey = coerce (Map.unionWithKey :: (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a)
169+
170+unionsWith :: forall k a. Ord k => (a -> a -> a) -> [AppendMap k a] -> AppendMap k a
171+unionsWith = coerce (Map.unionsWith :: (a -> a -> a) -> [Map k a] -> Map k a)
172+
173+difference :: forall k a b. Ord k => AppendMap k a -> AppendMap k b -> AppendMap k a
174+difference = (\\)
175+
176+differenceWith :: forall k a b. Ord k => (a -> b -> Maybe a) -> AppendMap k a -> AppendMap k b -> AppendMap k a
177+differenceWith = coerce (Map.differenceWith :: (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a)
178+
179+differenceWithKey :: forall k a b. Ord k => (k -> a -> b -> Maybe a) -> AppendMap k a -> AppendMap k b -> AppendMap k a
180+differenceWithKey = coerce (Map.differenceWithKey :: (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a)
181+
182+intersectionWith :: forall k a b c. Ord k => (a -> b -> c) -> AppendMap k a -> AppendMap k b -> AppendMap k c
183+intersectionWith = coerce (Map.intersectionWith :: (a -> b -> c) -> Map k a -> Map k b -> Map k c)
184+
185+intersectionWithKey :: forall k a b c. Ord k => (k -> a -> b -> c) -> AppendMap k a -> AppendMap k b -> AppendMap k c
186+intersectionWithKey = coerce (Map.intersectionWithKey :: (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c)
187+
188+mergeWithKey :: forall k a b c. Ord k => (k -> a -> b -> Maybe c) -> (AppendMap k a -> AppendMap k c) -> (AppendMap k b -> AppendMap k c) -> AppendMap k a -> AppendMap k b -> AppendMap k c
189+mergeWithKey = coerce (Map.mergeWithKey :: (k -> a -> b -> Maybe c) -> (Map k a -> Map k c) -> (Map k b -> Map k c) -> Map k a -> Map k b -> Map k c)
190+
191+map :: (a -> b) -> AppendMap k a -> AppendMap k b
192+map = fmap
193+
194+mapWithKey :: (k -> a -> b) -> AppendMap k a -> AppendMap k b
195+mapWithKey = imap
196+
197+traverseWithKey :: Applicative t => (k -> a -> t b) -> AppendMap k a -> t (AppendMap k b)
198+traverseWithKey = itraverse
199+
200+mapAccum :: forall k a b c. (a -> b -> (a, c)) -> a -> AppendMap k b -> (a, AppendMap k c)
201+mapAccum = coerce (Map.mapAccum :: (a -> b -> (a, c)) -> a -> Map k b -> (a, Map k c))
202+
203+mapAccumWithKey :: forall k a b c. (a -> k -> b -> (a, c)) -> a -> AppendMap k b -> (a, AppendMap k c)
204+mapAccumWithKey = coerce (Map.mapAccumWithKey :: (a -> k -> b -> (a, c)) -> a -> Map k b -> (a, Map k c))
205+
206+mapAccumRWithKey :: forall k a b c. (a -> k -> b -> (a, c)) -> a -> AppendMap k b -> (a, AppendMap k c)
207+mapAccumRWithKey = coerce (Map.mapAccumRWithKey :: (a -> k -> b -> (a, c)) -> a -> Map k b -> (a, Map k c))
208+
209+mapKeys :: forall k1 k2 a. Ord k2 => (k1 -> k2) -> AppendMap k1 a -> AppendMap k2 a
210+mapKeys = coerce (Map.mapKeys :: (k1 -> k2) -> Map k1 a -> Map k2 a)
211+
212+mapKeysWith :: forall k1 k2 a. Ord k2 => (a -> a -> a) -> (k1 -> k2) -> AppendMap k1 a -> AppendMap k2 a
213+mapKeysWith = coerce (Map.mapKeysWith :: (a -> a -> a) -> (k1 -> k2) -> Map k1 a -> Map k2 a)
214+
215+mapKeysMonotonic :: forall k1 k2 a. (k1 -> k2) -> AppendMap k1 a -> AppendMap k2 a
216+mapKeysMonotonic = coerce (Map.mapKeysMonotonic :: (k1 -> k2) -> Map k1 a -> Map k2 a)
217+
218+foldr :: forall k a b. (a -> b -> b) -> b -> AppendMap k a -> b
219+foldr = coerce (Map.foldr :: (a -> b -> b) -> b -> Map k a -> b)
220+
221+foldl :: forall k a b. (a -> b -> a) -> a -> AppendMap k b -> a
222+foldl = coerce (Map.foldl :: (a -> b -> a) -> a -> Map k b -> a)
223+
224+foldrWithKey :: forall k a b. (k -> a -> b -> b) -> b -> AppendMap k a -> b
225+foldrWithKey = coerce (Map.foldrWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b)
226+
227+foldlWithKey :: forall k a b. (a -> k -> b -> a) -> a -> AppendMap k b -> a
228+foldlWithKey = coerce (Map.foldlWithKey :: (a -> k -> b -> a) -> a -> Map k b -> a)
78229
79−-- | Displays a 'MonoidalMap' as a tree, using the supplied function to convert nodes to string.
80−showTreeWith :: forall k a. (k -> a -> String) -> Bool -> Bool -> MonoidalMap k a -> String
230+foldMapWithKey :: forall k a m. Monoid m => (k -> a -> m) -> AppendMap k a -> m
231+foldMapWithKey = coerce (Map.foldMapWithKey :: Monoid m => (k -> a -> m) -> Map k a -> m)
232+
233+foldr' :: forall k a b. (a -> b -> b) -> b -> AppendMap k a -> b
234+foldr' = coerce (Map.foldr' :: (a -> b -> b) -> b -> Map k a -> b)
235+
236+foldl' :: forall k a b. (a -> b -> a) -> a -> AppendMap k b -> a
237+foldl' = coerce (Map.foldl' :: (a -> b -> a) -> a -> Map k b -> a)
238+
239+foldrWithKey' :: forall k a b. (k -> a -> b -> b) -> b -> AppendMap k a -> b
240+foldrWithKey' = coerce (Map.foldrWithKey' :: (k -> a -> b -> b) -> b -> Map k a -> b)
241+
242+foldlWithKey' :: forall k a b. (a -> k -> b -> a) -> a -> AppendMap k b -> a
243+foldlWithKey' = coerce (Map.foldlWithKey' :: (a -> k -> b -> a) -> a -> Map k b -> a)
244+
245+elems :: forall k a. AppendMap k a -> [a]
246+elems = coerce (Map.elems :: Map k a -> [a])
247+
248+keys :: forall k a. AppendMap k a -> [k]
249+keys = coerce (Map.keys :: Map k a -> [k])
250+
251+assocs :: forall k a. AppendMap k a -> [(k, a)]
252+assocs = coerce (Map.assocs :: Map k a -> [(k, a)])
253+
254+keysSet :: forall k a. AppendMap k a -> Set k
255+keysSet = coerce (Map.keysSet :: Map k a -> Set k)
256+
257+fromSet :: forall k a. (k -> a) -> Set k -> AppendMap k a
258+fromSet = coerce (Map.fromSet :: (k -> a) -> Set k -> Map k a)
259+
260+toList :: forall k a. AppendMap k a -> [(k, a)]
261+toList = coerce (Map.toList :: Map k a -> [(k, a)])
262+
263+fromList :: forall k a. Ord k => [(k, a)] -> AppendMap k a
264+fromList = coerce (Map.fromList :: [(k, a)] -> Map k a)
265+
266+fromListWith :: forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> AppendMap k a
267+fromListWith = coerce (Map.fromListWith :: (a -> a -> a) -> [(k, a)] -> Map k a)
268+
269+fromListWithKey :: forall k a. Ord k => (k -> a -> a -> a) -> [(k, a)] -> AppendMap k a
270+fromListWithKey = coerce (Map.fromListWithKey :: (k -> a -> a -> a) -> [(k, a)] -> Map k a)
271+
272+toAscList :: forall k a. AppendMap k a -> [(k, a)]
273+toAscList = coerce (Map.toAscList :: Map k a -> [(k, a)])
274+
275+toDescList :: forall k a. AppendMap k a -> [(k, a)]
276+toDescList = coerce (Map.toDescList :: Map k a -> [(k, a)])
277+
278+fromAscList :: forall k a. Eq k => [(k, a)] -> AppendMap k a
279+fromAscList = coerce (Map.fromAscList :: [(k, a)] -> Map k a)
280+
281+fromAscListWith :: forall k a. Eq k => (a -> a -> a) -> [(k, a)] -> AppendMap k a
282+fromAscListWith = coerce (Map.fromAscListWith :: (a -> a -> a) -> [(k, a)] -> Map k a)
283+
284+fromAscListWithKey :: forall k a. Eq k => (k -> a -> a -> a) -> [(k, a)] -> AppendMap k a
285+fromAscListWithKey = coerce (Map.fromAscListWithKey :: (k -> a -> a -> a) -> [(k, a)] -> Map k a)
286+
287+fromDistinctAscList :: forall k a. [(k, a)] -> AppendMap k a
288+fromDistinctAscList = coerce (Map.fromDistinctAscList :: [(k, a)] -> Map k a)
289+
290+filter :: forall k a. (a -> Bool) -> AppendMap k a -> AppendMap k a
291+filter = coerce (Map.filter :: (a -> Bool) -> Map k a -> Map k a)
292+
293+filterWithKey :: forall k a. (k -> a -> Bool) -> AppendMap k a -> AppendMap k a
294+filterWithKey = coerce (Map.filterWithKey :: (k -> a -> Bool) -> Map k a -> Map k a)
295+
296+partition :: forall k a. (a -> Bool) -> AppendMap k a -> (AppendMap k a, AppendMap k a)
297+partition = coerce (Map.partition :: (a -> Bool) -> Map k a -> (Map k a, Map k a))
298+
299+partitionWithKey :: forall k a. (k -> a -> Bool) -> AppendMap k a -> (AppendMap k a, AppendMap k a)
300+partitionWithKey = coerce (Map.partitionWithKey :: (k -> a -> Bool) -> Map k a -> (Map k a, Map k a))
301+
302+mapMaybe :: forall k a b. (a -> Maybe b) -> AppendMap k a -> AppendMap k b
303+mapMaybe = coerce (Map.mapMaybe :: (a -> Maybe b) -> Map k a -> Map k b)
304+
305+mapMaybeWithKey :: forall k a b. (k -> a -> Maybe b) -> AppendMap k a -> AppendMap k b
306+mapMaybeWithKey = coerce (Map.mapMaybeWithKey :: (k -> a -> Maybe b) -> Map k a -> Map k b)
307+
308+mapEither :: forall k a b c. (a -> Either b c) -> AppendMap k a -> (AppendMap k b, AppendMap k c)
309+mapEither = coerce (Map.mapEither :: (a -> Either b c) -> Map k a -> (Map k b, Map k c))
310+
311+mapEitherWithKey :: forall k a b c. (k -> a -> Either b c) -> AppendMap k a -> (AppendMap k b, AppendMap k c)
312+mapEitherWithKey = coerce (Map.mapEitherWithKey :: (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c))
313+
314+split :: forall k a. Ord k => k -> AppendMap k a -> (AppendMap k a, AppendMap k a)
315+split = coerce (Map.split :: k -> Map k a -> (Map k a, Map k a))
316+
317+splitLookup :: forall k a. Ord k => k -> AppendMap k a -> (AppendMap k a, Maybe a, AppendMap k a)
318+splitLookup = coerce (Map.splitLookup :: k -> Map k a -> (Map k a, Maybe a, Map k a))
319+
320+splitRoot :: forall k a. AppendMap k a -> [AppendMap k a]
321+splitRoot = coerce (Map.splitRoot :: Map k a -> [Map k a])
322+
323+isSubmapOf :: forall k a. (Ord k, Eq a) => AppendMap k a -> AppendMap k a -> Bool
324+isSubmapOf = coerce (Map.isSubmapOf :: Map k a -> Map k a -> Bool)
325+
326+isSubmapOfBy :: forall k a b. Ord k => (a -> b -> Bool) -> AppendMap k a -> AppendMap k b -> Bool
327+isSubmapOfBy = coerce (Map.isSubmapOfBy :: (a -> b -> Bool) -> Map k a -> Map k b -> Bool)
328+
329+isProperSubmapOf :: forall k a. (Ord k, Eq a) => AppendMap k a -> AppendMap k a -> Bool
330+isProperSubmapOf = coerce (Map.isProperSubmapOf :: Map k a -> Map k a -> Bool)
331+
332+isProperSubmapOfBy :: forall k a b. Ord k => (a -> b -> Bool) -> AppendMap k a -> AppendMap k b -> Bool
333+isProperSubmapOfBy = coerce (Map.isProperSubmapOfBy :: (a -> b -> Bool) -> Map k a -> Map k b -> Bool)
334+
335+lookupIndex :: forall k a. Ord k => k -> AppendMap k a -> Maybe Int
336+lookupIndex = coerce (Map.lookupIndex :: k -> Map k a -> Maybe Int)
337+
338+findIndex :: forall k a. Ord k => k -> AppendMap k a -> Int
339+findIndex = coerce (Map.findIndex :: k -> Map k a -> Int)
340+
341+elemAt :: forall k a. Int -> AppendMap k a -> (k, a)
342+elemAt = coerce (Map.elemAt :: Int -> Map k a -> (k, a))
343+
344+updateAt :: forall k a. (k -> a -> Maybe a) -> Int -> AppendMap k a -> AppendMap k a
345+updateAt = coerce (Map.updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a)
346+
347+deleteAt :: forall k a. Int -> AppendMap k a -> AppendMap k a
348+deleteAt = coerce (Map.deleteAt :: Int -> Map k a -> Map k a)
349+
350+findMin :: forall k a. AppendMap k a -> (k, a)
351+findMin = coerce (Map.findMin :: Map k a -> (k, a))
352+
353+findMax :: forall k a. AppendMap k a -> (k, a)
354+findMax = coerce (Map.findMax :: Map k a -> (k, a))
355+
356+deleteMin :: forall k a. AppendMap k a -> AppendMap k a
357+deleteMin = coerce (Map.deleteMin :: Map k a -> Map k a)
358+
359+deleteMax :: forall k a. AppendMap k a -> AppendMap k a
360+deleteMax = coerce (Map.deleteMax :: Map k a -> Map k a)
361+
362+deleteFindMin :: forall k a. AppendMap k a -> ((k, a), AppendMap k a)
363+deleteFindMin = coerce (Map.deleteFindMin :: Map k a -> ((k, a), Map k a))
364+
365+deleteFindMax :: forall k a. AppendMap k a -> ((k, a), AppendMap k a)
366+deleteFindMax = coerce (Map.deleteFindMax :: Map k a -> ((k, a), Map k a))
367+
368+updateMin :: forall k a. (a -> Maybe a) -> AppendMap k a -> AppendMap k a
369+updateMin = coerce (Map.updateMin :: (a -> Maybe a) -> Map k a -> Map k a)
370+
371+updateMax :: forall k a. (a -> Maybe a) -> AppendMap k a -> AppendMap k a
372+updateMax = coerce (Map.updateMax :: (a -> Maybe a) -> Map k a -> Map k a)
373+
374+updateMinWithKey :: forall k a. (k -> a -> Maybe a) -> AppendMap k a -> AppendMap k a
375+updateMinWithKey = coerce (Map.updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a)
376+
377+updateMaxWithKey :: forall k a. (k -> a -> Maybe a) -> AppendMap k a -> AppendMap k a
378+updateMaxWithKey = coerce (Map.updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a)
379+
380+minView :: forall k a. AppendMap k a -> Maybe (a, AppendMap k a)
381+minView = coerce (Map.minView :: Map k a -> Maybe (a, Map k a))
382+
383+maxView :: forall k a. AppendMap k a -> Maybe (a, AppendMap k a)
384+maxView = coerce (Map.maxView :: Map k a -> Maybe (a, Map k a))
385+
386+minViewWithKey :: forall k a. AppendMap k a -> Maybe ((k, a), AppendMap k a)
387+minViewWithKey = coerce (Map.minViewWithKey :: Map k a -> Maybe ((k, a), Map k a))
388+
389+maxViewWithKey :: forall k a. AppendMap k a -> Maybe ((k, a), AppendMap k a)
390+maxViewWithKey = coerce (Map.maxViewWithKey :: Map k a -> Maybe ((k, a), Map k a))
391+
392+showTree :: forall k a. (Show k, Show a) => AppendMap k a -> String
393+showTree = coerce (Map.showTree :: (Show k, Show a) => Map k a -> String)
394+
395+showTreeWith :: forall k a. (k -> a -> String) -> Bool -> Bool -> AppendMap k a -> String
81396showTreeWith = coerce (Map.showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String)
82397
83−instance Default (MonoidalMap k a) where
398+valid :: forall k a. Ord k => AppendMap k a -> Bool
399+valid = coerce (Map.valid :: Ord k => Map k a -> Bool)
400+
401+instance Default (AppendMap k a) where
84402 def = empty
403+
404+instance AppendMap k' v' ~ t => Rewrapped (AppendMap k a) t
405+
406+instance Wrapped (AppendMap k a) where
407+ type Unwrapped (AppendMap k a) = Map k a
408+ _Wrapped' = iso (\(AppendMap m) -> m) AppendMap
src/Data/FastMutableIntMap.hs+4−25
@@ -1,9 +1,4 @@
11{-# LANGUAGE TypeFamilies #-}
2−-- |
3−-- Module:
4−-- Data.FastMutableIntMap
5−-- Description:
6−-- A mutable version of 'IntMap'
72module Data.FastMutableIntMap
83 ( FastMutableIntMap
94 , new
@@ -21,60 +16,49 @@ module Data.FastMutableIntMap
2116 , patchIntMapNewElements
2217 , patchIntMapNewElementsMap
2318 , getDeletions
24− , toList
2519 ) where
2620
2721--TODO: Pure JS version
2822--TODO: Fast copy to FastIntMap
2923--TODO: Fast patch type
3024
31−import Prelude hiding (lookup)
32−
3325import Control.Monad.IO.Class
3426import Data.Foldable (traverse_)
3527import Data.IntMap.Strict (IntMap)
3628import qualified Data.IntMap.Strict as IntMap
3729import Data.IORef
38−import Data.Patch.Class
39−import Data.Patch.IntMap
30+import Data.Maybe
31+import Prelude hiding (lookup)
32+import Reflex.Patch.Class
33+import Reflex.Patch.IntMap
4034
41−-- | A 'FastMutableIntMap' holds a map of values of type @a@ and allows low-overhead modifications via IO.
42−-- Operations on 'FastMutableIntMap' run in IO.
4335newtype FastMutableIntMap a = FastMutableIntMap (IORef (IntMap a))
4436
45−-- | Create a new 'FastMutableIntMap' out of an 'IntMap'
4637new :: IntMap a -> IO (FastMutableIntMap a)
4738new m = FastMutableIntMap <$> newIORef m
4839
49−-- | Create a new empty 'FastMutableIntMap'
5040newEmpty :: IO (FastMutableIntMap a)
5141newEmpty = FastMutableIntMap <$> newIORef IntMap.empty
5242
53−-- | Insert an element into a 'FastMutableIntMap' at the given key
5443insert :: FastMutableIntMap a -> Int -> a -> IO ()
5544insert (FastMutableIntMap r) k v = modifyIORef' r $ IntMap.insert k v
5645
57−-- | Attempt to lookup an element by key in a 'FastMutableIntMap'
5846lookup :: FastMutableIntMap a -> Int -> IO (Maybe a)
5947lookup (FastMutableIntMap r) k = IntMap.lookup k <$> readIORef r
6048
61−-- | Runs the provided action over the intersection of a 'FastMutableIntMap' and an 'IntMap'
6249forIntersectionWithImmutable_ :: MonadIO m => FastMutableIntMap a -> IntMap b -> (a -> b -> m ()) -> m ()
6350forIntersectionWithImmutable_ (FastMutableIntMap r) b f = do
6451 a <- liftIO $ readIORef r
6552 traverse_ (uncurry f) $ IntMap.intersectionWith (,) a b
6653
67−-- | Runs the provided action over the values of a 'FastMutableIntMap'
6854for_ :: MonadIO m => FastMutableIntMap a -> (a -> m ()) -> m ()
6955for_ (FastMutableIntMap r) f = do
7056 a <- liftIO $ readIORef r
7157 traverse_ f a
7258
73−-- | Checks whether a 'FastMutableIntMap' is empty
7459isEmpty :: FastMutableIntMap a -> IO Bool
7560isEmpty (FastMutableIntMap r) = IntMap.null <$> readIORef r
7661
77−-- | Retrieves the size of a 'FastMutableIntMap'
7862size :: FastMutableIntMap a -> IO Int
7963size (FastMutableIntMap r) = IntMap.size <$> readIORef r
8064
@@ -85,13 +69,8 @@ getFrozenAndClear (FastMutableIntMap r) = do
8569 writeIORef r IntMap.empty
8670 return result
8771
88−-- | Updates the value of a 'FastMutableIntMap' with the given patch (see 'Data.Patch.IntMap'),
89−-- and returns an 'IntMap' with the modified keys and values.
9072applyPatch :: FastMutableIntMap a -> PatchIntMap a -> IO (IntMap a)
9173applyPatch (FastMutableIntMap r) p@(PatchIntMap m) = do
9274 v <- readIORef r
9375 writeIORef r $! applyAlways p v
9476 return $ IntMap.intersection v m
95−
96−toList :: FastMutableIntMap a -> IO [(Int, a)]
97−toList (FastMutableIntMap r) = IntMap.toList <$> readIORef r
src/Data/FastWeakBag.hs+11−15
@@ -18,7 +18,6 @@ module Data.FastWeakBag
1818 , isEmpty
1919 , insert
2020 , traverse
21− , traverse_
2221 , remove
2322 -- * Internal functions
2423 -- These will not always be available.
@@ -27,9 +26,7 @@ module Data.FastWeakBag
2726#endif
2827 ) where
2928
30−import Prelude hiding (traverse)
31−
32−import Control.Monad
29+import Control.Monad hiding (forM_, mapM_)
3330import Control.Monad.IO.Class
3431
3532#ifdef GHCJS_FAST_WEAK
@@ -37,21 +34,24 @@ import GHCJS.Types
3734import Reflex.FastWeak (js_isNull, unsafeFromRawJSVal, unsafeToRawJSVal)
3835#else
3936import Control.Exception
37+import Data.Foldable (forM_, mapM_)
4038import Data.IntMap.Strict (IntMap)
4139import qualified Data.IntMap.Strict as IntMap
4240import Data.IORef
4341import System.Mem.Weak
4442#endif
4543
46−-- | A 'FastWeakBag' holds a set of values of type @/a/@, but does not retain them -
47−-- that is, they can still be garbage-collected. As long as the @/a/@ values remain
44+import Prelude hiding (mapM_, traverse)
45+
46+-- | A @FastWeakBag a@ holds a set of values of type @a@, but does not retain them -
47+-- that is, they can still be garbage-collected. As long as the @a@s remain
4848-- alive, the 'FastWeakBag' will continue to refer to them.
4949#ifdef GHCJS_FAST_WEAK
5050newtype FastWeakBag a = FastWeakBag JSVal
5151#else
5252data FastWeakBag a = FastWeakBag
5353 { _weakBag_nextId :: {-# UNPACK #-} !(IORef Int) --TODO: what if this wraps around?
54− , _weakBag_children :: {-# UNPACK #-} !(IORef (IntMap (Weak a))) -- ^ Map of items contained by the 'FastWeakBag'
54+ , _weakBag_children :: {-# UNPACK #-} !(IORef (IntMap (Weak a)))
5555 }
5656#endif
5757
@@ -117,14 +117,14 @@ foreign import javascript unsafe "(function(){ for(var i = 0; i < $1.tickets.len
117117isEmpty bag = {-# SCC "isEmpty" #-} IntMap.null <$> readIORef (_weakBag_children bag)
118118#endif
119119
120−{-# INLINE traverse_ #-}
120+{-# INLINE traverse #-}
121121-- | Visit every node in the given list. If new nodes are appended during the
122122-- traversal, they will not be visited. Every live node that was in the list
123123-- when the traversal began will be visited exactly once; however, no guarantee
124124-- is made about the order of the traversal.
125−traverse_ :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m ()
125+traverse :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m ()
126126#ifdef GHCJS_FAST_WEAK
127−traverse_ wb f = do
127+traverse wb f = do
128128 let go cursor = when (not $ js_isNull cursor) $ do
129129 val <- liftIO $ js_getTicketValue cursor
130130 f $ unsafeFromRawJSVal val
@@ -135,17 +135,13 @@ foreign import javascript unsafe "$r = $1.val;" js_getTicketValue :: JSVal -> IO
135135--TODO: Fix the race condition where if a cursor is deleted (presumably using 'remove', below) while we're holding it, it can't find its way back to the correct bag
136136foreign import javascript unsafe "(function(){ for(var i = $1.pos - 1; i >= 0; i--) { if($1.bag.tickets[i] !== null) { return $1.bag.tickets[i]; } }; return null; })()" js_getNext :: FastWeakBagTicket a -> IO JSVal --TODO: Clean up as we go along so this isn't O(n) every time -- Result can be null or a FastWeakBagTicket a
137137#else
138−traverse_ (FastWeakBag _ children) f = {-# SCC "traverse_" #-} do
138+traverse (FastWeakBag _ children) f = {-# SCC "traverse" #-} do
139139 cs <- liftIO $ readIORef children
140140 forM_ cs $ \c -> do
141141 ma <- liftIO $ deRefWeak c
142142 mapM_ f ma
143143#endif
144144
145−{-# DEPRECATED traverse "Use 'traverse_' instead" #-}
146−traverse :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m ()
147−traverse = traverse_
148−
149145-- | Remove an item from the 'FastWeakBag'; does nothing if invoked multiple times
150146-- on the same 'FastWeakBagTicket'.
151147{-# INLINE remove #-}
src/Data/Functor/Misc.hsnew file+287
@@ -0,0 +1,287 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE DeriveFunctor #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE KindSignatures #-}
8+{-# LANGUAGE LambdaCase #-}
9+{-# LANGUAGE MultiParamTypeClasses #-}
10+{-# LANGUAGE PatternSynonyms #-}
11+{-# LANGUAGE PolyKinds #-}
12+{-# LANGUAGE RankNTypes #-}
13+{-# LANGUAGE ScopedTypeVariables #-}
14+{-# LANGUAGE StandaloneDeriving #-}
15+#ifdef USE_REFLEX_OPTIMIZER
16+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
17+#endif
18+-- | This module provides types and functions with no particular theme, but
19+-- which are relevant to the use of 'Functor'-based datastructures like
20+-- 'Data.Dependent.Map.DMap'.
21+module Data.Functor.Misc
22+ ( -- * Const2
23+ Const2 (..)
24+ , unConst2
25+ , dmapToMap
26+ , dmapToIntMap
27+ , dmapToMapWith
28+ , mapToDMap
29+ , weakenDMapWith
30+ -- * WrapArg
31+ , WrapArg (..)
32+ -- * Convenience functions for DMap
33+ , mapWithFunctorToDMap
34+ , intMapWithFunctorToDMap
35+ , mapKeyValuePairsMonotonic
36+ , combineDMapsWithKey
37+ , EitherTag (..)
38+ , dmapToThese
39+ , eitherToDSum
40+ , dsumToEither
41+ -- * Deprecated functions
42+ , sequenceDmap
43+ , wrapDMap
44+ , rewrapDMap
45+ , unwrapDMap
46+ , unwrapDMapMaybe
47+ , extractFunctorDMap
48+ , ComposeMaybe (..)
49+ ) where
50+
51+import Control.Applicative (Applicative, (<$>))
52+import Control.Monad.Identity
53+import Data.Dependent.Map (DMap)
54+import qualified Data.Dependent.Map as DMap
55+import Data.Dependent.Sum
56+import Data.GADT.Compare
57+import Data.GADT.Show
58+import Data.IntMap (IntMap)
59+import qualified Data.IntMap as IntMap
60+import Data.Map (Map)
61+import qualified Data.Map as Map
62+import Data.Some (Some)
63+import qualified Data.Some as Some
64+import Data.These
65+import Data.Typeable hiding (Refl)
66+
67+--------------------------------------------------------------------------------
68+-- Const2
69+--------------------------------------------------------------------------------
70+
71+-- | 'Const2' stores a value of a given type 'k' and ensures that a particular
72+-- type 'v' is always given for the last type parameter
73+data Const2 :: * -> x -> x -> * where
74+ Const2 :: k -> Const2 k v v
75+ deriving (Typeable)
76+
77+-- | Extract the value from a Const2
78+unConst2 :: Const2 k v v' -> k
79+unConst2 (Const2 k) = k
80+
81+deriving instance Eq k => Eq (Const2 k v v')
82+deriving instance Ord k => Ord (Const2 k v v')
83+deriving instance Show k => Show (Const2 k v v')
84+deriving instance Read k => Read (Const2 k v v)
85+
86+instance Show k => GShow (Const2 k v) where
87+ gshowsPrec n x@(Const2 _) = showsPrec n x
88+
89+instance (Show k, Show (f v)) => ShowTag (Const2 k v) f where
90+ showTaggedPrec (Const2 _) = showsPrec
91+
92+instance Eq k => GEq (Const2 k v) where
93+ geq (Const2 a) (Const2 b) =
94+ if a == b
95+ then Just Refl
96+ else Nothing
97+
98+instance Ord k => GCompare (Const2 k v) where
99+ gcompare (Const2 a) (Const2 b) = case compare a b of
100+ LT -> GLT
101+ EQ -> GEQ
102+ GT -> GGT
103+
104+-- | Convert a 'DMap' to a regular 'Map'
105+dmapToMap :: DMap (Const2 k v) Identity -> Map k v
106+dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList
107+
108+-- | Convert a 'DMap' to an 'IntMap'
109+dmapToIntMap :: DMap (Const2 IntMap.Key v) Identity -> IntMap v
110+dmapToIntMap = IntMap.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList
111+
112+-- | Convert a 'DMap' to a regular 'Map', applying the given function to remove
113+-- the wrapping 'Functor'
114+dmapToMapWith :: (f v -> v') -> DMap (Const2 k v) f -> Map k v'
115+dmapToMapWith f = Map.fromDistinctAscList . map (\(Const2 k :=> v) -> (k, f v)) . DMap.toAscList
116+
117+-- | Convert a regular 'Map' to a 'DMap'
118+mapToDMap :: Map k v -> DMap (Const2 k v) Identity
119+mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> Identity v) . Map.toAscList
120+
121+-- | Convert a regular 'Map', where the values are already wrapped in a functor,
122+-- to a 'DMap'
123+mapWithFunctorToDMap :: Map k (f v) -> DMap (Const2 k v) f
124+mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . Map.toAscList
125+
126+-- | Convert a regular 'IntMap', where the values are already wrapped in a
127+-- functor, to a 'DMap'
128+intMapWithFunctorToDMap :: IntMap (f v) -> DMap (Const2 IntMap.Key v) f
129+intMapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . IntMap.toAscList
130+
131+-- | Convert a 'DMap' to a regular 'Map' by forgetting the types associated with
132+-- the keys, using a function to remove the wrapping 'Functor'
133+weakenDMapWith :: (forall a. v a -> v') -> DMap k v -> Map (Some k) v'
134+weakenDMapWith f = Map.fromDistinctAscList . map (\(k :=> v) -> (Some.This k, f v)) . DMap.toAscList
135+
136+--------------------------------------------------------------------------------
137+-- WrapArg
138+--------------------------------------------------------------------------------
139+
140+-- | 'WrapArg' can be used to tag a value in one functor with a type
141+-- representing another functor. This was primarily used with dependent-map <
142+-- 0.2, in which the value type was not wrapped in a separate functor.
143+data WrapArg :: (k -> *) -> (k -> *) -> * -> * where
144+ WrapArg :: f a -> WrapArg g f (g a)
145+
146+deriving instance Eq (f a) => Eq (WrapArg g f (g' a))
147+deriving instance Ord (f a) => Ord (WrapArg g f (g' a))
148+deriving instance Show (f a) => Show (WrapArg g f (g' a))
149+deriving instance Read (f a) => Read (WrapArg g f (g a))
150+
151+instance GEq f => GEq (WrapArg g f) where
152+ geq (WrapArg a) (WrapArg b) = (\Refl -> Refl) <$> geq a b
153+
154+instance GCompare f => GCompare (WrapArg g f) where
155+ gcompare (WrapArg a) (WrapArg b) = case gcompare a b of
156+ GLT -> GLT
157+ GEQ -> GEQ
158+ GGT -> GGT
159+
160+--------------------------------------------------------------------------------
161+-- Convenience functions for DMap
162+--------------------------------------------------------------------------------
163+
164+-- | Map over all key/value pairs in a 'DMap', potentially altering the key as
165+-- well as the value. The provided function MUST preserve the ordering of the
166+-- keys, or the resulting 'DMap' will be malformed.
167+mapKeyValuePairsMonotonic :: (DSum k v -> DSum k' v') -> DMap k v -> DMap k' v'
168+mapKeyValuePairsMonotonic f = DMap.fromDistinctAscList . map f . DMap.toAscList
169+
170+{-# INLINE combineDMapsWithKey #-}
171+-- | Union two 'DMap's of different types, yielding another type. Each key that
172+-- is present in either input map will be present in the output.
173+combineDMapsWithKey :: forall f g h i.
174+ GCompare f
175+ => (forall a. f a -> These (g a) (h a) -> i a)
176+ -> DMap f g
177+ -> DMap f h
178+ -> DMap f i
179+combineDMapsWithKey f mg mh = DMap.fromList $ go (DMap.toList mg) (DMap.toList mh)
180+ where go :: [DSum f g] -> [DSum f h] -> [DSum f i]
181+ go [] hs = map (\(hk :=> hv) -> hk :=> f hk (That hv)) hs
182+ go gs [] = map (\(gk :=> gv) -> gk :=> f gk (This gv)) gs
183+ go gs@((gk :=> gv) : gs') hs@((hk :=> hv) : hs') = case gk `gcompare` hk of
184+ GLT -> (gk :=> f gk (This gv)) : go gs' hs
185+ GEQ -> (gk :=> f gk (These gv hv)) : go gs' hs'
186+ GGT -> (hk :=> f hk (That hv)) : go gs hs'
187+
188+-- | Extract the values of a 'DMap' of 'EitherTag's.
189+dmapToThese :: DMap (EitherTag a b) Identity -> Maybe (These a b)
190+dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of
191+ (Nothing, Nothing) -> Nothing
192+ (Just (Identity a), Nothing) -> Just $ This a
193+ (Nothing, Just (Identity b)) -> Just $ That b
194+ (Just (Identity a), Just (Identity b)) -> Just $ These a b
195+
196+-- | Tag type for 'Either' to use it as a 'DSum'.
197+data EitherTag l r a where
198+ LeftTag :: EitherTag l r l
199+ RightTag :: EitherTag l r r
200+ deriving (Typeable)
201+
202+deriving instance Show (EitherTag l r a)
203+deriving instance Eq (EitherTag l r a)
204+deriving instance Ord (EitherTag l r a)
205+
206+instance GEq (EitherTag l r) where
207+ geq a b = case (a, b) of
208+ (LeftTag, LeftTag) -> Just Refl
209+ (RightTag, RightTag) -> Just Refl
210+ _ -> Nothing
211+
212+instance GCompare (EitherTag l r) where
213+ gcompare a b = case (a, b) of
214+ (LeftTag, LeftTag) -> GEQ
215+ (LeftTag, RightTag) -> GLT
216+ (RightTag, LeftTag) -> GGT
217+ (RightTag, RightTag) -> GEQ
218+
219+instance GShow (EitherTag l r) where
220+ gshowsPrec _ a = case a of
221+ LeftTag -> showString "LeftTag"
222+ RightTag -> showString "RightTag"
223+
224+instance (Show l, Show r) => ShowTag (EitherTag l r) Identity where
225+ showTaggedPrec t n (Identity a) = case t of
226+ LeftTag -> showsPrec n a
227+ RightTag -> showsPrec n a
228+
229+-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.
230+eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity
231+eitherToDSum = \case
232+ Left a -> (LeftTag :=> Identity a)
233+ Right b -> (RightTag :=> Identity b)
234+
235+-- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'.
236+dsumToEither :: DSum (EitherTag a b) Identity -> Either a b
237+dsumToEither = \case
238+ (LeftTag :=> Identity a) -> Left a
239+ (RightTag :=> Identity b) -> Right b
240+
241+--------------------------------------------------------------------------------
242+-- ComposeMaybe
243+--------------------------------------------------------------------------------
244+
245+-- | We can't use @Compose Maybe@ instead of 'ComposeMaybe', because that would
246+-- make the 'f' parameter have a nominal type role. We need f to be
247+-- representational so that we can use safe 'coerce'.
248+newtype ComposeMaybe f a =
249+ ComposeMaybe { getComposeMaybe :: Maybe (f a) } deriving (Show, Eq, Ord)
250+
251+deriving instance Functor f => Functor (ComposeMaybe f)
252+
253+--------------------------------------------------------------------------------
254+-- Deprecated functions
255+--------------------------------------------------------------------------------
256+
257+{-# INLINE sequenceDmap #-}
258+{-# DEPRECATED sequenceDmap "Use 'Data.Dependent.Map.traverseWithKey (\\_ -> fmap Identity)' instead" #-}
259+-- | Run the actions contained in the 'DMap'
260+sequenceDmap :: Applicative t => DMap f t -> t (DMap f Identity)
261+sequenceDmap = DMap.traverseWithKey $ \_ t -> Identity <$> t
262+
263+{-# DEPRECATED wrapDMap "Use 'Data.Dependent.Map.map (f . runIdentity)' instead" #-}
264+-- | Replace the 'Identity' functor for a 'DMap''s values with a different functor
265+wrapDMap :: (forall a. a -> f a) -> DMap k Identity -> DMap k f
266+wrapDMap f = DMap.map $ f . runIdentity
267+
268+{-# DEPRECATED rewrapDMap "Use 'Data.Dependent.Map.map' instead" #-}
269+-- | Replace one functor for a 'DMap''s values with a different functor
270+rewrapDMap :: (forall (a :: *). f a -> g a) -> DMap k f -> DMap k g
271+rewrapDMap = DMap.map
272+
273+{-# DEPRECATED unwrapDMap "Use 'Data.Dependent.Map.map (Identity . f)' instead" #-}
274+-- | Replace one functor for a 'DMap''s values with the 'Identity' functor
275+unwrapDMap :: (forall a. f a -> a) -> DMap k f -> DMap k Identity
276+unwrapDMap f = DMap.map $ Identity . f
277+
278+{-# DEPRECATED unwrapDMapMaybe "Use 'Data.Dependent.Map.mapMaybeWithKey (\\_ a -> fmap Identity $ f a)' instead" #-}
279+-- | Like 'unwrapDMap', but possibly delete some values from the DMap
280+unwrapDMapMaybe :: GCompare k => (forall a. f a -> Maybe a) -> DMap k f -> DMap k Identity
281+unwrapDMapMaybe f = DMap.mapMaybeWithKey $ \_ a -> Identity <$> f a
282+
283+{-# DEPRECATED extractFunctorDMap "Use 'mapKeyValuePairsMonotonic (\\(Const2 k :=> Identity v) -> Const2 k :=> v)' instead" #-}
284+-- | Eliminate the 'Identity' functor in a 'DMap' and replace it with the
285+-- underlying functor
286+extractFunctorDMap :: DMap (Const2 k (f v)) Identity -> DMap (Const2 k v) f
287+extractFunctorDMap = mapKeyValuePairsMonotonic $ \(Const2 k :=> Identity v) -> Const2 k :=> v
src/Data/Map/Misc.hs+10−26
@@ -1,5 +1,4 @@
11{-# LANGUAGE LambdaCase #-}
2−-- | Additional functions for manipulating 'Map's.
32module Data.Map.Misc
43 (
54 -- * Working with Maps
@@ -11,6 +10,7 @@ module Data.Map.Misc
1110 ) where
1211
1312import Data.Align
13+import Data.Either (isLeft)
1414import Data.Map (Map)
1515import qualified Data.Map as Map
1616import Data.Maybe
@@ -18,21 +18,12 @@ import Data.Set (Set)
1818import qualified Data.Set as Set
1919import Data.These
2020
21−-- |Produce a @'Map' k (Maybe v)@ by comparing two @'Map' k v@s, @old@ and @new@ respectively. @Just@ represents an association present in @new@ and @Nothing@
22−-- represents an association only present in @old@ but no longer present in @new@.
23−--
24−-- Similar to 'diffMap' but doesn't require 'Eq' on the values, thus can't tell if a value has changed or not.
2521diffMapNoEq :: (Ord k) => Map k v -> Map k v -> Map k (Maybe v)
2622diffMapNoEq olds news = flip Map.mapMaybe (align olds news) $ \case
2723 This _ -> Just Nothing
2824 These _ new -> Just $ Just new
2925 That new -> Just $ Just new
3026
31−-- |Produce a @'Map' k (Maybe v)@ by comparing two @'Map' k v@s, @old@ and @new respectively. @Just@ represents an association present in @new@ and either not
32−-- present in @old@ or where the value has changed. @Nothing@ represents an association only present in @old@ but no longer present in @new@.
33−--
34−-- See also 'diffMapNoEq' for a similar but weaker version which does not require 'Eq' on the values but thus can't indicated a value not changing between
35−-- @old@ and @new@ with @Nothing@.
3627diffMap :: (Ord k, Eq v) => Map k v -> Map k v -> Map k (Maybe v)
3728diffMap olds news = flip Map.mapMaybe (align olds news) $ \case
3829 This _ -> Just Nothing
@@ -41,30 +32,23 @@ diffMap olds news = flip Map.mapMaybe (align olds news) $ \case
4132 | otherwise -> Just $ Just new
4233 That new -> Just $ Just new
4334
44−-- |Given a @'Map' k (Maybe v)@ representing keys to insert/update (@Just@) or delete (@Nothing@), produce a new map from the given input @'Map' k v@.
45−--
46−-- See also 'Data.Patch.Map' and 'Data.Patch.MapWithMove'.
4735applyMap :: Ord k => Map k (Maybe v) -> Map k v -> Map k v
4836applyMap patch old = insertions `Map.union` (old `Map.difference` deletions)
49− where (deletions, insertions) = Map.mapEither maybeToEither patch
37+ where (deletions, insertions) = mapPartitionEithers $ maybeToEither <$> patch
5038 maybeToEither = \case
5139 Nothing -> Left ()
5240 Just r -> Right r
5341
54−-- |Split a @'Map' k (Either a b)@ into @Map k a@ and @Map k b@, equivalent to @'Map.mapEither' id@
55−{-# DEPRECATED mapPartitionEithers "Use 'mapEither' instead" #-}
5642mapPartitionEithers :: Map k (Either a b) -> (Map k a, Map k b)
57−mapPartitionEithers = Map.mapEither id
43+mapPartitionEithers m = (fromLeft <$> ls, fromRight <$> rs)
44+ where (ls, rs) = Map.partition isLeft m
45+ fromLeft (Left l) = l
46+ fromLeft _ = error "mapPartitionEithers: fromLeft received a Right value; this should be impossible"
47+ fromRight (Right r) = r
48+ fromRight _ = error "mapPartitionEithers: fromRight received a Left value; this should be impossible"
5849
59−-- |Given a @'Map' k (Maybe v)@ representing keys to insert/update (@Just@) or delete (@Nothing@), produce a new @'Set' k@ from the given input set.
60−--
61−-- Equivalent to:
62−--
63−-- @
64−-- applyMapKeysSet patch ('Map.keysSet' m) == 'Map.keysSet' ('applyMap' patch m)
65−-- @
66−--
67−-- but avoids the intervening @Map@ and needs no values.
50+-- | Apply a map patch to a set
51+-- > applyMapKeysSet patch (Map.keysSet m) == Map.keysSet (applyMap patch m)
6852applyMapKeysSet :: Ord k => Map k (Maybe v) -> Set k -> Set k
6953applyMapKeysSet patch old = Map.keysSet insertions `Set.union` (old `Set.difference` Map.keysSet deletions)
7054 where (insertions, deletions) = Map.partition isJust patch
src/Data/WeakBag.hs+9−13
@@ -15,25 +15,25 @@ module Data.WeakBag
1515 , singleton
1616 , insert
1717 , traverse
18− , traverse_
1918 , remove
2019 -- * Internal functions
2120 -- These will not always be available.
2221 , _weakBag_children --TODO: Don't export this
2322 ) where
2423
25−import Prelude hiding (traverse)
26−
2724import Control.Exception
28−import Control.Monad
25+import Control.Monad hiding (forM_, mapM_)
2926import Control.Monad.IO.Class
27+import Data.Foldable (forM_, mapM_)
3028import Data.IntMap.Strict (IntMap)
3129import qualified Data.IntMap.Strict as IntMap
3230import Data.IORef
3331import System.Mem.Weak
3432
35−-- | A 'WeakBag' holds a set of values of type @/a/@, but does not retain them -
36−-- that is, they can still be garbage-collected. As long as the @/a/@ values remain
33+import Prelude hiding (mapM_, traverse)
34+
35+-- | A @WeakBag a@ holds a set of values of type @a@, but does not retain them -
36+-- that is, they can still be garbage-collected. As long as the @a@s remain
3737-- alive, the 'WeakBag' will continue to refer to them.
3838data WeakBag a = WeakBag
3939 { _weakBag_nextId :: {-# UNPACK #-} !(IORef Int) --TODO: what if this wraps around?
@@ -100,22 +100,18 @@ singleton a wbRef finalizer = {-# SCC "singleton" #-} do
100100 ticket <- insert a bag wbRef finalizer
101101 return (bag, ticket)
102102
103−{-# INLINE traverse_ #-}
103+{-# INLINE traverse #-}
104104-- | Visit every node in the given list. If new nodes are appended during the
105105-- traversal, they will not be visited. Every live node that was in the list
106106-- when the traversal began will be visited exactly once; however, no guarantee
107107-- is made about the order of the traversal.
108−traverse_ :: MonadIO m => WeakBag a -> (a -> m ()) -> m ()
109−traverse_ (WeakBag _ children) f = {-# SCC "traverse" #-} do
108+traverse :: MonadIO m => WeakBag a -> (a -> m ()) -> m ()
109+traverse (WeakBag _ children) f = {-# SCC "traverse" #-} do
110110 cs <- liftIO $ readIORef children
111111 forM_ cs $ \c -> do
112112 ma <- liftIO $ deRefWeak c
113113 mapM_ f ma
114114
115−{-# DEPRECATED traverse "Use 'traverse_' instead" #-}
116−traverse :: MonadIO m => WeakBag a -> (a -> m ()) -> m ()
117−traverse = traverse_
118−
119115-- | Remove an item from the 'WeakBag'; does nothing if invoked multiple times
120116-- on the same 'WeakBagTicket'.
121117{-# INLINE remove #-}
src/Reflex.hs−4
@@ -6,9 +6,6 @@ module Reflex
66 ) where
77
88import Reflex.Class as X
9−import Reflex.Adjustable.Class as X
10−import Reflex.BehaviorWriter.Base as X
11−import Reflex.BehaviorWriter.Class as X
129import Reflex.Collection as X
1310import Reflex.Dynamic as X
1411import Reflex.EventWriter.Base as X
@@ -19,7 +16,6 @@ import Reflex.Dynamic.TH as X
1916import Reflex.Dynamic.Uniq as X
2017import Reflex.DynamicWriter.Base as X
2118import Reflex.DynamicWriter.Class as X
22−import Reflex.NotReady.Class as X
2319import Reflex.PerformEvent.Base as X
2420import Reflex.PerformEvent.Class as X
2521import Reflex.PostBuild.Base as X
src/Reflex/Adjustable/Class.hs+15−84
@@ -1,8 +1,7 @@
11{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
32{-# LANGUAGE FlexibleInstances #-}
43{-# LANGUAGE FunctionalDependencies #-}
5−{-# LANGUAGE LambdaCase #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
65{-# LANGUAGE RankNTypes #-}
76{-# LANGUAGE ScopedTypeVariables #-}
87{-# LANGUAGE TypeFamilies #-}
@@ -10,13 +9,6 @@
109#ifdef USE_REFLEX_OPTIMIZER
1110{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
1211#endif
13−-- |
14−-- Module:
15−-- Reflex.Adjustable.Class
16−-- Description:
17−-- A class for actions that can be "adjusted" over time based on some 'Event'
18−-- such that, when observed after the firing of any such 'Event', the result
19−-- is as though the action was originally run with the 'Event's value.
2012module Reflex.Adjustable.Class
2113 (
2214 -- * The Adjustable typeclass
@@ -24,23 +16,22 @@ module Reflex.Adjustable.Class
2416 , sequenceDMapWithAdjust
2517 , sequenceDMapWithAdjustWithMove
2618 , mapMapWithAdjustWithMove
27− -- * Deprecated aliases
28− , MonadAdjust
2919 ) where
3020
3121import Control.Monad.Identity
3222import Control.Monad.Reader
33−import Data.Dependent.Map (DMap)
34−import Data.GADT.Compare (GCompare(..))
35−import qualified Data.Dependent.Map as DMap
23+import Data.Align
24+import Data.Dependent.Map (DMap, GCompare (..))
3625import Data.Functor.Constant
3726import Data.Functor.Misc
38−import Data.IntMap.Strict (IntMap)
39−import qualified Data.IntMap.Strict as IntMap
4027import Data.Map (Map)
28+import qualified Data.Map as Map
29+import Data.Map.Misc
30+import Data.These
4131
4232import Reflex.Class
43−import Data.Patch.DMapWithMove
33+import Reflex.Dynamic
34+import Reflex.PostBuild.Class
4435
4536-- | A 'Monad' that supports adjustment over time. After an action has been
4637-- run, if the given events fire, it will adjust itself so that its net effect
@@ -49,43 +40,10 @@ import Data.Patch.DMapWithMove
4940-- other side-effects) cannot be undone, so it is up to the instance implementer
5041-- to determine what the best meaning for this class is in such cases.
5142class (Reflex t, Monad m) => Adjustable t m | m -> t where
52− runWithReplace
53− :: m a
54− -> Event t (m b)
55− -> m (a, Event t b)
56−
57− traverseIntMapWithKeyWithAdjust
58− :: (IntMap.Key -> v -> m v')
59− -> IntMap v
60− -> Event t (PatchIntMap v)
61− -> m (IntMap v', Event t (PatchIntMap v'))
62−
63− traverseDMapWithKeyWithAdjust
64− :: GCompare k
65− => (forall a. k a -> v a -> m (v' a))
66− -> DMap k v
67− -> Event t (PatchDMap k v)
68− -> m (DMap k v', Event t (PatchDMap k v'))
69− {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
70− traverseDMapWithKeyWithAdjust f dm0 dm' = fmap (fmap (fmap fromPatchWithMove)) $
71− traverseDMapWithKeyWithAdjustWithMove f dm0 $ fmap toPatchWithMove dm'
72− where
73− toPatchWithMove (PatchDMap m) = PatchDMapWithMove $ DMap.map toNodeInfoWithMove m
74− toNodeInfoWithMove = \case
75− ComposeMaybe (Just v) -> NodeInfo (From_Insert v) $ ComposeMaybe Nothing
76− ComposeMaybe Nothing -> NodeInfo From_Delete $ ComposeMaybe Nothing
77− fromPatchWithMove (PatchDMapWithMove m) = PatchDMap $ DMap.map fromNodeInfoWithMove m
78− fromNodeInfoWithMove (NodeInfo from _) = ComposeMaybe $ case from of
79− From_Insert v -> Just v
80− From_Delete -> Nothing
81− From_Move _ -> error "traverseDMapWithKeyWithAdjust: implementation of traverseDMapWithKeyWithAdjustWithMove inserted spurious move"
82−
83− traverseDMapWithKeyWithAdjustWithMove
84− :: GCompare k
85− => (forall a. k a -> v a -> m (v' a))
86− -> DMap k v
87− -> Event t (PatchDMapWithMove k v)
88− -> m (DMap k v', Event t (PatchDMapWithMove k v'))
43+ runWithReplace :: m a -> Event t (m b) -> m (a, Event t b)
44+ traverseIntMapWithKeyWithAdjust :: (IntMap.Key -> v -> m v') -> IntMap v -> Event t (PatchIntMap v) -> m (IntMap v', Event t (PatchIntMap v'))
45+ traverseDMapWithKeyWithAdjust :: GCompare k => (forall a. k a -> v a -> m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> m (DMap k v', Event t (PatchDMap k v'))
46+ traverseDMapWithKeyWithAdjustWithMove :: GCompare k => (forall a. k a -> v a -> m (v' a)) -> DMap k v -> Event t (PatchDMapWithMove k v) -> m (DMap k v', Event t (PatchDMapWithMove k v'))
8947
9048instance Adjustable t m => Adjustable t (ReaderT r m) where
9149 runWithReplace a0 a' = do
@@ -101,40 +59,13 @@ instance Adjustable t m => Adjustable t (ReaderT r m) where
10159 r <- ask
10260 lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runReaderT (f k v) r) dm0 dm'
10361
104−-- | Traverse a 'DMap' of 'Adjustable' actions, running each of them. The provided 'Event' of patches
105−-- to the 'DMap' can add, remove, or update values.
106−sequenceDMapWithAdjust
107− :: (GCompare k, Adjustable t m)
108− => DMap k m
109− -> Event t (PatchDMap k m)
110− -> m (DMap k Identity, Event t (PatchDMap k Identity))
62+sequenceDMapWithAdjust :: (GCompare k, Adjustable t m) => DMap k m -> Event t (PatchDMap k m) -> m (DMap k Identity, Event t (PatchDMap k Identity))
11163sequenceDMapWithAdjust = traverseDMapWithKeyWithAdjust $ \_ -> fmap Identity
11264
113−-- | Traverses a 'DMap' of 'Adjustable' actions, running each of them. The provided 'Event' of patches
114−-- to the 'DMap' can add, remove, update, move, or swap values.
115−sequenceDMapWithAdjustWithMove
116− :: (GCompare k, Adjustable t m)
117− => DMap k m
118− -> Event t (PatchDMapWithMove k m)
119− -> m (DMap k Identity, Event t (PatchDMapWithMove k Identity))
65+sequenceDMapWithAdjustWithMove :: (GCompare k, Adjustable t m) => DMap k m -> Event t (PatchDMapWithMove k m) -> m (DMap k Identity, Event t (PatchDMapWithMove k Identity))
12066sequenceDMapWithAdjustWithMove = traverseDMapWithKeyWithAdjustWithMove $ \_ -> fmap Identity
12167
122−-- | Traverses a 'Map', running the provided 'Adjustable' action. The provided 'Event' of patches to the 'Map'
123−-- can add, remove, update, move, or swap values.
124−mapMapWithAdjustWithMove
125− :: forall t m k v v'. (Adjustable t m, Ord k)
126− => (k -> v -> m v')
127− -> Map k v
128− -> Event t (PatchMapWithMove k v)
129− -> m (Map k v', Event t (PatchMapWithMove k v'))
68+mapMapWithAdjustWithMove :: forall t m k v v'. (Adjustable t m, Ord k) => (k -> v -> m v') -> Map k v -> Event t (PatchMapWithMove k v) -> m (Map k v', Event t (PatchMapWithMove k v'))
13069mapMapWithAdjustWithMove f m0 m' = do
13170 (out0 :: DMap (Const2 k v) (Constant v'), out') <- traverseDMapWithKeyWithAdjustWithMove (\(Const2 k) (Identity v) -> Constant <$> f k v) (mapToDMap m0) (const2PatchDMapWithMoveWith Identity <$> m')
13271 return (dmapToMapWith (\(Constant v') -> v') out0, patchDMapWithMoveToPatchMapWithMoveWith (\(Constant v') -> v') <$> out')
133−
134−--------------------------------------------------------------------------------
135−-- Deprecated functions
136−--------------------------------------------------------------------------------
137−
138−{-# DEPRECATED MonadAdjust "Use Adjustable instead" #-}
139−-- | Synonym for 'Adjustable'
140−type MonadAdjust = Adjustable
src/Reflex/BehaviorWriter/Base.hsdeleted−211
@@ -1,211 +0,0 @@
1−{-|
2−Module: Reflex.BehaviorWriter.Base
3−Description: Implementation of BehaviorWriter
4−-}
5−{-# LANGUAGE CPP #-}
6−{-# LANGUAGE FlexibleInstances #-}
7−{-# LANGUAGE GADTs #-}
8−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9−{-# LANGUAGE MultiParamTypeClasses #-}
10−{-# LANGUAGE RankNTypes #-}
11−{-# LANGUAGE ScopedTypeVariables #-}
12−{-# LANGUAGE TypeFamilies #-}
13−{-# LANGUAGE UndecidableInstances #-}
14−{-# LANGUAGE StandaloneDeriving #-}
15−#ifdef USE_REFLEX_OPTIMIZER
16−{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
17−#endif
18−module Reflex.BehaviorWriter.Base
19− ( BehaviorWriterT (..)
20− , runBehaviorWriterT
21− , withBehaviorWriterT
22− ) where
23−
24−import Control.Monad.Exception
25−import Control.Monad.Identity
26−import Control.Monad.IO.Class
27−import Control.Monad.Morph
28−import Control.Monad.Reader
29−import Control.Monad.Ref
30−import Control.Monad.State.Strict
31−import Data.Dependent.Map (DMap)
32−import qualified Data.Dependent.Map as DMap
33−import Data.Functor.Misc
34−import Data.IntMap (IntMap)
35−import qualified Data.IntMap as IntMap
36−import Data.Map (Map)
37−import qualified Data.Map as Map
38−import Data.Some (Some)
39−
40−import Reflex.Class
41−import Reflex.Adjustable.Class
42−import Reflex.BehaviorWriter.Class
43−import Reflex.Host.Class
44−import Reflex.PerformEvent.Class
45−import Reflex.PostBuild.Class
46−import Reflex.Query.Class
47−import Reflex.Requester.Class
48−import Reflex.TriggerEvent.Class
49−
50−-- | A basic implementation of 'BehaviorWriter'.
51−newtype BehaviorWriterT t w m a = BehaviorWriterT { unBehaviorWriterT :: StateT [Behavior t w] m a }
52− -- The list is kept in reverse order
53− deriving
54− ( Functor
55− , Applicative
56− , Monad
57− , MonadTrans
58− , MFunctor
59− , MonadIO
60− , MonadFix
61− , MonadAsyncException
62− , MonadException
63− )
64−
65−-- | Run a 'BehaviorWriterT' action. The behavior writer output will be provided
66−-- along with the result of the action.
67−runBehaviorWriterT :: (Monad m, Reflex t, Monoid w) => BehaviorWriterT t w m a -> m (a, Behavior t w)
68−runBehaviorWriterT (BehaviorWriterT a) = do
69− (result, ws) <- runStateT a []
70− return (result, mconcat $ reverse ws)
71−
72−-- | Map a function over the output of a 'BehaviorWriterT'.
73−withBehaviorWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m)
74− => (w -> w')
75− -> BehaviorWriterT t w m a
76− -> BehaviorWriterT t w' m a
77−withBehaviorWriterT f dw = do
78− (r, d) <- lift $ do
79− (r, d) <- runBehaviorWriterT dw
80− let d' = fmap f d
81− return (r, d')
82− tellBehavior d
83− return r
84−
85−deriving instance MonadHold t m => MonadHold t (BehaviorWriterT t w m)
86−deriving instance MonadSample t m => MonadSample t (BehaviorWriterT t w m)
87−
88−instance MonadRef m => MonadRef (BehaviorWriterT t w m) where
89− type Ref (BehaviorWriterT t w m) = Ref m
90− newRef = lift . newRef
91− readRef = lift . readRef
92− writeRef r = lift . writeRef r
93−
94−instance MonadAtomicRef m => MonadAtomicRef (BehaviorWriterT t w m) where
95− atomicModifyRef r = lift . atomicModifyRef r
96−
97−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (BehaviorWriterT t w m) where
98− newEventWithTrigger = lift . newEventWithTrigger
99− newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
100−
101−instance (Monad m, Monoid w, Reflex t) => BehaviorWriter t w (BehaviorWriterT t w m) where
102− tellBehavior w = BehaviorWriterT $ modify (w :)
103−
104−instance MonadReader r m => MonadReader r (BehaviorWriterT t w m) where
105− ask = lift ask
106− local f (BehaviorWriterT a) = BehaviorWriterT $ mapStateT (local f) a
107− reader = lift . reader
108−
109−instance PerformEvent t m => PerformEvent t (BehaviorWriterT t w m) where
110− type Performable (BehaviorWriterT t w m) = Performable m
111− performEvent_ = lift . performEvent_
112− performEvent = lift . performEvent
113−
114−instance TriggerEvent t m => TriggerEvent t (BehaviorWriterT t w m) where
115− newTriggerEvent = lift newTriggerEvent
116− newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
117− newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
118−
119−instance PostBuild t m => PostBuild t (BehaviorWriterT t w m) where
120− getPostBuild = lift getPostBuild
121−
122−instance MonadState s m => MonadState s (BehaviorWriterT t w m) where
123− get = lift get
124− put = lift . put
125−
126−instance Requester t m => Requester t (BehaviorWriterT t w m) where
127− type Request (BehaviorWriterT t w m) = Request m
128− type Response (BehaviorWriterT t w m) = Response m
129− requesting = lift . requesting
130− requesting_ = lift . requesting_
131−
132−instance (MonadQuery t q m, Monad m) => MonadQuery t q (BehaviorWriterT t w m) where
133− tellQueryIncremental = lift . tellQueryIncremental
134− askQueryResult = lift askQueryResult
135− queryIncremental = lift . queryIncremental
136−
137−instance (Adjustable t m, Monoid w, MonadHold t m, Reflex t) => Adjustable t (BehaviorWriterT t w m) where
138− runWithReplace a0 a' = do
139− (result0, result') <- lift $ runWithReplace (runBehaviorWriterT a0) $ runBehaviorWriterT <$> a'
140− tellBehavior . join =<< hold (snd result0) (snd <$> result')
141− return (fst result0, fst <$> result')
142− traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustImpl traverseIntMapWithKeyWithAdjust
143− traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove weakenPatchDMapWithMoveWith
144−
145−traverseIntMapWithKeyWithAdjustImpl
146− :: forall t w v' p p' v m.
147− ( PatchTarget (p' (Behavior t w)) ~ IntMap (Behavior t w)
148− , Patch (p' (Behavior t w))
149− , Monoid w
150− , Reflex t
151− , MonadHold t m
152− , Functor p
153− , p ~ p'
154− )
155− => ( (IntMap.Key -> v -> m (v', Behavior t w))
156− -> IntMap v
157− -> Event t (p v)
158− -> m (IntMap (v', Behavior t w), Event t (p (v', Behavior t w)))
159− )
160− -> (IntMap.Key -> v -> BehaviorWriterT t w m v')
161− -> IntMap v
162− -> Event t (p v)
163− -> BehaviorWriterT t w m (IntMap v', Event t (p v'))
164−traverseIntMapWithKeyWithAdjustImpl base f (dm0 :: IntMap v) dm' = do
165− (result0, result') <- lift $ base (\k v -> runBehaviorWriterT $ f k v) dm0 dm'
166− let liftedResult0 = fmap fst result0
167− liftedResult' = fmap (fmap fst) result'
168− liftedWritten0 :: IntMap (Behavior t w)
169− liftedWritten0 = fmap snd result0
170− liftedWritten' = fmap (fmap snd) result'
171− i <- holdIncremental liftedWritten0 liftedWritten'
172− tellBehavior $ pull $ do
173− m <- sample $ currentIncremental i
174− mconcat . IntMap.elems <$> traverse sample m
175− return (liftedResult0, liftedResult')
176−
177−newtype BehaviorWriterTLoweredResult t w v a = BehaviorWriterTLoweredResult (v a, Behavior t w)
178−
179−traverseDMapWithKeyWithAdjustImpl
180− :: forall t w k v' p p' v m.
181− ( PatchTarget (p' (Some k) (Behavior t w)) ~ Map (Some k) (Behavior t w)
182− , Patch (p' (Some k) (Behavior t w))
183− , Monoid w
184− , Reflex t
185− , MonadHold t m
186− )
187− => ( (forall a. k a -> v a -> m (BehaviorWriterTLoweredResult t w v' a))
188− -> DMap k v
189− -> Event t (p k v)
190− -> m (DMap k (BehaviorWriterTLoweredResult t w v'), Event t (p k (BehaviorWriterTLoweredResult t w v')))
191− )
192− -> ((forall a. BehaviorWriterTLoweredResult t w v' a -> v' a) -> p k (BehaviorWriterTLoweredResult t w v') -> p k v')
193− -> ((forall a. BehaviorWriterTLoweredResult t w v' a -> Behavior t w) -> p k (BehaviorWriterTLoweredResult t w v') -> p' (Some k) (Behavior t w))
194− -> (forall a. k a -> v a -> BehaviorWriterT t w m (v' a))
195− -> DMap k v
196− -> Event t (p k v)
197− -> BehaviorWriterT t w m (DMap k v', Event t (p k v'))
198−traverseDMapWithKeyWithAdjustImpl base mapPatch weakenPatchWith f (dm0 :: DMap k v) dm' = do
199− (result0, result') <- lift $ base (\k v -> fmap BehaviorWriterTLoweredResult $ runBehaviorWriterT $ f k v) dm0 dm'
200− let getValue (BehaviorWriterTLoweredResult (v, _)) = v
201− getWritten (BehaviorWriterTLoweredResult (_, w)) = w
202− liftedResult0 = DMap.map getValue result0
203− liftedResult' = ffor result' $ mapPatch getValue
204− liftedWritten0 :: Map (Some k) (Behavior t w)
205− liftedWritten0 = weakenDMapWith getWritten result0
206− liftedWritten' = ffor result' $ weakenPatchWith getWritten
207− i <- holdIncremental liftedWritten0 liftedWritten'
208− tellBehavior $ pull $ do
209− m <- sample $ currentIncremental i
210− mconcat . Map.elems <$> traverse sample m
211− return (liftedResult0, liftedResult')
src/Reflex/BehaviorWriter/Class.hsdeleted−31
@@ -1,31 +0,0 @@
1−{-|
2−Module: Reflex.BehaviorWriter.Class
3−Description: This module defines the 'BehaviorWriter' class
4−-}
5−{-# LANGUAGE CPP #-}
6−{-# LANGUAGE ConstraintKinds #-}
7−{-# LANGUAGE FlexibleInstances #-}
8−{-# LANGUAGE FunctionalDependencies #-}
9−{-# LANGUAGE UndecidableInstances #-}
10−#ifdef USE_REFLEX_OPTIMIZER
11−{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
12−#endif
13−module Reflex.BehaviorWriter.Class
14− ( MonadBehaviorWriter
15− , BehaviorWriter(..)
16− ) where
17−
18−import Control.Monad.Reader (ReaderT, lift)
19−import Reflex.Class (Behavior)
20−
21−{-# DEPRECATED MonadBehaviorWriter "Use 'BehaviorWriter' instead" #-}
22−-- | Type synonym for 'BehaviorWriter'
23−type MonadBehaviorWriter = BehaviorWriter
24−
25−-- | 'BehaviorWriter' efficiently collects 'Behavior' values using 'tellBehavior'
26−-- and combines them monoidally to provide a 'Behavior' result.
27−class (Monad m, Monoid w) => BehaviorWriter t w m | m -> t w where
28− tellBehavior :: Behavior t w -> m ()
29−
30−instance BehaviorWriter t w m => BehaviorWriter t w (ReaderT r m) where
31− tellBehavior = lift . tellBehavior
src/Reflex/Class.hs+203−718
@@ -7,8 +7,8 @@
77{-# LANGUAGE FunctionalDependencies #-}
88{-# LANGUAGE GADTs #-}
99{-# LANGUAGE LambdaCase #-}
10+{-# LANGUAGE MultiParamTypeClasses #-}
1011{-# LANGUAGE NoMonomorphismRestriction #-}
11−{-# LANGUAGE PolyKinds #-}
1212{-# LANGUAGE RankNTypes #-}
1313{-# LANGUAGE RecursiveDo #-}
1414{-# LANGUAGE RoleAnnotations #-}
@@ -16,56 +16,42 @@
1616{-# LANGUAGE TypeFamilies #-}
1717{-# LANGUAGE TypeOperators #-}
1818{-# LANGUAGE UndecidableInstances #-}
19−{-# LANGUAGE Trustworthy #-}
2019#ifdef USE_REFLEX_OPTIMIZER
2120{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
2221#endif
2322
24−-- |
25−-- Module:
26−-- Reflex.Class
27−-- Description:
28−-- This module contains the Reflex interface, as well as a variety of
29−-- convenience functions for working with 'Event's, 'Behavior's, and other
30−-- signals.
23+-- | This module contains the Reflex interface, as well as a variety of
24+-- convenience functions for working with 'Event's, 'Behavior's, and other
25+-- signals.
3126module Reflex.Class
32− ( module Data.Patch
27+ ( module Reflex.Patch
3328 -- * Primitives
3429 , Reflex (..)
3530 , mergeInt
3631 , coerceBehavior
3732 , coerceEvent
3833 , coerceDynamic
39− , coerceIncremental
4034 , MonadSample (..)
4135 , MonadHold (..)
42− -- ** 'fan' related types
36+ -- ** 'fan'-related types
4337 , EventSelector (..)
44− , EventSelectorG (..)
4538 , EventSelectorInt (..)
39+ -- ** 'Incremental'-related types
4640 -- * Convenience functions
4741 , constDyn
4842 , pushAlways
4943 -- ** Combining 'Event's
5044 , leftmost
51− , merge
52− , mergeIncremental
53− , mergeIncrementalWithMove
5445 , mergeMap
55− , mergeIntMap
5646 , mergeMapIncremental
5747 , mergeMapIncrementalWithMove
5848 , mergeIntMapIncremental
59− , coincidencePatchMap
60− , coincidencePatchMapWithMove
61− , coincidencePatchIntMap
6249 , mergeList
6350 , mergeWith
6451 , difference
6552 , alignEventWithMaybe
6653 -- ** Breaking up 'Event's
6754 , splitE
68− , fan
6955 , fanEither
7056 , fanThese
7157 , fanMap
@@ -73,16 +59,12 @@ module Reflex.Class
7359 , EitherTag (..)
7460 , eitherToDSum
7561 , dsumToEither
76− , factorEvent
77− , filterEventKey
7862 -- ** Collapsing 'Event . Event'
7963 , switchHold
8064 , switchHoldPromptly
8165 , switchHoldPromptOnly
82− , switchHoldPromptOnlyIncremental
8366 -- ** Using 'Event's to sample 'Behavior's
8467 , tag
85− , tagMaybe
8668 , attach
8769 , attachWith
8870 , attachWithMaybe
@@ -90,7 +72,6 @@ module Reflex.Class
9072 , gate
9173 -- ** Combining 'Dynamic's
9274 , distributeDMapOverDynPure
93− , distributeDMapOverDynPureG
9475 , distributeListOverDyn
9576 , distributeListOverDynWith
9677 , zipDyn
@@ -117,14 +98,6 @@ module Reflex.Class
11798 , mapAccumM_
11899 , mapAccumMaybe_
119100 , mapAccumMaybeM_
120− , accumIncremental
121− , accumMIncremental
122− , accumMaybeIncremental
123− , accumMaybeMIncremental
124− , mapAccumIncremental
125− , mapAccumMIncremental
126− , mapAccumMaybeIncremental
127− , mapAccumMaybeMIncremental
128101 , zipListWithEvent
129102 , numberOccurrences
130103 , numberOccurrencesFrom
@@ -134,9 +107,6 @@ module Reflex.Class
134107 , tailE
135108 , headTailE
136109 , takeWhileE
137− , takeWhileJustE
138− , dropWhileE
139− , takeDropWhileJustE
140110 , switcher
141111 -- * Debugging functions
142112 , traceEvent
@@ -144,24 +114,25 @@ module Reflex.Class
144114 -- * Unsafe functions
145115 , unsafeDynamic
146116 , unsafeMapIncremental
147− -- * 'Filterable' convenience functions
148− , FunctorMaybe -- fmapMaybe is purposely not exported from deprecated 'FunctorMaybe' and the new alias is exported instead
149− , mapMaybe -- Re-exported for convenience
150− , fmapMaybe
117+ -- * 'FunctorMaybe'
118+ , FunctorMaybe (..)
151119 , fforMaybe
152120 , ffilter
153121 , filterLeft
154122 , filterRight
123+ -- * 'Adjustable'
124+ , Adjustable(..)
125+ , sequenceDMapWithAdjust
126+ , sequenceDMapWithAdjustWithMove
127+ , mapMapWithAdjustWithMove
155128 -- * Miscellaneous convenience functions
156129 , ffor
157− , ffor2
158− , ffor3
159130 -- * Deprecated functions
160− , switchPromptly
161− , switchPromptOnly
162− -- * "Cheap" functions
131+ , MonadAdjust
132+ , appendEvents
133+ , onceE
134+ , sequenceThese
163135 , fmapMaybeCheap
164− , mapMaybeCheap
165136 , fmapCheap
166137 , fforCheap
167138 , fforMaybeCheap
@@ -169,21 +140,12 @@ module Reflex.Class
169140 , tagCheap
170141 , mergeWithCheap
171142 , mergeWithCheap'
143+ , switchPromptly
144+ , switchPromptOnly
172145 -- * Slow, but general, implementations
173146 , slowHeadE
174147 ) where
175148
176−#ifdef MIN_VERSION_semialign
177−import Prelude hiding (zip, zipWith)
178−
179−#if MIN_VERSION_these(0,8,0)
180−import Data.These.Combinators (justThese)
181−#endif
182−#if MIN_VERSION_semialign(1,1,0)
183−import Data.Zip (Zip (..), Unzip (..))
184−#endif
185−#endif
186−
187149import Control.Applicative
188150import Control.Monad.Identity
189151import Control.Monad.Reader
@@ -196,38 +158,29 @@ import Data.Align
196158import Data.Bifunctor
197159import Data.Coerce
198160import Data.Default
199−import Data.Dependent.Map (DMap)
200−import Data.Dependent.Sum (DSum (..))
161+import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
201162import qualified Data.Dependent.Map as DMap
202−import Data.Functor.Compose
203−import Data.Functor.Product
204−import Data.GADT.Compare (GEq (..), GCompare (..))
205163import Data.FastMutableIntMap (PatchIntMap)
206164import Data.Foldable
207165import Data.Functor.Bind
166+import Data.Functor.Constant
208167import Data.Functor.Misc
209168import Data.Functor.Plus
210169import Data.IntMap.Strict (IntMap)
211170import qualified Data.IntMap.Strict as IntMap
212171import Data.List.NonEmpty (NonEmpty (..))
213172import Data.Map (Map)
214−import Data.Semigroup (Semigroup (..))
215−import Data.Some (Some(Some))
173+import Data.Semigroup (Semigroup, sconcat, stimes, (<>))
216174import Data.String
217175import Data.These
218176import Data.Type.Coercion
219−import Data.Type.Equality ((:~:) (..))
220−import Data.Witherable (Filterable(..))
221−import qualified Data.Witherable as W
222−import Reflex.FunctorMaybe (FunctorMaybe)
223−import qualified Reflex.FunctorMaybe
224−import Data.Patch
225−import qualified Data.Patch.MapWithMove as PatchMapWithMove
177+import Reflex.FunctorMaybe
178+import Reflex.Patch
226179
227180import Debug.Trace (trace)
228181
229182-- | The 'Reflex' class contains all the primitive functionality needed for
230−-- Functional Reactive Programming (FRP). The @/t/@ type parameter indicates
183+-- Functional Reactive Programming (FRP). The @t@ type parameter indicates
231184-- which "timeline" is in use. Timelines are fully-independent FRP contexts,
232185-- and the type of the timeline determines the FRP engine to be used. For most
233186-- purposes, the 'Reflex.Spider' implementation is recommended.
@@ -273,23 +226,18 @@ class ( MonadHold t (PushM t)
273226 -- recomputed whenever any of the read 'Behavior's changes
274227 pull :: PullM t a -> Behavior t a
275228 -- | Merge a collection of events; the resulting 'Event' will only occur if at
276− -- least one input event is occurring, and will contain all of the input keys
229+ -- least one input event is occuring, and will contain all of the input keys
277230 -- that are occurring simultaneously
278−
279− --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty
280− mergeG :: GCompare k => (forall a. q a -> Event t (v a))
281− -> DMap k q -> Event t (DMap k v)
282−
283− -- | Efficiently fan-out an event to many destinations. You should save the
284− -- result in a @let@-binding, and then repeatedly 'selectG' on the result to
285− -- create child events
286− fanG :: GCompare k => Event t (DMap k v) -> EventSelectorG t k v
287−
231+ merge :: GCompare k => DMap k (Event t) -> Event t (DMap k Identity) --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty
232+ -- | Efficiently fan-out an event to many destinations. This function should
233+ -- be partially applied, and then the result applied repeatedly to create
234+ -- child events
235+ fan :: GCompare k => Event t (DMap k Identity) -> EventSelector t k --TODO: Can we help enforce the partial application discipline here? The combinator is worthless without it
288236 -- | Create an 'Event' that will occur whenever the currently-selected input
289237 -- 'Event' occurs
290238 switch :: Behavior t (Event t a) -> Event t a
291− -- | Create an 'Event' that will occur whenever the input event is occurring -- and its occurrence value, another 'Event', is also occurring.
292− -- You maybe looking for '@switchHold@ @never@' instead.
239+ -- | Create an 'Event' that will occur whenever the input event is occurring
240+ -- and its occurrence value, another 'Event', is also occurring
293241 coincidence :: Event t (Event t a) -> Event t a
294242 -- | Extract the 'Behavior' of a 'Dynamic'.
295243 current :: Dynamic t a -> Behavior t a
@@ -298,19 +246,14 @@ class ( MonadHold t (PushM t)
298246 -- | Create a new 'Dynamic'. The given 'PullM' must always return the most
299247 -- recent firing of the given 'Event', if any.
300248 unsafeBuildDynamic :: PullM t a -> Event t a -> Dynamic t a
301− -- | Create a new 'Incremental'. The given "PullM"'s value must always change
249+ -- | Create a new 'Incremental'. The given 'PullM''s value must always change
302250 -- in the same way that the accumulated application of patches would change
303251 -- that value.
304252 unsafeBuildIncremental :: Patch p => PullM t (PatchTarget p) -> Event t p -> Incremental t p
305253 -- | Create a merge whose parents can change over time
306− mergeIncrementalG :: GCompare k
307− => (forall a. q a -> Event t (v a))
308− -> Incremental t (PatchDMap k q)
309− -> Event t (DMap k v)
254+ mergeIncremental :: GCompare k => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)
310255 -- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental
311− mergeIncrementalWithMoveG :: GCompare k
312− => (forall a. q a -> Event t (v a))
313− -> Incremental t (PatchDMapWithMove k q) -> Event t (DMap k v)
256+ mergeIncrementalWithMove :: GCompare k => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)
314257 -- | Extract the 'Behavior' component of an 'Incremental'
315258 currentIncremental :: Patch p => Incremental t p -> Behavior t (PatchTarget p)
316259 -- | Extract the 'Event' component of an 'Incremental'
@@ -326,28 +269,10 @@ class ( MonadHold t (PushM t)
326269 -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its
327270 -- occurrence type
328271 dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)
329− -- | Construct a 'Coercion' for an 'Incremental' given 'Coercion's for its
330− -- patch target and patch types.
331− incrementalCoercion
332− :: Coercion (PatchTarget a) (PatchTarget b) -> Coercion a b -> Coercion (Incremental t a) (Incremental t b)
333272 mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)
334273 fanInt :: Event t (IntMap a) -> EventSelectorInt t a
335274
336−-- | Efficiently fan-out an event to many destinations. You should save the
337−-- result in a @let@-binding, and then repeatedly 'select' on the result to
338−-- create child events
339−fan :: forall t k. (Reflex t, GCompare k)
340− => Event t (DMap k Identity) -> EventSelector t k
341− --TODO: Can we help enforce the partial application discipline here? The combinator is worthless without it
342−fan e = EventSelector (fixup (selectG (fanG e) :: k a -> Event t (Identity a)) :: forall a. k a -> Event t a)
343− where
344− fixup :: forall a. (k a -> Event t (Identity a)) -> k a -> Event t a
345− fixup = case eventCoercion Coercion :: Coercion (Event t (Identity a)) (Event t a) of
346− Coercion -> coerce
347−
348275--TODO: Specialize this so that we can take advantage of knowing that there's no changing going on
349−-- | Constructs a single 'Event' out of a map of events. The output event may fire with multiple
350−-- keys simultaneously.
351276mergeInt :: Reflex t => IntMap (Event t a) -> Event t (IntMap a)
352277mergeInt m = mergeIntIncremental $ unsafeBuildIncremental (return m) never
353278
@@ -363,14 +288,8 @@ coerceEvent = coerceWith $ eventCoercion Coercion
363288coerceDynamic :: (Reflex t, Coercible a b) => Dynamic t a -> Dynamic t b
364289coerceDynamic = coerceWith $ dynamicCoercion Coercion
365290
366−-- | Coerce an 'Incremental' between representationally-equivalent value types
367−coerceIncremental
368− :: (Reflex t, Coercible a b, Coercible (PatchTarget a) (PatchTarget b))
369− => Incremental t a -> Incremental t b
370−coerceIncremental = coerceWith $ incrementalCoercion Coercion Coercion
371−
372291-- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'. The 'Behavior'
373−-- __must__ change when and only when the 'Event' fires, such that the
292+-- _must_ change when and only when the 'Event' fires, such that the
374293-- 'Behavior''s value is always equal to the most recent firing of the 'Event';
375294-- if this is not the case, the resulting 'Dynamic' will behave
376295-- nondeterministically.
@@ -398,7 +317,7 @@ class MonadSample t m => MonadHold t m where
398317 -- value and will be updated whenever the given 'Event' occurs. The update
399318 -- takes effect immediately after the 'Event' occurs; if the occurrence that
400319 -- sets the 'Behavior' (or one that is simultaneous with it) is used to sample
401− -- the 'Behavior', it will see the __old__ value of the 'Behavior', not the new
320+ -- the 'Behavior', it will see the _old_ value of the 'Behavior', not the new
402321 -- one.
403322 hold :: a -> Event t a -> m (Behavior t a)
404323 default hold :: (m ~ f m', MonadTrans f, MonadHold t m') => a -> Event t a -> m (Behavior t a)
@@ -413,118 +332,16 @@ class MonadSample t m => MonadHold t m where
413332 holdIncremental :: Patch p => PatchTarget p -> Event t p -> m (Incremental t p)
414333 default holdIncremental :: (Patch p, m ~ f m', MonadTrans f, MonadHold t m') => PatchTarget p -> Event t p -> m (Incremental t p)
415334 holdIncremental v0 = lift . holdIncremental v0
416− buildDynamic :: PushM t a -> Event t a -> m (Dynamic t a)
335+ buildDynamic :: PullM t a -> Event t a -> m (Dynamic t a)
417336 {-
418337 default buildDynamic :: (m ~ f m', MonadTrans f, MonadHold t m') => PullM t a -> Event t a -> m (Dynamic t a)
419338 buildDynamic getV0 = lift . buildDynamic getV0
420339 -}
421− -- | Create a new 'Event' that only occurs only once, on the first occurrence of
340+ -- | Create a new 'Event' that only occurs only once, on the first occurence of
422341 -- the supplied 'Event'.
423342 headE :: Event t a -> m (Event t a)
424− -- | An event which only occurs at the current moment in time, such that:
425− --
426− -- > coincidence (pushAlways (\a -> (a <$) <$> now) e) = e
427− --
428− now :: m (Event t ())
429− default now :: (m ~ f m', MonadTrans f, MonadHold t m') => m (Event t ())
430− now = lift now
431−
432−-- | Accumulate an 'Incremental' with the supplied initial value and the firings of the provided 'Event',
433−-- using the combining function to produce a patch.
434−accumIncremental
435− :: (Reflex t, Patch p, MonadHold t m, MonadFix m)
436− => (PatchTarget p -> b -> p)
437− -> PatchTarget p
438− -> Event t b
439− -> m (Incremental t p)
440−accumIncremental f = accumMaybeIncremental $ \v o -> Just $ f v o
441−
442−-- | Similar to 'accumIncremental' but the combining function runs in 'PushM'
443−accumMIncremental
444− :: (Reflex t, Patch p, MonadHold t m, MonadFix m)
445− => (PatchTarget p -> b -> PushM t p)
446− -> PatchTarget p
447− -> Event t b
448− -> m (Incremental t p)
449−accumMIncremental f = accumMaybeMIncremental $ \v o -> Just <$> f v o
450−
451−-- | Similar to 'accumIncremental' but allows filtering of updates (by dropping updates when the
452−-- combining function produces @Nothing@)
453−accumMaybeIncremental
454− :: (Reflex t, Patch p, MonadHold t m, MonadFix m)
455− => (PatchTarget p -> b -> Maybe p)
456− -> PatchTarget p
457− -> Event t b
458− -> m (Incremental t p)
459−accumMaybeIncremental f = accumMaybeMIncremental $ \v o -> return $ f v o
460−
461−-- | Similar to 'accumMaybeMIncremental' but the combining function runs in 'PushM'
462−accumMaybeMIncremental
463− :: (Reflex t, Patch p, MonadHold t m, MonadFix m)
464− => (PatchTarget p -> b -> PushM t (Maybe p))
465− -> PatchTarget p
466− -> Event t b
467− -> m (Incremental t p)
468−accumMaybeMIncremental f z e = do
469− rec let e' = flip push e $ \o -> do
470− v <- sample $ currentIncremental d'
471− f v o
472− d' <- holdIncremental z e'
473− return d'
474343
475−-- | Accumulate an 'Incremental' by folding occurrences of an 'Event'
476−-- with a function that both accumulates and produces a value to fire
477−-- as an 'Event'. Returns both the accumulated value and the constructed
478−-- 'Event'.
479−mapAccumIncremental
480− :: (Reflex t, Patch p, MonadHold t m, MonadFix m)
481− => (PatchTarget p -> b -> (p, c))
482− -> PatchTarget p
483− -> Event t b
484− -> m (Incremental t p, Event t c)
485−mapAccumIncremental f = mapAccumMaybeIncremental $ \v o -> bimap Just Just $ f v o
486−
487−-- | Like 'mapAccumIncremental' but the combining function runs in 'PushM'
488−mapAccumMIncremental
489− :: (Reflex t, Patch p, MonadHold t m, MonadFix m)
490− => (PatchTarget p -> b -> PushM t (p, c))
491− -> PatchTarget p
492− -> Event t b
493− -> m (Incremental t p, Event t c)
494−mapAccumMIncremental f = mapAccumMaybeMIncremental $ \v o -> bimap Just Just <$> f v o
495−
496−-- | Accumulate an 'Incremental' by folding occurrences of an 'Event' with
497−-- a function that both optionally accumulates and optionally produces
498−-- a value to fire as a separate output 'Event'.
499−-- Note that because 'Nothing's are discarded in both cases, the output
500−-- 'Event' may fire even though the output 'Incremental' has not changed, and
501−-- the output 'Incremental' may update even when the output 'Event' is not firing.
502−mapAccumMaybeIncremental
503− :: (Reflex t, Patch p, MonadHold t m, MonadFix m)
504− => (PatchTarget p -> b -> (Maybe p, Maybe c))
505− -> PatchTarget p
506− -> Event t b
507− -> m (Incremental t p, Event t c)
508−mapAccumMaybeIncremental f = mapAccumMaybeMIncremental $ \v o -> return $ f v o
509−
510−-- | Like 'mapAccumMaybeIncremental' but the combining function is a 'PushM' action
511−mapAccumMaybeMIncremental
512− :: (Reflex t, Patch p, MonadHold t m, MonadFix m)
513− => (PatchTarget p -> b -> PushM t (Maybe p, Maybe c))
514− -> PatchTarget p
515− -> Event t b
516− -> m (Incremental t p, Event t c)
517−mapAccumMaybeMIncremental f z e = do
518− rec let e' = flip push e $ \o -> do
519− v <- sample $ currentIncremental d'
520− result <- f v o
521− return $ case result of
522− (Nothing, Nothing) -> Nothing
523− _ -> Just result
524− d' <- holdIncremental z $ mapMaybe fst e'
525− return (d', mapMaybe snd e')
526344
527−-- | A somewhat slow implementation of 'headE'
528345slowHeadE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
529346slowHeadE e = do
530347 rec be <- hold e $ fmapCheap (const never) e'
@@ -533,31 +350,18 @@ slowHeadE e = do
533350
534351-- | An 'EventSelector' allows you to efficiently 'select' an 'Event' based on a
535352-- key. This is much more efficient than filtering for each key with
536−-- 'mapMaybe'.
353+-- 'fmapMaybe'.
537354newtype EventSelector t k = EventSelector
538355 { -- | Retrieve the 'Event' for the given key. The type of the 'Event' is
539356 -- determined by the type of the key, so this can be used to fan-out
540357 -- 'Event's whose sub-'Event's have different types.
541358 --
542359 -- Using 'EventSelector's and the 'fan' primitive is far more efficient than
543− -- (but equivalent to) using 'mapMaybe' to select only the relevant
360+ -- (but equivalent to) using 'fmapMaybe' to select only the relevant
544361 -- occurrences of an 'Event'.
545362 select :: forall a. k a -> Event t a
546363 }
547364
548−newtype EventSelectorG t k v = EventSelectorG
549− { -- | Retrieve the 'Event' for the given key. The type of the 'Event' is
550− -- determined by the type of the key, so this can be used to fan-out
551− -- 'Event's whose sub-'Event's have different types.
552− --
553− -- Using 'EventSelector's and the 'fan' primitive is far more efficient than
554− -- (but equivalent to) using 'mapMaybe' to select only the relevant
555− -- occurrences of an 'Event'.
556− selectG :: forall a. k a -> Event t (v a)
557− }
558−
559−-- | Efficiently select an 'Event' keyed on 'Int'. This is more efficient than manually
560−-- filtering by key.
561365newtype EventSelectorInt t a = EventSelectorInt { selectInt :: Int -> Event t a }
562366
563367--------------------------------------------------------------------------------
@@ -573,7 +377,6 @@ instance MonadHold t m => MonadHold t (ReaderT r m) where
573377 holdIncremental a0 = lift . holdIncremental a0
574378 buildDynamic a0 = lift . buildDynamic a0
575379 headE = lift . headE
576− now = lift now
577380
578381instance (MonadSample t m, Monoid r) => MonadSample t (WriterT r m) where
579382 sample = lift . sample
@@ -584,7 +387,6 @@ instance (MonadHold t m, Monoid r) => MonadHold t (WriterT r m) where
584387 holdIncremental a0 = lift . holdIncremental a0
585388 buildDynamic a0 = lift . buildDynamic a0
586389 headE = lift . headE
587− now = lift now
588390
589391instance MonadSample t m => MonadSample t (StateT s m) where
590392 sample = lift . sample
@@ -595,7 +397,6 @@ instance MonadHold t m => MonadHold t (StateT s m) where
595397 holdIncremental a0 = lift . holdIncremental a0
596398 buildDynamic a0 = lift . buildDynamic a0
597399 headE = lift . headE
598− now = lift now
599400
600401instance MonadSample t m => MonadSample t (ExceptT e m) where
601402 sample = lift . sample
@@ -606,7 +407,6 @@ instance MonadHold t m => MonadHold t (ExceptT e m) where
606407 holdIncremental a0 = lift . holdIncremental a0
607408 buildDynamic a0 = lift . buildDynamic a0
608409 headE = lift . headE
609− now = lift now
610410
611411instance (MonadSample t m, Monoid w) => MonadSample t (RWST r w s m) where
612412 sample = lift . sample
@@ -617,7 +417,6 @@ instance (MonadHold t m, Monoid w) => MonadHold t (RWST r w s m) where
617417 holdIncremental a0 = lift . holdIncremental a0
618418 buildDynamic a0 = lift . buildDynamic a0
619419 headE = lift . headE
620− now = lift now
621420
622421instance MonadSample t m => MonadSample t (ContT r m) where
623422 sample = lift . sample
@@ -628,7 +427,6 @@ instance MonadHold t m => MonadHold t (ContT r m) where
628427 holdIncremental a0 = lift . holdIncremental a0
629428 buildDynamic a0 = lift . buildDynamic a0
630429 headE = lift . headE
631− now = lift now
632430
633431--------------------------------------------------------------------------------
634432-- Convenience functions
@@ -643,14 +441,6 @@ pushAlways f = push (fmap Just . f)
643441ffor :: Functor f => f a -> (a -> b) -> f b
644442ffor = flip fmap
645443
646−-- | Rotated version of 'liftA2'.
647−ffor2 :: Applicative f => f a -> f b -> (a -> b -> c) -> f c
648−ffor2 a b f = liftA2 f a b
649−
650−-- | Rotated version of 'liftA3'.
651−ffor3 :: Applicative f => f a -> f b -> f c -> (a -> b -> c -> d) -> f d
652−ffor3 a b c f = liftA3 f a b c
653−
654444instance Reflex t => Applicative (Behavior t) where
655445 pure = constant
656446 f <*> x = pull $ sample f `ap` sample x
@@ -678,9 +468,7 @@ instance Reflex t => Monad (Behavior t) where
678468 a >>= f = pull $ sample a >>= sample . f
679469 -- 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.
680470 return = constant
681−#if !MIN_VERSION_base(4,13,0)
682471 fail = error "Monad (Behavior t) does not support fail"
683−#endif
684472
685473instance (Reflex t, Monoid a) => Monoid (Behavior t a) where
686474 mempty = constant mempty
@@ -696,51 +484,40 @@ instance (Reflex t, Num a) => Num (Behavior t a) where
696484 negate = fmap negate
697485 signum = fmap signum
698486
699−instance (Num a, Reflex t) => Num (Dynamic t a) where
700− (+) = liftA2 (+)
701− (*) = liftA2 (*)
702− abs = fmap abs
703− signum = fmap signum
704− fromInteger = pure . fromInteger
705− negate = fmap negate
706− (-) = liftA2 (-)
707−
708487instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where
709488 a <> b = pull $ liftM2 (<>) (sample a) (sample b)
710489 sconcat = pull . fmap sconcat . mapM sample
490+#if MIN_VERSION_semigroups(0,17,0)
711491 stimes n = fmap $ stimes n
492+#else
493+ times1p n = fmap $ times1p n
494+#endif
712495
713−-- | Alias for 'mapMaybe'
714−fmapMaybe :: Filterable f => (a -> Maybe b) -> f a -> f b
715−fmapMaybe = mapMaybe
716−
717−-- | Flipped version of 'mapMaybe'.
718−fforMaybe :: Filterable f => f a -> (a -> Maybe b) -> f b
719−fforMaybe = flip mapMaybe
496+-- | Flipped version of 'fmapMaybe'.
497+fforMaybe :: FunctorMaybe f => f a -> (a -> Maybe b) -> f b
498+fforMaybe = flip fmapMaybe
720499
721500-- | Filter 'f a' using the provided predicate.
722−ffilter :: Filterable f => (a -> Bool) -> f a -> f a
723−ffilter = W.filter
501+-- Relies on 'fforMaybe'.
502+ffilter :: FunctorMaybe f => (a -> Bool) -> f a -> f a
503+ffilter f = fmapMaybe $ \x -> if f x then Just x else Nothing
724504
725505-- | Filter 'Left's from 'f (Either a b)' into 'a'.
726−filterLeft :: Filterable f => f (Either a b) -> f a
727−filterLeft = mapMaybe (either Just (const Nothing))
506+filterLeft :: FunctorMaybe f => f (Either a b) -> f a
507+filterLeft = fmapMaybe (either Just (const Nothing))
728508
729509-- | Filter 'Right's from 'f (Either a b)' into 'b'.
730−filterRight :: Filterable f => f (Either a b) -> f b
731−filterRight = mapMaybe (either (const Nothing) Just)
510+filterRight :: FunctorMaybe f => f (Either a b) -> f b
511+filterRight = fmapMaybe (either (const Nothing) Just)
732512
733513-- | Left-biased event union (prefers left event on simultaneous
734514-- occurrence).
735515instance Reflex t => Alt (Event t) where
736516 ev1 <!> ev2 = leftmost [ev1, ev2]
737517
738−-- | 'Event' intersection. Only occurs when both events are co-incident.
518+-- | 'Event' intersection (convenient interface to 'coincidence').
739519instance Reflex t => Apply (Event t) where
740− evf <.> evx = mapMaybe f (align evf evx) where
741− f (These g a) = Just (g a)
742− f _ = Nothing
743−
520+ evf <.> evx = coincidence (fmap (<$> evx) evf)
744521
745522-- | 'Event' intersection (convenient interface to 'coincidence').
746523instance Reflex t => Bind (Event t) where
@@ -749,18 +526,13 @@ instance Reflex t => Bind (Event t) where
749526
750527instance Reflex t => Functor (Event t) where
751528 {-# INLINE fmap #-}
752− fmap f = mapMaybe $ Just . f
529+ fmap f = fmapMaybe $ Just . f
753530 {-# INLINE (<$) #-}
754531 x <$ e = fmapCheap (const x) e
755532
756−-- TODO Remove this instance
757533instance Reflex t => FunctorMaybe (Event t) where
758534 {-# INLINE fmapMaybe #-}
759− fmapMaybe = mapMaybe
760−
761−instance Reflex t => Filterable (Event t) where
762− {-# INLINE mapMaybe #-}
763− mapMaybe f = push $ return . f
535+ fmapMaybe f = push $ return . f
764536
765537-- | Never: @'zero' = 'never'@.
766538instance Reflex t => Plus (Event t) where
@@ -771,13 +543,7 @@ instance Reflex t => Plus (Event t) where
771543tag :: Reflex t => Behavior t b -> Event t a -> Event t b
772544tag b = pushAlways $ \_ -> sample b
773545
774−-- | Replace each occurrence value of the 'Event' with the value of the
775−-- 'Behavior' at that time; if it is 'Just', fire with the contained value; if
776−-- it is 'Nothing', drop the occurrence.
777−tagMaybe :: Reflex t => Behavior t (Maybe b) -> Event t a -> Event t b
778−tagMaybe b = push $ \_ -> sample b
779−
780−-- | Create a new 'Event' that combines occurrences of supplied 'Event' with the
546+-- | Create a new 'Event' that combines occurences of supplied 'Event' with the
781547-- current value of the 'Behavior'.
782548attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b)
783549attach = attachWith (,)
@@ -787,118 +553,53 @@ attach = attachWith (,)
787553attachWith :: Reflex t => (a -> b -> c) -> Behavior t a -> Event t b -> Event t c
788554attachWith f = attachWithMaybe $ \a b -> Just $ f a b
789555
790−-- | Create a new 'Event' by combining each occurrence with the current value of
556+-- | Create a new 'Event' by combining each occurence with the current value of
791557-- the 'Behavior'. The occurrence is discarded if the combining function returns
792558-- Nothing
793559attachWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c
794560attachWithMaybe f b e = flip push e $ \o -> (`f` o) <$> sample b
795561
796−-- | Create a new 'Event' that occurs on all but the first occurrence of the
562+-- | Create a new 'Event' that occurs on all but the first occurence of the
797563-- supplied 'Event'.
798−tailE :: (Reflex t, MonadHold t m) => Event t a -> m (Event t a)
564+tailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
799565tailE e = snd <$> headTailE e
800566
801−-- | Create a tuple of two 'Event's with the first one occurring only the first
802−-- time the supplied 'Event' occurs and the second occurring on all but the first
803−-- occurrence.
804−headTailE :: (Reflex t, MonadHold t m) => Event t a -> m (Event t a, Event t a)
567+-- | Create a tuple of two 'Event's with the first one occuring only the first
568+-- time the supplied 'Event' occurs and the second occuring on all but the first
569+-- occurence.
570+headTailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a, Event t a)
805571headTailE e = do
806572 eHead <- headE e
807573 be <- hold never $ fmap (const e) eHead
808574 return (eHead, switch be)
809575
810−-- | Take the streak of occurrences starting at the current time for which the
811−-- event returns 'True'.
812−--
813−-- Starting at the current time, fire all the occurrences of the 'Event' for
814−-- which the given predicate returns 'True'. When first 'False' is returned,
815−-- do not fire, and permanently stop firing, even if 'True' values would have
816−-- been encountered later.
817−takeWhileE
818− :: forall t m a
819− . (Reflex t, MonadFix m, MonadHold t m)
820− => (a -> Bool)
821− -> Event t a
822− -> m (Event t a)
823−takeWhileE f = takeWhileJustE $ \v -> guard (f v) $> v
824−
825−-- | Take the streak of occurrences starting at the current time for which the
826−-- event returns 'Just b'.
827−--
828−-- Starting at the current time, fire all the occurrences of the 'Event' for
829−-- which the given predicate returns 'Just b'. When first 'Nothing' is returned,
830−-- do not fire, and permanently stop firing, even if 'Just b' values would have
831−-- been encountered later.
832−takeWhileJustE
833− :: forall t m a b
834− . (Reflex t, MonadFix m, MonadHold t m)
835− => (a -> Maybe b)
836− -> Event t a
837− -> m (Event t b)
838−takeWhileJustE f e = do
839− rec let (eBad, eTrue) = fanEither $ ffor e' $ \a -> case f a of
840− Nothing -> Left never
841− Just b -> Right b
842− eFirstBad <- headE eBad
843− e' <- switchHold e eFirstBad
576+-- | Starting at the current time, fire all the occurrences of the 'Event' for
577+-- which the given predicate returns 'True'. When 'False' is returned, do not
578+-- fire, and permanently stop firing, even if 'True' values are encountered
579+-- later.
580+takeWhileE :: forall t m a. (Reflex t, MonadFix m, MonadHold t m) => (a -> Bool) -> Event t a -> m (Event t a)
581+takeWhileE f e = do
582+ rec let (eFalse, eTrue) = fanEither $ ffor e' $ \a -> if f a
583+ then Right a
584+ else Left never
585+ be <- hold e eFalse
586+ let e' = switch be
844587 return eTrue
845588
846−-- | Drop the streak of occurrences starting at the current time for which the
847−-- event returns 'True'.
848−--
849−-- Starting at the current time, do not fire all the occurrences of the 'Event'
850−-- for which the given predicate returns 'True'. When 'False' is first
851−-- returned, do fire, and permanently continue firing, even if 'True' values
852−-- would have been encountered later.
853−dropWhileE
854− :: forall t m a
855− . (Reflex t, MonadFix m, MonadHold t m)
856− => (a -> Bool)
857− -> Event t a
858− -> m (Event t a)
859−dropWhileE f e = snd <$> takeDropWhileJustE (\v -> guard (f v) $> v) e
860−
861−-- | Both take and drop the streak of occurrences starting at the current time
862−-- for which the event returns 'Just b'.
863−--
864−-- For the left event, starting at the current time, fire all the occurrences
865−-- of the 'Event' for which the given function returns 'Just b'. When
866−-- 'Nothing' is returned, do not fire, and permanently stop firing, even if
867−-- 'Just b' values would have been encountered later.
868−--
869−-- For the right event, do not fire until the first occurrence where the given
870−-- function returns 'Nothing', and fire that one and all subsequent
871−-- occurrences. Even if the function would have again returned 'Just b', keep
872−-- on firing.
873−takeDropWhileJustE
874− :: forall t m a b
875− . (Reflex t, MonadFix m, MonadHold t m)
876− => (a -> Maybe b)
877− -> Event t a
878− -> m (Event t b, Event t a)
879−takeDropWhileJustE f e = do
880− rec let (eBad, eGood) = fanEither $ ffor e' $ \a -> case f a of
881− Nothing -> Left ()
882− Just b -> Right b
883− eFirstBad <- headE eBad
884− e' <- switchHold e (never <$ eFirstBad)
885− eRest <- switchHoldPromptOnly never (e <$ eFirstBad)
886− return (eGood, eRest)
887−
888−-- | Split the supplied 'Event' into two individual 'Event's occurring at the
589+-- | Split the supplied 'Event' into two individual 'Event's occuring at the
889590-- same time with the respective values from the tuple.
890591splitE :: Reflex t => Event t (a, b) -> (Event t a, Event t b)
891592splitE e = (fmap fst e, fmap snd e)
892593
893594-- | Print the supplied 'String' and the value of the 'Event' on each
894−-- occurrence. This should /only/ be used for debugging.
595+-- occurence. This should /only/ be used for debugging.
895596--
896597-- Note: As with Debug.Trace.trace, the message will only be printed if the
897598-- 'Event' is actually used.
898599traceEvent :: (Reflex t, Show a) => String -> Event t a -> Event t a
899600traceEvent s = traceEventWith $ \x -> s <> ": " <> show x
900601
901−-- | Print the output of the supplied function on each occurrence of the
602+-- | Print the output of the supplied function on each occurence of the
902603-- 'Event'. This should /only/ be used for debugging.
903604--
904605-- Note: As with Debug.Trace.trace, the message will only be printed if the
@@ -909,7 +610,11 @@ traceEventWith f = push $ \x -> trace (f x) $ return $ Just x
909610instance (Semigroup a, Reflex t) => Semigroup (Event t a) where
910611 (<>) = alignWith (mergeThese (<>))
911612 sconcat = fmap sconcat . mergeList . toList
613+#if MIN_VERSION_semigroups(0,17,0)
912614 stimes n = fmap $ stimes n
615+#else
616+ times1p n = fmap $ times1p n
617+#endif
913618
914619instance (Semigroup a, Reflex t) => Monoid (Event t a) where
915620 mempty = never
@@ -938,30 +643,21 @@ leftmost :: Reflex t => [Event t a] -> Event t a
938643leftmost = mergeWith const
939644
940645-- | Create a new 'Event' that occurs if at least one of the 'Event's in the
941−-- list occurs and has a list of the values of all 'Event's occurring at that
646+-- list occurs and has a list of the values of all 'Event's occuring at that
942647-- time.
943648mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a)
944649mergeList [] = never
945650mergeList es = mergeWithFoldCheap' id es
946651
947−unsafeMapIncremental
948− :: (Reflex t, Patch p, Patch p')
949− => (PatchTarget p -> PatchTarget p')
950− -> (p -> p')
951− -> Incremental t p
952− -> Incremental t p'
652+unsafeMapIncremental :: (Reflex t, Patch p, Patch p') => (PatchTarget p -> PatchTarget p') -> (p -> p') -> Incremental t p -> Incremental t p'
953653unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ g <$> updatedIncremental a
954654
955655-- | Create a new 'Event' combining the map of 'Event's into an 'Event' that
956656-- occurs if at least one of them occurs and has a map of values of all 'Event's
957−-- occurring at that time.
657+-- occuring at that time.
958658mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a)
959659mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap
960660
961−-- | Like 'mergeMap' but for 'IntMap'.
962−mergeIntMap :: Reflex t => IntMap (Event t a) -> Event t (IntMap a)
963−mergeIntMap = fmap dmapToIntMap . merge . intMapWithFunctorToDMap
964−
965661-- | Create a merge whose parents can change over time
966662mergeMapIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Event t a)) -> Event t (Map k a)
967663mergeMapIncremental = fmap dmapToMap . mergeIncremental . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWith id)
@@ -979,7 +675,7 @@ fanEither :: Reflex t => Event t (Either a b) -> (Event t a, Event t b)
979675fanEither e =
980676 let justLeft = either Just (const Nothing)
981677 justRight = either (const Nothing) Just
982− in (mapMaybe justLeft e, mapMaybe justRight e)
678+ in (fmapMaybe justLeft e, fmapMaybe justRight e)
983679
984680-- | Split the event into separate events for 'This' and 'That' values,
985681-- allowing them to fire simultaneously when the input value is 'These'.
@@ -991,7 +687,7 @@ fanThese e =
991687 that (That y) = Just y
992688 that (These _ y) = Just y
993689 that _ = Nothing
994− in (mapMaybe this e, mapMaybe that e)
690+ in (fmapMaybe this e, fmapMaybe that e)
995691
996692-- | Split the event into an 'EventSelector' that allows efficient selection of
997693-- the individual 'Event's.
@@ -1000,7 +696,7 @@ fanMap = fan . fmap mapToDMap
1000696
1001697-- | Switches to the new event whenever it receives one. Only the old event is
1002698-- considered the moment a new one is switched in; the output event will fire at
1003−-- that moment only if the old event does.
699+-- that moment if only if the old event does.
1004700--
1005701-- Because the simultaneous firing case is irrelevant, this function imposes
1006702-- laxer "timing requirements" on the overall circuit, avoiding many potential
@@ -1040,85 +736,17 @@ switchHoldPromptOnly e0 e' = do
1040736 eLag <- switch <$> hold e0 e'
1041737 return $ coincidence $ leftmost [e', eLag <$ eLag]
1042738
1043−-- | When the given outer event fires, condense the inner events into the contained patch. Non-firing inner events will be replaced with deletions.
1044−coincidencePatchMap :: (Reflex t, Ord k) => Event t (PatchMap k (Event t v)) -> Event t (PatchMap k v)
1045−coincidencePatchMap e = fmapCheap PatchMap $ coincidence $ ffor e $ \(PatchMap m) -> mergeMap $ ffor m $ \case
1046− Nothing -> fmapCheap (const Nothing) e
1047− Just ev -> leftmost [fmapCheap Just ev, fmapCheap (const Nothing) e]
1048−
1049−-- | See 'coincidencePatchMap'
1050−coincidencePatchIntMap :: Reflex t => Event t (PatchIntMap (Event t v)) -> Event t (PatchIntMap v)
1051−coincidencePatchIntMap e = fmapCheap PatchIntMap $ coincidence $ ffor e $ \(PatchIntMap m) -> mergeIntMap $ ffor m $ \case
1052− Nothing -> fmapCheap (const Nothing) e
1053− Just ev -> leftmost [fmapCheap Just ev, fmapCheap (const Nothing) e]
1054−
1055−-- | See 'coincidencePatchMap'
1056−coincidencePatchMapWithMove :: (Reflex t, Ord k) => Event t (PatchMapWithMove k (Event t v)) -> Event t (PatchMapWithMove k v)
1057−coincidencePatchMapWithMove e = fmapCheap unsafePatchMapWithMove $ coincidence $ ffor e $ \p -> mergeMap $ ffor (unPatchMapWithMove p) $ \ni -> case PatchMapWithMove._nodeInfo_from ni of
1058− PatchMapWithMove.From_Delete -> fforCheap e $ \_ ->
1059− ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Delete }
1060− PatchMapWithMove.From_Move k -> fforCheap e $ \_ ->
1061− ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Move k }
1062− PatchMapWithMove.From_Insert ev -> leftmost
1063− [ fforCheap ev $ \v ->
1064− ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Insert v }
1065− , fforCheap e $ \_ ->
1066− ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Delete }
1067− ]
1068−
1069−-- | Given a 'PatchTarget' of events (e.g., a 'Map' with 'Event' values) and an event of 'Patch'es
1070−-- (e.g., a 'PatchMap' with 'Event' values), produce an 'Event' of the 'PatchTarget' type that
1071−-- fires with the patched value.
1072−switchHoldPromptOnlyIncremental
1073− :: forall t m p pt w
1074− . ( Reflex t
1075− , MonadHold t m
1076− , Patch (p (Event t w))
1077− , PatchTarget (p (Event t w)) ~ pt (Event t w)
1078− , Patch (p w)
1079− , PatchTarget (p w) ~ pt w
1080− , Monoid (pt w)
1081− )
1082− => (Incremental t (p (Event t w)) -> Event t (pt w))
1083− -> (Event t (p (Event t w)) -> Event t (p w))
1084− -> pt (Event t w)
1085− -> Event t (p (Event t w))
1086− -> m (Event t (pt w))
1087−switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch e0 e' = do
1088− lag <- mergePatchIncremental <$> holdIncremental e0 e'
1089− pure $ ffor (align lag (coincidencePatch e')) $ \case
1090− This old -> old
1091− That new -> new `applyAlways` mempty
1092− These old new -> new `applyAlways` old
1093−
1094739instance Reflex t => Align (Event t) where
1095740 nil = never
1096−#if MIN_VERSION_these(0, 8, 0)
1097−instance Reflex t => Semialign (Event t) where
1098−#endif
1099741 align = alignEventWithMaybe Just
1100742
1101−#ifdef MIN_VERSION_semialign
1102−#if MIN_VERSION_semialign(1,1,0)
1103−instance Reflex t => Zip (Event t) where
1104−#endif
1105− zip x y = mapMaybe justThese $ align x y
1106−#endif
1107−
1108−#ifdef MIN_VERSION_semialign
1109−#if MIN_VERSION_semialign(1,1,0)
1110−instance Reflex t => Unzip (Event t) where
1111− unzip = splitE
1112−#endif
1113−#endif
1114−
1115743-- | Create a new 'Event' that only occurs if the supplied 'Event' occurs and
1116−-- the 'Behavior' is true at the time of occurrence.
744+-- the 'Behavior' is true at the time of occurence.
1117745gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a
1118746gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing
1119747
1120−-- | Create a new behavior given a starting behavior and switch to the behavior
1121−-- carried by the event when it fires.
748+-- | Create a new behavior given a starting behavior and switch to a the behvior
749+-- carried by the event when it fires.
1122750switcher :: (Reflex t, MonadHold t m)
1123751 => Behavior t a -> Event t (Behavior t a) -> m (Behavior t a)
1124752switcher b eb = pull . (sample <=< sample) <$> hold b eb
@@ -1133,7 +761,7 @@ zipDyn = zipDynWith (,)
1133761
1134762-- | Combine two 'Dynamic's with a combining function. The result will change
1135763-- whenever either (or both) input 'Dynamic' changes.
1136−-- More efficient than 'liftA2'.
764+-- More efficient than liftA2.
1137765zipDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> Dynamic t c
1138766zipDynWith f da db =
1139767 let eab = align (updated da) (updated db)
@@ -1151,7 +779,11 @@ zipDynWith f da db =
1151779
1152780instance (Reflex t, Semigroup a) => Semigroup (Dynamic t a) where
1153781 (<>) = zipDynWith (<>)
782+#if MIN_VERSION_semigroups(0,17,0)
1154783 stimes n = fmap $ stimes n
784+#else
785+ times1p n = fmap $ times1p n
786+#endif
1155787
1156788instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where
1157789 mconcat = distributeListOverDynWith mconcat
@@ -1160,23 +792,14 @@ instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where
1160792
1161793-- | This function converts a 'DMap' whose elements are 'Dynamic's into a
1162794-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same
1163−-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators.
795+-- through the use of multiple uses of 'zipWithDyn' or 'Applicative' operators.
1164796distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity)
1165−distributeDMapOverDynPure = distributeDMapOverDynPureG coerceDynamic
1166−
1167−-- | This function converts a 'DMap' whose elements are 'Dynamic's into a
1168−-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same
1169−-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators.
1170−distributeDMapOverDynPureG
1171− :: forall t k q v. (Reflex t, GCompare k)
1172− => (forall a. q a -> Dynamic t (v a))
1173− -> DMap k q -> Dynamic t (DMap k v)
1174−distributeDMapOverDynPureG nt dm = case DMap.toList dm of
797+distributeDMapOverDynPure dm = case DMap.toList dm of
1175798 [] -> constDyn DMap.empty
1176− [k :=> v] -> DMap.singleton k <$> nt v
799+ [k :=> v] -> fmap (DMap.singleton k . Identity) v
1177800 _ ->
1178− let getInitial = DMap.traverseWithKey (\_ -> sample . current . nt) dm
1179− edmPre = mergeG getCompose $ DMap.map (Compose . updated . nt) dm
801+ let getInitial = DMap.traverseWithKey (\_ -> fmap Identity . sample . current) dm
802+ edmPre = merge $ DMap.map updated dm
1180803 result = unsafeBuildDynamic getInitial $ flip pushAlways edmPre $ \news -> do
1181804 olds <- sample $ current result
1182805 return $ DMap.unionWithKey (\_ _ new -> new) olds news
@@ -1188,73 +811,21 @@ distributeListOverDyn = distributeListOverDynWith id
1188811
1189812-- | Create a new 'Dynamic' by applying a combining function to a list of 'Dynamic's
1190813distributeListOverDynWith :: Reflex t => ([a] -> b) -> [Dynamic t a] -> Dynamic t b
1191−distributeListOverDynWith f =
1192− fmap (f . map fromDSum . DMap.toAscList) .
1193− distributeDMapOverDynPure .
1194− DMap.fromDistinctAscList .
1195− zipWith toDSum [0..]
1196− where
1197− toDSum :: Int -> Dynamic t a -> DSum (Const2 Int a) (Dynamic t)
1198− toDSum k v = Const2 k :=> v
1199− fromDSum :: DSum (Const2 Int a) Identity -> a
1200− fromDSum (Const2 _ :=> Identity v) = v
814+distributeListOverDynWith f = fmap (f . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList) . distributeDMapOverDynPure . DMap.fromList . map (\(k, v) -> Const2 k :=> v) . zip [0 :: Int ..]
1201815
1202816-- | Create a new 'Event' that occurs when the first supplied 'Event' occurs
1203817-- unless the second supplied 'Event' occurs simultaneously.
1204818difference :: Reflex t => Event t a -> Event t b -> Event t a
1205819difference = alignEventWithMaybe $ \case
1206820 This a -> Just a
1207− _ -> Nothing
821+ _ -> Nothing
1208822
1209−-- | Zips two values by taking the union of their shapes and combining with the provided function.
1210−-- 'Nothing' values are dropped.
1211823alignEventWithMaybe :: Reflex t => (These a b -> Maybe c) -> Event t a -> Event t b -> Event t c
1212−alignEventWithMaybe f ea eb = mapMaybe (f <=< dmapToThese) $
1213− merge $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]
1214−
1215−-- | Produces an 'Event' that fires only when the input event fires with a 'DSum' key that
1216−-- matches the provided key.
1217−filterEventKey
1218− :: forall t m k v a.
1219− ( Reflex t
1220− , MonadFix m
1221− , MonadHold t m
1222− , GEq k
1223− )
1224− => k a
1225− -> Event t (DSum k v)
1226− -> m (Event t (v a))
1227−filterEventKey k kv' = do
1228− let f :: DSum k v -> Maybe (v a)
1229− f (newK :=> newV) = case newK `geq` k of
1230− Just Refl -> Just newV
1231− Nothing -> Nothing
1232− takeWhileJustE f kv'
1233−
1234−-- | "Factor" the input 'DSum' 'Event' to produce an 'Event' which
1235−-- fires when the 'DSum' key changes and contains both the value of the
1236−-- 'DSum' at switchover and an 'Event' of values produced by subsequent
1237−-- firings of the input 'Event' that do not change the 'DSum' key.
1238−factorEvent
1239− :: forall t m k v a.
1240− ( Reflex t
1241− , MonadFix m
1242− , MonadHold t m
1243− , GEq k
1244− )
1245− => k a
1246− -> Event t (DSum k v)
1247− -> m (Event t (v a), Event t (DSum k (Product v (Compose (Event t) v))))
1248−factorEvent k0 kv' = do
1249− key :: Behavior t (Some k) <- hold (Some k0) $ fmapCheap (\(k :=> _) -> Some k) kv'
1250− let update = flip push kv' $ \(newKey :=> newVal) -> sample key >>= \case
1251− Some oldKey -> case newKey `geq` oldKey of
1252− Just Refl -> return Nothing
1253− Nothing -> do
1254− newInner <- filterEventKey newKey kv'
1255− return $ Just $ newKey :=> Pair newVal (Compose newInner)
1256− eInitial <- filterEventKey k0 kv'
1257− return (eInitial, update)
824+alignEventWithMaybe f ea eb =
825+ fmapMaybe (f <=< dmapToThese)
826+ $ merge
827+ $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]
828+
1258829
1259830--------------------------------------------------------------------------------
1260831-- Accumulator
@@ -1284,94 +855,26 @@ class Reflex t => Accumulator t f | f -> t where
1284855 mapAccumMaybe f = mapAccumMaybeM $ \v o -> return $ f v o
1285856 mapAccumMaybeM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (f a, Event t c)
1286857
1287−-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event'
1288−-- with the provided function. See 'foldDyn'.
1289−accumDyn
1290− :: (Reflex t, MonadHold t m, MonadFix m)
1291− => (a -> b -> a)
1292− -> a
1293− -> Event t b
1294− -> m (Dynamic t a)
858+accumDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (Dynamic t a)
1295859accumDyn f = accumMaybeDyn $ \v o -> Just $ f v o
1296−
1297−-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event'
1298−-- with the provided 'PushM' action.
1299−accumMDyn
1300− :: (Reflex t, MonadHold t m, MonadFix m)
1301− => (a -> b -> PushM t a)
1302− -> a
1303− -> Event t b
1304− -> m (Dynamic t a)
860+accumMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t a) -> a -> Event t b -> m (Dynamic t a)
1305861accumMDyn f = accumMaybeMDyn $ \v o -> Just <$> f v o
1306−
1307−-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event'
1308−-- with the provided function, discarding 'Nothing' results.
1309−accumMaybeDyn
1310− :: (Reflex t, MonadHold t m, MonadFix m)
1311− => (a -> b -> Maybe a)
1312− -> a
1313− -> Event t b
1314− -> m (Dynamic t a)
862+accumMaybeDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (Dynamic t a)
1315863accumMaybeDyn f = accumMaybeMDyn $ \v o -> return $ f v o
1316−
1317−-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event'
1318−-- with the provided 'PushM' action, discarding 'Nothing' results.
1319−accumMaybeMDyn
1320− :: (Reflex t, MonadHold t m, MonadFix m)
1321− => (a -> b -> PushM t (Maybe a))
1322− -> a
1323− -> Event t b
1324− -> m (Dynamic t a)
864+accumMaybeMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (Dynamic t a)
1325865accumMaybeMDyn f z e = do
1326866 rec let e' = flip push e $ \o -> do
1327867 v <- sample $ current d'
1328868 f v o
1329869 d' <- holdDyn z e'
1330870 return d'
1331−
1332−-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event'
1333−-- with a function that both accumulates and produces a value to fire
1334−-- as an 'Event'. Returns both the accumulated value and an 'Event'.
1335−mapAccumDyn
1336− :: (Reflex t, MonadHold t m, MonadFix m)
1337− => (a -> b -> (a, c))
1338− -> a
1339− -> Event t b
1340− -> m (Dynamic t a, Event t c)
871+mapAccumDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (Dynamic t a, Event t c)
1341872mapAccumDyn f = mapAccumMaybeDyn $ \v o -> bimap Just Just $ f v o
1342−
1343−-- | Similar to 'mapAccumDyn' except that the combining function is a
1344−-- 'PushM' action.
1345−mapAccumMDyn
1346− :: (Reflex t, MonadHold t m, MonadFix m)
1347− => (a -> b -> PushM t (a, c))
1348− -> a
1349− -> Event t b
1350− -> m (Dynamic t a, Event t c)
873+mapAccumMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (Dynamic t a, Event t c)
1351874mapAccumMDyn f = mapAccumMaybeMDyn $ \v o -> bimap Just Just <$> f v o
1352−
1353−-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event' with
1354−-- a function that both optionally accumulates and optionally produces
1355−-- a value to fire as a separate output 'Event'.
1356−-- Note that because 'Nothing's are discarded in both cases, the output
1357−-- 'Event' may fire even though the output 'Dynamic' has not changed, and
1358−-- the output 'Dynamic' may update even when the output 'Event' is not firing.
1359−mapAccumMaybeDyn
1360− :: (Reflex t, MonadHold t m, MonadFix m)
1361− => (a -> b -> (Maybe a, Maybe c))
1362− -> a
1363− -> Event t b
1364− -> m (Dynamic t a, Event t c)
875+mapAccumMaybeDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (Dynamic t a, Event t c)
1365876mapAccumMaybeDyn f = mapAccumMaybeMDyn $ \v o -> return $ f v o
1366−
1367−-- | Like 'mapAccumMaybeDyn' except that the combining function is a
1368−-- 'PushM' action.
1369−mapAccumMaybeMDyn
1370− :: (Reflex t, MonadHold t m, MonadFix m)
1371− => (a -> b -> PushM t (Maybe a, Maybe c))
1372− -> a
1373− -> Event t b
1374− -> m (Dynamic t a, Event t c)
877+mapAccumMaybeMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (Dynamic t a, Event t c)
1375878mapAccumMaybeMDyn f z e = do
1376879 rec let e' = flip push e $ \o -> do
1377880 v <- sample $ current d'
@@ -1379,42 +882,18 @@ mapAccumMaybeMDyn f z e = do
1379882 return $ case result of
1380883 (Nothing, Nothing) -> Nothing
1381884 _ -> Just result
1382− d' <- holdDyn z $ mapMaybe fst e'
1383− return (d', mapMaybe snd e')
885+ d' <- holdDyn z $ fmapMaybe fst e'
886+ return (d', fmapMaybe snd e')
1384887
1385−-- | Accumulate a 'Behavior' by folding occurrences of an 'Event'
1386−-- with the provided function.
1387888{-# INLINE accumB #-}
1388−accumB
1389− :: (Reflex t, MonadHold t m, MonadFix m)
1390− => (a -> b -> a)
1391− -> a
1392− -> Event t b
1393− -> m (Behavior t a)
889+accumB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (Behavior t a)
1394890accumB f = accumMaybeB $ \v o -> Just $ f v o
1395−
1396−-- | Like 'accumB' except that the combining function is a 'PushM' action.
1397891{-# INLINE accumMB #-}
1398−accumMB
1399− :: (Reflex t, MonadHold t m, MonadFix m)
1400− => (a -> b -> PushM t a)
1401− -> a
1402− -> Event t b
1403− -> m (Behavior t a)
892+accumMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t a) -> a -> Event t b -> m (Behavior t a)
1404893accumMB f = accumMaybeMB $ \v o -> Just <$> f v o
1405−
1406−-- | Accumulate a 'Behavior' by folding occurrences of an 'Event'
1407−-- with the provided function, discarding 'Nothing' results.
1408894{-# INLINE accumMaybeB #-}
1409−accumMaybeB
1410− :: (Reflex t, MonadHold t m, MonadFix m)
1411− => (a -> b -> Maybe a)
1412− -> a
1413− -> Event t b
1414− -> m (Behavior t a)
895+accumMaybeB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (Behavior t a)
1415896accumMaybeB f = accumMaybeMB $ \v o -> return $ f v o
1416−
1417−-- | Like 'accumMaybeB' except that the combining function is a 'PushM' action.
1418897{-# INLINE accumMaybeMB #-}
1419898accumMaybeMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (Behavior t a)
1420899accumMaybeMB f z e = do
@@ -1423,42 +902,16 @@ accumMaybeMB f z e = do
1423902 f v o
1424903 d' <- hold z e'
1425904 return d'
1426−
1427−-- | Accumulate a 'Behavior' by folding occurrences of an 'Event'
1428−-- with a function that both accumulates and produces a value to fire
1429−-- as an 'Event'. Returns both the accumulated value and an 'Event'.
1430905{-# INLINE mapAccumB #-}
1431−mapAccumB
1432− :: (Reflex t, MonadHold t m, MonadFix m)
1433− => (a -> b -> (a, c))
1434− -> a
1435− -> Event t b
1436− -> m (Behavior t a, Event t c)
906+mapAccumB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (Behavior t a, Event t c)
1437907mapAccumB f = mapAccumMaybeB $ \v o -> bimap Just Just $ f v o
1438−
1439−-- | Like 'mapAccumB' except that the combining function is a 'PushM' action.
1440908{-# INLINE mapAccumMB #-}
1441−mapAccumMB
1442− :: (Reflex t, MonadHold t m, MonadFix m)
1443− => (a -> b -> PushM t (a, c))
1444− -> a
1445− -> Event t b
1446− -> m (Behavior t a, Event t c)
909+mapAccumMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (Behavior t a, Event t c)
1447910mapAccumMB f = mapAccumMaybeMB $ \v o -> bimap Just Just <$> f v o
1448−
1449−-- | Accumulate a 'Behavior' by folding occurrences of an 'Event' with
1450−-- a function that both optionally accumulates and optionally produces
1451−-- a value to fire as a separate output 'Event'. 'Nothing's are discarded.
1452911{-# INLINE mapAccumMaybeB #-}
1453−mapAccumMaybeB
1454− :: (Reflex t, MonadHold t m, MonadFix m)
1455− => (a -> b -> (Maybe a, Maybe c))
1456− -> a
1457− -> Event t b
1458− -> m (Behavior t a, Event t c)
912+mapAccumMaybeB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (Behavior t a, Event t c)
1459913mapAccumMaybeB f = mapAccumMaybeMB $ \v o -> return $ f v o
1460914
1461−-- | Like 'mapAccumMaybeB' except that the combining function is a 'PushM' action.
1462915{-# INLINE mapAccumMaybeMB #-}
1463916mapAccumMaybeMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (Behavior t a, Event t c)
1464917mapAccumMaybeMB f z e = do
@@ -1468,8 +921,8 @@ mapAccumMaybeMB f z e = do
1468921 return $ case result of
1469922 (Nothing, Nothing) -> Nothing
1470923 _ -> Just result
1471− d' <- hold z $ mapMaybe fst e'
1472− return (d', mapMaybe snd e')
924+ d' <- hold z $ fmapMaybe fst e'
925+ return (d', fmapMaybe snd e')
1473926
1474927-- | Accumulate occurrences of an 'Event', producing an output occurrence each
1475928-- time. Discard the underlying 'Accumulator'.
@@ -1516,7 +969,7 @@ instance Reflex t => Accumulator t (Event t) where
1516969 accumMaybeM f z e = updated <$> accumMaybeM f z e
1517970 mapAccumMaybeM f z e = first updated <$> mapAccumMaybeM f z e
1518971
1519−-- | Create a new 'Event' by combining each occurrence with the next value of the
972+-- | Create a new 'Event' by combining each occurence with the next value of the
1520973-- list using the supplied function. If the list runs out of items, all
1521974-- subsequent 'Event' occurrences will be ignored.
1522975zipListWithEvent :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> c) -> [a] -> Event t b -> m (Event t c)
@@ -1526,17 +979,17 @@ zipListWithEvent f l e = do
1526979 _ -> (Nothing, Nothing) --TODO: Unsubscribe the event?
1527980 mapAccumMaybe_ f' l e
1528981
1529−-- | Assign a number to each occurrence of the given 'Event', starting from 0
982+-- | Assign a number to each occurence of the given 'Event', starting from 0
1530983{-# INLINE numberOccurrences #-}
1531984numberOccurrences :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Event t (b, a))
1532985numberOccurrences = numberOccurrencesFrom 0
1533986
1534−-- | Assign a number to each occurrence of the given 'Event'
987+-- | Assign a number to each occurence of the given 'Event'
1535988{-# INLINE numberOccurrencesFrom #-}
1536989numberOccurrencesFrom :: (Reflex t, MonadHold t m, MonadFix m, Num b) => b -> Event t a -> m (Event t (b, a))
1537990numberOccurrencesFrom = mapAccum_ (\n a -> let !next = n + 1 in (next, (n, a)))
1538991
1539−-- | Assign a number to each occurrence of the given 'Event'; discard the occurrences' values
992+-- | Assign a number to each occurence of the given 'Event'; discard the occurrences' values
1540993{-# INLINE numberOccurrencesFrom_ #-}
1541994numberOccurrencesFrom_ :: (Reflex t, MonadHold t m, MonadFix m, Num b) => b -> Event t a -> m (Event t b)
1542995numberOccurrencesFrom_ = mapAccum_ (\n _ -> let !next = n + 1 in (next, n))
@@ -1609,74 +1062,83 @@ infixl 4 <@>
16091062(<@) = tag
16101063infixl 4 <@
16111064
1065+------------------
1066+-- Adjustable
1067+------------------
1068+
1069+-- | A 'Monad' that supports adjustment over time. After an action has been
1070+-- run, if the given events fire, it will adjust itself so that its net effect
1071+-- is as though it had originally been run with the new value. Note that there
1072+-- is some issue here with persistent side-effects: obviously, IO (and some
1073+-- other side-effects) cannot be undone, so it is up to the instance implementer
1074+-- to determine what the best meaning for this class is in such cases.
1075+class (Reflex t, Monad m) => Adjustable t m | m -> t where
1076+ runWithReplace :: m a -> Event t (m b) -> m (a, Event t b)
1077+ traverseIntMapWithKeyWithAdjust :: (IntMap.Key -> v -> m v') -> IntMap v -> Event t (PatchIntMap v) -> m (IntMap v', Event t (PatchIntMap v'))
1078+ traverseDMapWithKeyWithAdjust :: GCompare k => (forall a. k a -> v a -> m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> m (DMap k v', Event t (PatchDMap k v'))
1079+ traverseDMapWithKeyWithAdjustWithMove :: GCompare k => (forall a. k a -> v a -> m (v' a)) -> DMap k v -> Event t (PatchDMapWithMove k v) -> m (DMap k v', Event t (PatchDMapWithMove k v'))
1080+
1081+instance Adjustable t m => Adjustable t (ReaderT r m) where
1082+ runWithReplace a0 a' = do
1083+ r <- ask
1084+ lift $ runWithReplace (runReaderT a0 r) $ fmap (`runReaderT` r) a'
1085+ traverseIntMapWithKeyWithAdjust f dm0 dm' = do
1086+ r <- ask
1087+ lift $ traverseIntMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'
1088+ traverseDMapWithKeyWithAdjust f dm0 dm' = do
1089+ r <- ask
1090+ lift $ traverseDMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'
1091+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do
1092+ r <- ask
1093+ lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runReaderT (f k v) r) dm0 dm'
1094+
1095+sequenceDMapWithAdjust :: (GCompare k, Adjustable t m) => DMap k m -> Event t (PatchDMap k m) -> m (DMap k Identity, Event t (PatchDMap k Identity))
1096+sequenceDMapWithAdjust = traverseDMapWithKeyWithAdjust $ \_ -> fmap Identity
1097+
1098+sequenceDMapWithAdjustWithMove :: (GCompare k, Adjustable t m) => DMap k m -> Event t (PatchDMapWithMove k m) -> m (DMap k Identity, Event t (PatchDMapWithMove k Identity))
1099+sequenceDMapWithAdjustWithMove = traverseDMapWithKeyWithAdjustWithMove $ \_ -> fmap Identity
1100+
1101+mapMapWithAdjustWithMove :: forall t m k v v'. (Adjustable t m, Ord k) => (k -> v -> m v') -> Map k v -> Event t (PatchMapWithMove k v) -> m (Map k v', Event t (PatchMapWithMove k v'))
1102+mapMapWithAdjustWithMove f m0 m' = do
1103+ (out0 :: DMap (Const2 k v) (Constant v'), out') <- traverseDMapWithKeyWithAdjustWithMove (\(Const2 k) (Identity v) -> Constant <$> f k v) (mapToDMap m0) (const2PatchDMapWithMoveWith Identity <$> m')
1104+ return (dmapToMapWith (\(Constant v') -> v') out0, patchDMapWithMoveToPatchMapWithMoveWith (\(Constant v') -> v') <$> out')
1105+
16121106------------------
16131107-- Cheap Functions
16141108------------------
16151109
1616−-- | A "cheap" version of 'pushAlways'. See the performance note on 'pushCheap'.
16171110{-# INLINE pushAlwaysCheap #-}
16181111pushAlwaysCheap :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b
16191112pushAlwaysCheap f = pushCheap (fmap Just . f)
16201113
1621−-- | A "cheap" version of 'mapMaybe'. See the performance note on 'pushCheap'.
1622−{-# INLINE mapMaybeCheap #-}
1623−mapMaybeCheap :: Reflex t => (a -> Maybe b) -> Event t a -> Event t b
1624−mapMaybeCheap f = pushCheap $ return . f
1625−
1626−-- | An alias for 'mapMaybeCheap'
16271114{-# INLINE fmapMaybeCheap #-}
16281115fmapMaybeCheap :: Reflex t => (a -> Maybe b) -> Event t a -> Event t b
1629−fmapMaybeCheap = mapMaybeCheap
1630−
1116+fmapMaybeCheap f = pushCheap $ return . f
16311117
1632−-- | A "cheap" version of 'fforMaybe'. See the performance note on 'pushCheap'.
16331118{-# INLINE fforMaybeCheap #-}
16341119fforMaybeCheap :: Reflex t => Event t a -> (a -> Maybe b) -> Event t b
1635−fforMaybeCheap = flip mapMaybeCheap
1120+fforMaybeCheap = flip fmapMaybeCheap
16361121
1637−-- | A "cheap" version of 'ffor'. See the performance note on 'pushCheap'.
16381122{-# INLINE fforCheap #-}
16391123fforCheap :: Reflex t => Event t a -> (a -> b) -> Event t b
16401124fforCheap = flip fmapCheap
16411125
1642−-- | A "cheap" version of 'fmap'. See the performance note on 'pushCheap'.
16431126{-# INLINE fmapCheap #-}
16441127fmapCheap :: Reflex t => (a -> b) -> Event t a -> Event t b
16451128fmapCheap f = pushCheap $ return . Just . f
16461129
1647−-- | A "cheap" version of 'tag'. See the performance note on 'pushCheap'.
16481130{-# INLINE tagCheap #-}
16491131tagCheap :: Reflex t => Behavior t b -> Event t a -> Event t b
16501132tagCheap b = pushAlwaysCheap $ \_ -> sample b
16511133
1652−-- | Merge a collection of events; the resulting 'Event' will only occur if at
1653−-- least one input event is occurring, and will contain all of the input keys
1654−-- that are occurring simultaneously
1655−merge :: (Reflex t, GCompare k) => DMap k (Event t) -> Event t (DMap k Identity)
1656−merge = mergeG coerceEvent
1657−{-# INLINE merge #-}
1658−
1659−-- | Create a merge whose parents can change over time
1660−mergeIncremental :: (Reflex t, GCompare k)
1661− => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)
1662−mergeIncremental = mergeIncrementalG coerceEvent
1663−
1664−-- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental
1665−mergeIncrementalWithMove :: (Reflex t, GCompare k)
1666− => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)
1667−mergeIncrementalWithMove = mergeIncrementalWithMoveG coerceEvent
1668−
1669−-- | A "cheap" version of 'mergeWithCheap'. See the performance note on 'pushCheap'.
16701134{-# INLINE mergeWithCheap #-}
16711135mergeWithCheap :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a
16721136mergeWithCheap = mergeWithCheap' id
16731137
1674−-- | A "cheap" version of 'mergeWithCheap''. See the performance note on 'pushCheap'.
16751138{-# INLINE mergeWithCheap' #-}
16761139mergeWithCheap' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b
16771140mergeWithCheap' f g = mergeWithFoldCheap' $ foldl1 g . fmap f
16781141
1679−-- | A "cheap" version of 'mergeWithFoldCheap''. See the performance note on 'pushCheap'.
16801142{-# INLINE mergeWithFoldCheap' #-}
16811143mergeWithFoldCheap' :: Reflex t => (NonEmpty a -> b) -> [Event t a] -> Event t b
16821144mergeWithFoldCheap' f es =
@@ -1689,11 +1151,34 @@ mergeWithFoldCheap' f es =
16891151-- Deprecated functions
16901152--------------------------------------------------------------------------------
16911153
1154+{-# DEPRECATED MonadAdjust "Use Adjustable instead" #-}
1155+type MonadAdjust = Adjustable
1156+
1157+-- | Create a new 'Event' that occurs if at least one of the supplied 'Event's
1158+-- occurs. If both occur at the same time they are combined using 'mappend'.
1159+{-# DEPRECATED appendEvents "If a 'Semigroup a' instance is available, use 'mappend'; otherwise, use 'alignWith (mergeThese mappend)' instead" #-}
1160+appendEvents :: (Reflex t, Monoid a) => Event t a -> Event t a -> Event t a
1161+appendEvents = alignWith $ mergeThese mappend
1162+
1163+-- | Alias for 'headE'
1164+{-# DEPRECATED onceE "Use 'headE' instead" #-}
1165+onceE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
1166+onceE = headE
1167+
1168+-- | Run both sides of a 'These' monadically, combining the results.
1169+{-# DEPRECATED sequenceThese "Use bisequenceA or bisequence from the bifunctors package instead" #-}
1170+#ifdef USE_TEMPLATE_HASKELL
1171+{-# ANN sequenceThese "HLint: ignore Use fmap" #-}
1172+#endif
1173+sequenceThese :: Monad m => These (m a) (m b) -> m (These a b)
1174+sequenceThese t = case t of
1175+ This ma -> fmap This ma
1176+ These ma mb -> liftM2 These ma mb
1177+ That mb -> fmap That mb
1178+
16921179{-# DEPRECATED switchPromptly "Use 'switchHoldPromptly' instead. The 'switchHold*' naming convention was chosen because those functions are more closely related to each other than they are to 'switch'. " #-}
1693−-- | See 'switchHoldPromptly'
16941180switchPromptly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)
16951181switchPromptly = switchHoldPromptly
16961182{-# DEPRECATED switchPromptOnly "Use 'switchHoldPromptOnly' instead. The 'switchHold*' naming convention was chosen because those functions are more closely related to each other than they are to 'switch'. " #-}
1697−-- | See 'switchHoldPromptOnly'
16981183switchPromptOnly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)
16991184switchPromptOnly = switchHoldPromptOnly
src/Reflex/Collection.hs+53−158
@@ -10,14 +10,12 @@
1010#ifdef USE_REFLEX_OPTIMIZER
1111{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
1212#endif
13−-- |
14−-- Module:
15−-- Reflex.Collection
1613module Reflex.Collection
1714 (
1815 -- * Widgets on Collections
1916 listHoldWithKey
2017 , listWithKey
18+ , listWithKey'
2119 , listWithKeyShallowDiff
2220 , listViewWithKey
2321 , selectViewListWithKey
@@ -27,13 +25,6 @@ module Reflex.Collection
2725 , simpleList
2826 ) where
2927
30−#ifdef MIN_VERSION_semialign
31−import Prelude hiding (zip, zipWith)
32−#if MIN_VERSION_semialign(1,1,0)
33−import Data.Zip (Zip (..))
34−#endif
35−#endif
36−
3728import Control.Monad.Identity
3829import Data.Align
3930import Data.Functor.Misc
@@ -43,183 +34,87 @@ import Data.Map.Misc
4334import Data.These
4435
4536import Reflex.Class
46−import Reflex.Adjustable.Class
4737import Reflex.Dynamic
4838import Reflex.PostBuild.Class
4939
50−-- | Create a set of widgets based on the provided 'Map'. When the
51−-- input 'Event' fires, remove widgets for keys with the value 'Nothing'
52−-- and add/replace widgets for keys with 'Just' values.
53−listHoldWithKey
54− :: forall t m k v a
55− . (Ord k, Adjustable t m, MonadHold t m)
56− => Map k v
57− -> Event t (Map k (Maybe v))
58− -> (k -> v -> m a)
59− -> m (Dynamic t (Map k a))
40+listHoldWithKey :: forall t m k v a. (Ord k, Adjustable t m, MonadHold t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a))
6041listHoldWithKey m0 m' f = do
6142 let dm0 = mapWithFunctorToDMap $ Map.mapWithKey f m0
62− dm' = fmap
63− (PatchDMap . mapWithFunctorToDMap . Map.mapWithKey
64− (\k v -> ComposeMaybe $ fmap (f k) v)
65− )
66− m'
43+ dm' = fmap (PatchDMap . mapWithFunctorToDMap . Map.mapWithKey (\k v -> ComposeMaybe $ fmap (f k) v)) m'
6744 (a0, a') <- sequenceDMapWithAdjust dm0 dm'
45+ fmap dmapToMap . incrementalToDynamic <$> holdIncremental a0 a' --TODO: Move the dmapToMap to the righthand side so it doesn't get fully redone every time
6846
69− --TODO: Move the dmapToMap to the righthand side so it doesn't get
70− --fully redone every time
71− fmap dmapToMap . incrementalToDynamic <$> holdIncremental a0 a'
72−
73−--TODO: Something better than Dynamic t (Map k v) - we want something
74−--where the Events carry diffs, not the whole value
75−listWithKey
76− :: forall t k v m a
77− . (Ord k, Adjustable t m, PostBuild t m, MonadFix m, MonadHold t m)
78− => Dynamic t (Map k v)
79− -> (k -> Dynamic t v -> m a)
80− -> m (Dynamic t (Map k a))
47+--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
48+listWithKey :: forall t k v m a. (Ord k, Adjustable t m, PostBuild t m, MonadFix m, MonadHold t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a))
8149listWithKey vals mkChild = do
8250 postBuild <- getPostBuild
8351 let childValChangedSelector = fanMap $ updated vals
84−
85− -- We keep track of changes to children values in the mkChild
86− -- function we pass to listHoldWithKey The other changes we need
87− -- to keep track of are child insertions and
88− -- deletions. diffOnlyKeyChanges keeps track of insertions and
89− -- deletions but ignores value changes, since they're already
90− -- accounted for.
91− diffOnlyKeyChanges olds news =
92− flip Map.mapMaybe (align olds news) $ \case
93− This _ -> Just Nothing
94− These _ _ -> Nothing
95− That new -> Just $ Just new
52+ -- We keep track of changes to children values in the mkChild function we pass to listHoldWithKey
53+ -- The other changes we need to keep track of are child insertions and deletions. diffOnlyKeyChanges
54+ -- keeps track of insertions and deletions but ignores value changes, since they're already accounted for.
55+ diffOnlyKeyChanges olds news = flip Map.mapMaybe (align olds news) $ \case
56+ This _ -> Just Nothing
57+ These _ _ -> Nothing
58+ That new -> Just $ Just new
9659 rec sentVals :: Dynamic t (Map k v) <- foldDyn applyMap Map.empty changeVals
9760 let changeVals :: Event t (Map k (Maybe v))
98− changeVals =
99− attachWith diffOnlyKeyChanges (current sentVals) $ leftmost
100− [ updated vals
101−
102− -- TODO: This should probably be added to the
103− -- attachWith, not to the updated; if we were using
104− -- diffMap instead of diffMapNoEq, I think it might not
105− -- work
106− , tag (current vals) postBuild
107− ]
61+ changeVals = attachWith diffOnlyKeyChanges (current sentVals) $ leftmost
62+ [ updated vals
63+ , tag (current vals) postBuild --TODO: This should probably be added to the attachWith, not to the updated; if we were using diffMap instead of diffMapNoEq, I think it might not work
64+ ]
10865 listHoldWithKey Map.empty changeVals $ \k v ->
10966 mkChild k =<< holdDyn v (select childValChangedSelector $ Const2 k)
11067
111−-- | Display the given map of items (in key order) using the builder
112−-- function provided, and update it with the given event. 'Nothing'
113−-- update entries will delete the corresponding children, and 'Just'
114−-- entries will create them if they do not exist or send an update
115−-- event to them if they do.
116−listWithKeyShallowDiff
117− :: (Ord k, Adjustable t m, MonadFix m, MonadHold t m)
118− => Map k v
119− -> Event t (Map k (Maybe v))
120− -> (k -> v -> Event t v -> m a)
121− -> m (Dynamic t (Map k a))
68+{-# DEPRECATED listWithKey' "listWithKey' has been renamed to listWithKeyShallowDiff; also, its behavior has changed to fix a bug where children were always rebuilt (never updated)" #-}
69+listWithKey' :: (Ord k, Adjustable t m, MonadFix m, MonadHold t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))
70+listWithKey' = listWithKeyShallowDiff
71+
72+-- | Display the given map of items (in key order) using the builder function provided, and update it with the given event. 'Nothing' update entries will delete the corresponding children, and 'Just' entries will create them if they do not exist or send an update event to them if they do.
73+listWithKeyShallowDiff :: (Ord k, Adjustable t m, MonadFix m, MonadHold t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))
12274listWithKeyShallowDiff initialVals valsChanged mkChild = do
12375 let childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged
12476 sentVals <- foldDyn applyMap (void initialVals) $ fmap (fmap void) valsChanged
12577 let relevantPatch patch _ = case patch of
126−
127− -- Even if we let a Nothing through when the element doesn't
128− -- already exist, this doesn't cause a problem because it is
129− -- ignored
130− Nothing -> Just Nothing
131−
132− -- We don't want to let spurious re-creations of items through
133− Just _ -> Nothing
134− listHoldWithKey
135− initialVals
136− (attachWith (flip (Map.differenceWith relevantPatch))
137− (current sentVals)
138− valsChanged
139− )
140− $ \k v -> mkChild k v $ select childValChangedSelector $ Const2 k
141−
142−--TODO: Something better than Dynamic t (Map k v) - we want something
143−--where the Events carry diffs, not the whole value
144−-- | Create a dynamically-changing set of Event-valued widgets. This
145−-- is like 'listWithKey', specialized for widgets returning @/Event t a/@.
146−-- 'listWithKey' would return @/Dynamic t (Map k (Event t a))/@ in
147−-- this scenario, but 'listViewWithKey' flattens this to
148−-- @/Event t (Map k a)/@ via 'switch'.
149−listViewWithKey
150− :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m)
151− => Dynamic t (Map k v)
152− -> (k -> Dynamic t v -> m (Event t a))
153− -> m (Event t (Map k a))
154−listViewWithKey vals mkChild =
155− switch . fmap mergeMap <$> listViewWithKey' vals mkChild
156−
157−listViewWithKey'
158− :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m)
159− => Dynamic t (Map k v)
160− -> (k -> Dynamic t v -> m a)
161− -> m (Behavior t (Map k a))
78+ Nothing -> Just Nothing -- Even if we let a Nothing through when the element doesn't already exist, this doesn't cause a problem because it is ignored
79+ Just _ -> Nothing -- We don't want to let spurious re-creations of items through
80+ listHoldWithKey initialVals (attachWith (flip (Map.differenceWith relevantPatch)) (current sentVals) valsChanged) $ \k v ->
81+ mkChild k v $ select childValChangedSelector $ Const2 k
82+
83+--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
84+-- | Create a dynamically-changing set of Event-valued widgets.
85+-- This is like listWithKey, specialized for widgets returning (Event t a). listWithKey would return 'Dynamic t (Map k (Event t a))' in this scenario, but listViewWithKey flattens this to 'Event t (Map k a)' via 'switch'.
86+listViewWithKey :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m (Event t a)) -> m (Event t (Map k a))
87+listViewWithKey vals mkChild = switch . fmap mergeMap <$> listViewWithKey' vals mkChild
88+
89+listViewWithKey' :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Behavior t (Map k a))
16290listViewWithKey' vals mkChild = current <$> listWithKey vals mkChild
16391
164−-- | Create a dynamically-changing set of widgets, one of which is
165−-- selected at any time.
166−selectViewListWithKey
167− :: forall t m k v a
168− . (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)
169− => Dynamic t k
170− -- ^ Current selection key
171− -> Dynamic t (Map k v)
172− -- ^ Dynamic key/value map
173− -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a))
174− -- ^ Function to create a widget for a given key from Dynamic value
175− -- and Dynamic Bool indicating if this widget is currently selected
176− -> m (Event t (k, a))
177− -- ^ Event that fires when any child's return Event fires. Contains
178− -- key of an arbitrary firing widget.
92+-- | Create a dynamically-changing set of widgets, one of which is selected at any time.
93+selectViewListWithKey :: forall t m k v a. (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)
94+ => Dynamic t k -- ^ Current selection key
95+ -> Dynamic t (Map k v) -- ^ Dynamic key/value map
96+ -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -- ^ Function to create a widget for a given key from Dynamic value and Dynamic Bool indicating if this widget is currently selected
97+ -> m (Event t (k, a)) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.
17998selectViewListWithKey selection vals mkChild = do
180− -- For good performance, this value must be shared across all children
181− let selectionDemux = demux selection
99+ let selectionDemux = demux selection -- For good performance, this value must be shared across all children
182100 selectChild <- listWithKey vals $ \k v -> do
183101 let selected = demuxed selectionDemux k
184102 selectSelf <- mkChild k v selected
185103 return $ fmap ((,) k) selectSelf
186104 return $ switchPromptlyDyn $ leftmost . Map.elems <$> selectChild
187105
188−-- | Like 'selectViewListWithKey' but discards the value of the list
189−-- item widget's output 'Event'.
190−selectViewListWithKey_
191− :: forall t m k v a
192− . (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)
193− => Dynamic t k
194− -- ^ Current selection key
195− -> Dynamic t (Map k v)
196− -- ^ Dynamic key/value map
197− -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a))
198− -- ^ Function to create a widget for a given key from Dynamic value
199− -- and Dynamic Bool indicating if this widget is currently selected
200− -> m (Event t k)
201− -- ^ Event that fires when any child's return Event fires. Contains
202− -- key of an arbitrary firing widget.
203−selectViewListWithKey_ selection vals mkChild =
204− fmap fst <$> selectViewListWithKey selection vals mkChild
106+selectViewListWithKey_ :: forall t m k v a. (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)
107+ => Dynamic t k -- ^ Current selection key
108+ -> Dynamic t (Map k v) -- ^ Dynamic key/value map
109+ -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -- ^ Function to create a widget for a given key from Dynamic value and Dynamic Bool indicating if this widget is currently selected
110+ -> m (Event t k) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.
111+selectViewListWithKey_ selection vals mkChild = fmap fst <$> selectViewListWithKey selection vals mkChild
205112
206−-- | Create a dynamically-changing set of widgets from a Dynamic
207−-- key/value map. Unlike the 'withKey' variants, the child widgets
208−-- are insensitive to which key they're associated with.
209−list
210− :: (Ord k, Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m)
211− => Dynamic t (Map k v)
212− -> (Dynamic t v -> m a)
213− -> m (Dynamic t (Map k a))
113+-- | Create a dynamically-changing set of widgets from a Dynamic key/value map.
114+-- Unlike the 'withKey' variants, the child widgets are insensitive to which key they're associated with.
115+list :: (Ord k, Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m) => Dynamic t (Map k v) -> (Dynamic t v -> m a) -> m (Dynamic t (Map k a))
214116list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
215117
216118-- | Create a dynamically-changing set of widgets from a Dynamic list.
217−simpleList
218− :: (Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m)
219− => Dynamic t [v]
220− -> (Dynamic t v -> m a)
221− -> m (Dynamic t [a])
222−simpleList xs mkChild =
223− fmap (fmap (map snd . Map.toList)) $ flip list mkChild $ fmap
224− (Map.fromList . zip [(1 :: Int) ..])
225− xs
119+simpleList :: (Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m) => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])
120+simpleList xs mkChild = fmap (fmap (map snd . Map.toList)) $ flip list mkChild $ fmap (Map.fromList . zip [(1::Int)..]) xs
src/Reflex/Dynamic.hs+207−66
@@ -17,12 +17,8 @@
1717#ifdef USE_REFLEX_OPTIMIZER
1818{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
1919#endif
20−-- |
21−-- Module:
22−-- Reflex.Dynamic
23−-- Description:
24−-- This module contains various functions for working with 'Dynamic' values.
25−-- 'Dynamic' and its primitives have been moved to the 'Reflex' class.
20+-- | This module contains various functions for working with 'Dynamic' values.
21+-- 'Dynamic' and its primitives have been moved to the 'Reflex' class.
2622module Reflex.Dynamic
2723 ( -- * Basics
2824 Dynamic -- Abstract so we can preserve the law that the current value is always equal to the most recent update
@@ -53,18 +49,15 @@ module Reflex.Dynamic
5349 , foldDynMaybe
5450 , foldDynMaybeM
5551 , joinDynThroughMap
56− , joinDynThroughIntMap
5752 , traceDyn
5853 , traceDynWith
5954 , splitDynPure
6055 , distributeMapOverDynPure
61− , distributeIntMapOverDynPure
6256 , distributeDMapOverDynPure
6357 , distributeListOverDynPure
6458 , Demux
6559 , demux
6660 , demuxed
67− -- * Miscellaneous
6861 -- Things that probably aren't very useful:
6962 , HList (..)
7063 , FHList (..)
@@ -74,14 +67,34 @@ module Reflex.Dynamic
7467 , AllAreFunctors (..)
7568 , HListPtr (..)
7669 , distributeFHListOverDynPure
77− -- * Unsafe
70+ -- Unsafe
7871 , unsafeDynamic
72+ -- * Deprecated functions
73+ , apDyn
74+ , attachDyn
75+ , attachDynWith
76+ , attachDynWithMaybe
77+ , collectDyn
78+ , combineDyn
79+ , distributeDMapOverDyn
80+ , distributeFHListOverDyn
81+ , forDyn
82+ , getDemuxed
83+ , joinDyn
84+ , mapDyn
85+ , mconcatDyn
86+ , nubDyn
87+ , splitDyn
88+ , tagDyn
89+ , uniqDyn
90+ , uniqDynBy
7991 ) where
8092
8193import Data.Functor.Compose
8294import Data.Functor.Misc
8395import Reflex.Class
8496
97+import Control.Applicative ((<*>))
8598import Control.Monad
8699import Control.Monad.Fix
87100import Control.Monad.Identity
@@ -89,14 +102,11 @@ import Data.Align
89102import Data.Dependent.Map (DMap)
90103import qualified Data.Dependent.Map as DMap
91104import Data.Dependent.Sum (DSum (..))
92−import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))
93−import Data.IntMap (IntMap)
94−import qualified Data.IntMap as IntMap
105+import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), GOrdering (..))
95106import Data.Map (Map)
96107import Data.Maybe
97−import Data.Monoid ((<>))
108+import Data.Monoid
98109import Data.These
99−import Data.Type.Equality ((:~:) (..))
100110
101111import Debug.Trace
102112
@@ -119,7 +129,7 @@ holdUniqDyn = holdUniqDynBy (==)
119129holdUniqDynBy :: (Reflex t, MonadHold t m, MonadFix m) => (a -> a -> Bool) -> Dynamic t a -> m (Dynamic t a)
120130holdUniqDynBy eq = scanDynMaybe id (\new old -> if new `eq` old then Nothing else Just new)
121131
122−-- | @/Dynamic Maybe/@ that can only update from @/Nothing/@ to @/Just/@ or @/Just/@ to @/Just/@ (i.e., cannot revert to @/Nothing/@)
132+-- | Dynamic Maybe that can only update from Nothing to Just or Just to Just (i.e., cannot revert to Nothing)
123133improvingMaybe :: (Reflex t, MonadHold t m, MonadFix m) => Dynamic t (Maybe a) -> m (Dynamic t (Maybe a))
124134improvingMaybe = scanDynMaybe id (\new _ -> if isJust new then Just new else Nothing)
125135
@@ -163,7 +173,7 @@ foldDynMaybe = accumMaybeDyn . flip
163173foldDynMaybeM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe b)) -> b -> Event t a -> m (Dynamic t b)
164174foldDynMaybeM = accumMaybeMDyn . flip
165175
166−-- | Create a new 'Dynamic' that counts the occurrences of the 'Event'.
176+-- | Create a new 'Dynamic' that counts the occurences of the 'Event'.
167177count :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Dynamic t b)
168178count e = holdDyn 0 =<< zipListWithEvent const (iterate (+1) 1) e
169179
@@ -184,9 +194,9 @@ switchDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a
184194switchDyn d = switch (current d)
185195
186196-- | Switches to the new 'Event' whenever it receives one. Switching occurs
187−-- __before__ the inner 'Event' fires - so if the 'Dynamic' changes and both the
197+-- *before* the inner 'Event' fires - so if the 'Dynamic' changes and both the
188198-- old and new inner Events fire simultaneously, the output will fire with the
189−-- value of the __new__ 'Event'.
199+-- value of the *new* 'Event'.
190200--
191201-- Prefer 'switchDyn' to this where possible. The timing requirements that
192202-- switching before imposes are likely to bring down your app unless you are
@@ -206,30 +216,28 @@ splitDynPure d = (fmap fst d, fmap snd d)
206216distributeMapOverDynPure :: (Reflex t, Ord k) => Map k (Dynamic t v) -> Dynamic t (Map k v)
207217distributeMapOverDynPure = fmap dmapToMap . distributeDMapOverDynPure . mapWithFunctorToDMap
208218
209−-- | Convert an 'IntMap' with 'Dynamic' elements into a 'Dynamic' of an 'IntMap' with
210−-- non-'Dynamic' elements.
211−distributeIntMapOverDynPure :: (Reflex t) => IntMap (Dynamic t v) -> Dynamic t (IntMap v)
212−distributeIntMapOverDynPure = fmap dmapToIntMap . distributeDMapOverDynPure . intMapWithFunctorToDMap
213−
214219-- | Convert a list with 'Dynamic' elements into a 'Dynamic' of a list with
215220-- non-'Dynamic' elements, preserving the order of the elements.
216−{-# DEPRECATED distributeListOverDynPure "Use 'distributeListOverDyn' instead" #-}
217221distributeListOverDynPure :: Reflex t => [Dynamic t v] -> Dynamic t [v]
218−distributeListOverDynPure = distributeListOverDyn
222+distributeListOverDynPure =
223+ fmap (map fromDSum . DMap.toAscList) .
224+ distributeDMapOverDynPure .
225+ DMap.fromDistinctAscList .
226+ zipWith toDSum [0..]
227+ where
228+ toDSum :: Int -> Dynamic t a -> DSum (Const2 Int a) (Dynamic t)
229+ toDSum k v = Const2 k :=> v
230+ fromDSum :: DSum (Const2 Int a) Identity -> a
231+ fromDSum (Const2 _ :=> Identity v) = v
219232
220233--TODO: Generalize this to functors other than Maps
221234-- | Combine a 'Dynamic' of a 'Map' of 'Dynamic's into a 'Dynamic'
222235-- with the current values of the 'Dynamic's in a map.
223236joinDynThroughMap :: forall t k a. (Reflex t, Ord k) => Dynamic t (Map k (Dynamic t a)) -> Dynamic t (Map k a)
224−joinDynThroughMap = (distributeMapOverDynPure =<<)
225−
226−-- | Combine a 'Dynamic' of an 'IntMap' of 'Dynamic's into a 'Dynamic'
227−-- with the current values of the 'Dynamic's in a map.
228−joinDynThroughIntMap :: forall t a. (Reflex t) => Dynamic t (IntMap (Dynamic t a)) -> Dynamic t (IntMap a)
229−joinDynThroughIntMap = (distributeIntMapOverDynPure =<<)
237+joinDynThroughMap = joinDyn . fmap distributeMapOverDynPure
230238
231239-- | Print the value of the 'Dynamic' when it is first read and on each
232−-- subsequent change that is observed (as 'traceEvent'), prefixed with the
240+-- subsequent change that is observed (as traceEvent), prefixed with the
233241-- provided string. This should /only/ be used for debugging.
234242--
235243-- Note: Just like Debug.Trace.trace, the value will only be shown if something
@@ -239,7 +247,7 @@ traceDyn s = traceDynWith $ \x -> s <> ": " <> show x
239247
240248-- | Print the result of applying the provided function to the value
241249-- of the 'Dynamic' when it is first read and on each subsequent change
242−-- that is observed (as 'traceEvent'). This should /only/ be used for
250+-- that is observed (as traceEvent). This should /only/ be used for
243251-- debugging.
244252--
245253-- Note: Just like Debug.Trace.trace, the value will only be shown if something
@@ -255,35 +263,36 @@ traceDynWith f d =
255263-- | Replace the value of the 'Event' with the current value of the 'Dynamic'
256264-- each time the 'Event' occurs.
257265--
258−-- Note: @/tagPromptlyDyn d e/@ differs from @/tag (current d) e/@ in the case that @/e/@ is firing
259−-- at the same time that @/d/@ is changing. With @/tagPromptlyDyn d e/@, the __new__ value of @/d/@
260−-- will replace the value of @/e/@, whereas with @/tag (current d) e/@, the __old__ value
266+-- Note: `tagPromptlyDyn d e` differs from `tag (current d) e` in the case that `e` is firing
267+-- at the same time that `d` is changing. With `tagPromptlyDyn d e`, the *new* value of `d`
268+-- will replace the value of `e`, whereas with `tag (current d) e`, the *old* value
261269-- will be used, since the 'Behavior' won't be updated until the end of the frame.
262270-- Additionally, this means that the output 'Event' may not be used to directly change
263−-- the input 'Dynamic', because that would mean its value depends on itself. __When creating__
264−-- __cyclic data flows, generally @/tag (current d) e/@ is preferred.__
271+-- the input 'Dynamic', because that would mean its value depends on itself. When creating
272+-- cyclic data flows, generally `tag (current d) e` is preferred.
265273tagPromptlyDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a
266274tagPromptlyDyn = attachPromptlyDynWith const
267275
268276-- | Attach the current value of the 'Dynamic' to the value of the
269277-- 'Event' each time it occurs.
270278--
271−-- Note: @/attachPromptlyDyn d/@ is not the same as @/attach (current d)/@. See 'tagPromptlyDyn' for details.
279+-- Note: `attachPromptlyDyn d` is not the same as `attach (current d)`. See 'tagPromptlyDyn' for details.
272280attachPromptlyDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b)
273281attachPromptlyDyn = attachPromptlyDynWith (,)
274282
275283-- | Combine the current value of the 'Dynamic' with the value of the
276284-- 'Event' each time it occurs.
277285--
278−-- Note: @/attachPromptlyDynWith f d/@ is not the same as @/attachWith f (current d)/@. See 'tagPromptlyDyn' for details.
286+-- Note: `attachPromptlyDynWith f d` is not the same as `attachWith f (current d)`. See 'tagPromptlyDyn' for details.
279287attachPromptlyDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c
280288attachPromptlyDynWith f = attachPromptlyDynWithMaybe $ \a b -> Just $ f a b
281289
282−-- | Create a new 'Event' by combining the value at each occurrence with the
290+-- | Create a new 'Event' by combining the value at each occurence with the
283291-- current value of the 'Dynamic' value and possibly filtering if the combining
284292-- function returns 'Nothing'.
285293--
286−-- Note: @/attachPromptlyDynWithMaybe f d/@ is not the same as @/attachWithMaybe f (current d)/@. See 'tagPromptlyDyn' for details.
294+-- Note: `attachPromptlyDynWithMaybe f d` is not the same as `attachWithMaybe f
295+-- (current d)`. See 'tagPromptlyDyn' for details.
287296attachPromptlyDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c
288297attachPromptlyDynWithMaybe f d e =
289298 let e' = attach (current d) e
@@ -292,8 +301,8 @@ attachPromptlyDynWithMaybe f d e =
292301 These (_, b) a -> f a b -- Both events are firing, so use the newer value
293302 That _ -> Nothing -- The tagging event isn't firing, so don't fire
294303
295−-- | Factor a @/Dynamic t (Maybe a)/@ into a @/Dynamic t (Maybe (Dynamic t a))/@,
296−-- such that the outer 'Dynamic' is updated only when the "Maybe"'s constructor
304+-- | Factor a @Dynamic t (Maybe a)@ into a @Dynamic t (Maybe (Dynamic t a))@,
305+-- such that the outer 'Dynamic' is updated only when the 'Maybe''s constructor
297306-- chages from 'Nothing' to 'Just' or vice-versa. Whenever the constructor
298307-- becomes 'Just', an inner 'Dynamic' will be provided, whose value will track
299308-- the 'a' inside the 'Just'; when the constructor becomes 'Nothing', the
@@ -308,8 +317,6 @@ maybeDyn = fmap (fmap unpack) . eitherDyn . fmap pack
308317 Left _ -> Nothing
309318 Right a -> Just a
310319
311−-- | Turns a 'Dynamic t (Either a b)' into a 'Dynamic t (Either (Dynamic t a) (Dynamic t b))' such that
312−-- the outer 'Dynamic' is updated only when the 'Either' constructor changes (e.g., from 'Left' to 'Right').
313320eitherDyn :: forall t a b m. (Reflex t, MonadFix m, MonadHold t m) => Dynamic t (Either a b) -> m (Dynamic t (Either (Dynamic t a) (Dynamic t b)))
314321eitherDyn = fmap (fmap unpack) . factorDyn . fmap eitherToDSum
315322 where unpack :: DSum (EitherTag a b) (Compose (Dynamic t) Identity) -> Either (Dynamic t a) (Dynamic t b)
@@ -317,23 +324,26 @@ eitherDyn = fmap (fmap unpack) . factorDyn . fmap eitherToDSum
317324 LeftTag :=> Compose a -> Left $ coerceDynamic a
318325 RightTag :=> Compose b -> Right $ coerceDynamic b
319326
320−-- | Factor a 'Dynamic t DSum' into a 'Dynamic' 'DSum' containing nested 'Dynamic' values.
321−-- The outer 'Dynamic' updates only when the key of the 'DSum' changes, while the update of the inner
322−-- 'Dynamic' represents updates within the current key.
323−factorDyn :: forall t m k v. (Reflex t, MonadHold t m, GEq k)
324− => Dynamic t (DSum k v) -> m (Dynamic t (DSum k (Compose (Dynamic t) v)))
325−factorDyn d = buildDynamic (sample (current d) >>= holdKey) update where
326− update :: Event t (DSum k (Compose (Dynamic t) v))
327− update = flip push (updated d) $ \(newKey :=> newVal) -> do
328− (oldKey :=> _) <- sample (current d)
329− case newKey `geq` oldKey of
330− Just Refl -> return Nothing
331− Nothing -> Just <$> holdKey (newKey :=> newVal)
332−
333− holdKey (k :=> v) = do
334− inner' <- filterEventKey k (updated d)
335− inner <- holdDyn v inner'
336− return $ k :=> Compose inner
327+factorDyn :: forall t m k v. (Reflex t, MonadFix m, MonadHold t m, GEq k) => Dynamic t (DSum k v) -> m (Dynamic t (DSum k (Compose (Dynamic t) v)))
328+factorDyn d = do
329+ let inner :: forall m' a. (MonadFix m', MonadHold t m') => k a -> v a -> m' (Dynamic t (v a))
330+ inner k v0 = holdDyn v0 . fmapMaybe id =<< takeWhileE isJust newVal
331+ where newVal = ffor (updated d) $ \(newK :=> newV) -> case newK `geq` k of
332+ Just Refl -> Just newV
333+ Nothing -> Nothing
334+ getInitial = do
335+ k0 :=> (v0 :: v a) <- sample $ current d
336+ i0 <- inner k0 v0
337+ return $ k0 :=> Compose i0
338+ update = flip push (updated d) $ \(newKey :=> newVal) -> do
339+ (oldKey :=> _) <- sample $ current d
340+ case newKey `geq` oldKey of
341+ Just Refl -> return Nothing
342+ Nothing -> do
343+ newInner <- inner newKey newVal
344+ return $ Just $ newKey :=> Compose newInner
345+ o0 <- getInitial --TODO: Figure out how to get this to run inside something like the first argument to buildDynamic
346+ holdDyn o0 update
337347
338348--------------------------------------------------------------------------------
339349-- Demux
@@ -348,7 +358,7 @@ factorDyn d = buildDynamic (sample (current d) >>= holdKey) update where
348358--
349359-- > demuxed (demux d) k === fmap (== k) d
350360--
351−-- However, when 'demuxed' is used multiple times, the complexity is only
361+-- However, the when getDemuxed is used multiple times, the complexity is only
352362-- /O(log(n))/, rather than /O(n)/ for fmap.
353363data Demux t k = Demux { demuxValue :: Behavior t k
354364 , demuxSelector :: EventSelector t (Const2 k Bool)
@@ -502,7 +512,7 @@ instance AllAreFunctors f t => AllAreFunctors f (h ': t) where
502512
503513-- | Convert a datastructure whose constituent parts are all 'Dynamic's into a
504514-- single 'Dynamic' whose value represents all the current values of the input's
505−-- constituent 'Dynamic's.
515+-- consitutent 'Dynamic's.
506516collectDynPure :: ( RebuildSortedHList (HListElems b)
507517 , IsHList a, IsHList b
508518 , AllAreFunctors (Dynamic t) (HListElems b)
@@ -543,3 +553,134 @@ instance IsHList (a, b, c, d, e, f) where
543553#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800
544554 _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
545555#endif
556+
557+--------------------------------------------------------------------------------
558+-- Deprecated functions
559+--------------------------------------------------------------------------------
560+
561+-- | Map a function over a 'Dynamic'.
562+{-# DEPRECATED mapDyn "Use 'return . fmap f' instead of 'mapDyn f'; consider eliminating monadic style" #-}
563+mapDyn :: (Reflex t, Monad m) => (a -> b) -> Dynamic t a -> m (Dynamic t b)
564+mapDyn f = return . fmap f
565+
566+-- | Flipped version of 'mapDyn'.
567+{-# DEPRECATED forDyn "Use 'return . ffor a' instead of 'forDyn a'; consider eliminating monadic style" #-}
568+forDyn :: (Reflex t, Monad m) => Dynamic t a -> (a -> b) -> m (Dynamic t b)
569+forDyn a = return . ffor a
570+
571+-- | Split the 'Dynamic' into two 'Dynamic's, each taking the respective value
572+-- of the tuple.
573+{-# DEPRECATED splitDyn "Use 'return . splitDynPure' instead; consider eliminating monadic style" #-}
574+splitDyn :: (Reflex t, Monad m) => Dynamic t (a, b) -> m (Dynamic t a, Dynamic t b)
575+splitDyn = return . splitDynPure
576+
577+-- | Merge the 'Dynamic' values using their 'Monoid' instance.
578+{-# DEPRECATED mconcatDyn "Use 'return . mconcat' instead; consider eliminating monadic style" #-}
579+mconcatDyn :: forall t m a. (Reflex t, Monad m, Monoid a) => [Dynamic t a] -> m (Dynamic t a)
580+mconcatDyn = return . mconcat
581+
582+-- | This function no longer needs to be monadic; see 'distributeMapOverDynPure'.
583+{-# DEPRECATED distributeDMapOverDyn "Use 'return . distributeDMapOverDynPure' instead; consider eliminating monadic style" #-}
584+distributeDMapOverDyn :: (Reflex t, Monad m, GCompare k) => DMap k (Dynamic t) -> m (Dynamic t (DMap k Identity))
585+distributeDMapOverDyn = return . distributeDMapOverDynPure
586+
587+-- | Merge two 'Dynamic's into a new one using the provided function. The new
588+-- 'Dynamic' changes its value each time one of the original 'Dynamic's changes
589+-- its value.
590+{-# DEPRECATED combineDyn "Use 'return (zipDynWith f a b)' instead of 'combineDyn f a b'; consider eliminating monadic style" #-}
591+combineDyn :: forall t m a b c. (Reflex t, Monad m) => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> m (Dynamic t c)
592+combineDyn f a b = return $ zipDynWith f a b
593+
594+-- | A psuedo applicative version of ap for 'Dynamic'. Example useage:
595+--
596+-- > do
597+-- > person <- Person `mapDyn` dynFirstName
598+-- > `apDyn` dynListName
599+-- > `apDyn` dynAge
600+-- > `apDyn` dynAddress
601+{-# DEPRECATED apDyn "Use 'ffor m (<*> a)' instead of 'apDyn m a'; consider eliminating monadic style, since Dynamics are now Applicative and can be used with applicative style directly" #-}
602+#ifdef USE_TEMPLATE_HASKELL
603+{-# ANN apDyn "HLint: ignore Use fmap" #-}
604+#endif
605+apDyn :: forall t m a b. (Reflex t, Monad m)
606+ => m (Dynamic t (a -> b))
607+ -> Dynamic t a
608+ -> m (Dynamic t b)
609+apDyn m a = fmap (<*> a) m
610+
611+--TODO: The pattern of using hold (sample b0) can be reused in various places as a safe way of building certain kinds of Dynamics; see if we can factor this out
612+-- | This function no longer needs to be monadic, so it has been replaced by
613+-- 'demuxed', which is pure.
614+{-# DEPRECATED getDemuxed "Use 'return . demuxed d' instead of 'getDemuxed d'; consider eliminating monadic style" #-}
615+getDemuxed :: (Reflex t, Monad m, Eq k) => Demux t k -> k -> m (Dynamic t Bool)
616+getDemuxed d = return . demuxed d
617+
618+-- | This function no longer needs to be monadic, so it has been replaced by
619+-- 'distributeFHListOverDynPure', which is pure.
620+{-# DEPRECATED distributeFHListOverDyn "Use 'return . distributeFHListOverDynPure' instead; consider eliminating monadic style" #-}
621+distributeFHListOverDyn :: forall t m l. (Reflex t, Monad m, RebuildSortedHList l) => FHList (Dynamic t) l -> m (Dynamic t (HList l))
622+distributeFHListOverDyn = return . distributeFHListOverDynPure
623+
624+-- | This function no longer needs to be monadic, so it has been replaced by
625+-- 'collectDynPure', which is pure.
626+{-# DEPRECATED collectDyn "Use 'return . collectDynPure' instead; consider eliminating monadic style" #-}
627+collectDyn :: ( RebuildSortedHList (HListElems b)
628+ , IsHList a, IsHList b
629+ , AllAreFunctors (Dynamic t) (HListElems b)
630+ , Reflex t, Monad m
631+ , HListElems a ~ FunctorList (Dynamic t) (HListElems b)
632+ ) => a -> m (Dynamic t b)
633+collectDyn = return . collectDynPure
634+
635+-- | This function has been renamed to 'tagPromptlyDyn' to clarify its
636+-- semantics.
637+{-# DEPRECATED tagDyn "Use 'tagPromptlyDyn' instead" #-}
638+tagDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a
639+tagDyn = tagPromptlyDyn
640+
641+-- | This function has been renamed to 'attachPromptlyDyn' to clarify its
642+-- semantics.
643+{-# DEPRECATED attachDyn "Use 'attachPromptlyDyn' instead" #-}
644+attachDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b)
645+attachDyn = attachPromptlyDyn
646+
647+-- | This function has been renamed to 'attachPromptlyDynWith' to clarify its
648+-- semantics.
649+{-# DEPRECATED attachDynWith "Use 'attachPromptlyDynWith' instead" #-}
650+attachDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c
651+attachDynWith = attachPromptlyDynWith
652+
653+-- | This function has been renamed to 'attachPromptlyDynWithMaybe' to clarify
654+-- its semantics.
655+{-# DEPRECATED attachDynWithMaybe "Use 'attachPromptlyDynWithMaybe' instead" #-}
656+attachDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c
657+attachDynWithMaybe = attachPromptlyDynWithMaybe
658+
659+-- | Combine an inner and outer 'Dynamic' such that the resulting 'Dynamic''s
660+-- current value will always be equal to the current value's current value, and
661+-- will change whenever either the inner or the outer (or both) values change.
662+{-# DEPRECATED joinDyn "Use 'join' instead" #-}
663+joinDyn :: Reflex t => Dynamic t (Dynamic t a) -> Dynamic t a
664+joinDyn = join
665+
666+-- | WARNING: This function is only pure if @a@'s 'Eq' instance tests
667+-- representational equality. Use 'holdUniqDyn' instead, which is pure in all
668+-- circumstances. Also, note that, unlike 'nub', this function does not prevent
669+-- all recurrences of a value, only consecutive recurrences.
670+{-# DEPRECATED nubDyn "Use 'holdUniqDyn' instead; note that it returns a MonadHold action rather than a pure Dynamic" #-}
671+nubDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a
672+nubDyn = uniqDyn
673+
674+-- | WARNING: This function is only pure if @a@'s 'Eq' instance tests
675+-- representational equality. Use 'holdUniqDyn' instead, which is pure in all
676+-- circumstances.
677+{-# DEPRECATED uniqDyn "Use 'holdUniqDyn' instead; note that it returns a MonadHold action rather than a pure Dynamic" #-}
678+uniqDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a
679+uniqDyn = uniqDynBy (==)
680+
681+-- | WARNING: This function is impure. Use 'holdUniqDynBy' instead.
682+{-# DEPRECATED uniqDynBy "Use 'holdUniqDynBy' instead; note that it returns a MonadHold action rather than a pure Dynamic" #-}
683+uniqDynBy :: Reflex t => (a -> a -> Bool) -> Dynamic t a -> Dynamic t a
684+uniqDynBy eq d =
685+ let e' = attachWithMaybe (\x x' -> if x' `eq` x then Nothing else Just x') (current d) (updated d)
686+ in unsafeDynamic (current d) e'
src/Reflex/Dynamic/TH.hs+28−4
@@ -13,6 +13,9 @@ module Reflex.Dynamic.TH
1313 ( qDynPure
1414 , unqDyn
1515 , mkDynPure
16+ -- * Deprecated functions
17+ , qDyn
18+ , mkDyn
1619 ) where
1720
1821import Reflex.Dynamic
@@ -20,7 +23,7 @@ import Reflex.Dynamic
2023import Control.Monad.State
2124import Data.Data
2225import Data.Generics
23−import Data.Monoid ((<>))
26+import Data.Monoid
2427import qualified Language.Haskell.Exts as Hs
2528import qualified Language.Haskell.Meta.Syntax.Translate as Hs
2629import Language.Haskell.TH
@@ -44,8 +47,8 @@ qDynPure qe = do
4447 _ -> gmapM f d
4548 (e', exprsReversed) <- runStateT (gmapM f e) []
4649 let exprs = reverse exprsReversed
47− arg = foldr (\a b -> ConE 'FHCons `AppE` snd a `AppE` b) (ConE 'FHNil) exprs
48− param = foldr (\a b -> ConP 'HCons [VarP (fst a), b]) (ConP 'HNil []) exprs
50+ arg = foldr (\a b -> ConE 'FHCons `AppE` a `AppE` b) (ConE 'FHNil) $ map snd exprs
51+ param = foldr (\a b -> ConP 'HCons [VarP a, b]) (ConP 'HNil []) $ map fst exprs
4952 [| $(return $ LamE [param] e') <$> distributeFHListOverDynPure $(return arg) |]
5053
5154-- | Antiquote a 'Dynamic' expression. This can /only/ be used inside of a
@@ -81,7 +84,7 @@ mkDynPure = QuasiQuoter
8184 }
8285
8386mkDynExp :: String -> Q Exp
84−mkDynExp s = case Hs.parseExpWithMode Hs.defaultParseMode { Hs.extensions = [ Hs.EnableExtension Hs.TemplateHaskell ] } s of
87+mkDynExp s = case Hs.parseExpWithMode (Hs.defaultParseMode { Hs.extensions = [ Hs.EnableExtension Hs.TemplateHaskell ] }) s of
8588 Hs.ParseFailed (Hs.SrcLoc _ l c) err -> fail $ "mkDyn:" <> show l <> ":" <> show c <> ": " <> err
8689 Hs.ParseOk e -> qDynPure $ return $ everywhere (id `extT` reinstateUnqDyn) $ Hs.toExp $ everywhere (id `extT` antiE) e
8790 where TH.Name (TH.OccName occName) (TH.NameG _ _ (TH.ModName modName)) = 'unqMarker
@@ -104,3 +107,24 @@ mkDynExp s = case Hs.parseExpWithMode Hs.defaultParseMode { Hs.extensions = [ Hs
104107 reinstateUnqDyn (TH.Name (TH.OccName occName') (TH.NameQ (TH.ModName modName')))
105108 | modName == modName' && occName == occName' = 'unqMarker
106109 reinstateUnqDyn x = x
110+
111+--------------------------------------------------------------------------------
112+-- Deprecated
113+--------------------------------------------------------------------------------
114+
115+{-# DEPRECATED qDyn "Instead of $(qDyn x), use return $(qDynPure x)" #-}
116+-- | Like 'qDynPure', but wraps its result monadically using 'return'. This is
117+-- no longer necessary, due to 'Dynamic' being an instance of 'Functor'.
118+qDyn :: Q Exp -> Q Exp
119+qDyn qe = [| return $(qDynPure qe) |]
120+
121+{-# DEPRECATED mkDyn "Instead of [mkDyn| x |], use return [mkDynPure| x |]" #-}
122+-- | Like 'mkDynPure', but wraps its result monadically using 'return'. This is
123+-- no longer necessary, due to 'Dynamic' being an instance of 'Functor'.
124+mkDyn :: QuasiQuoter
125+mkDyn = QuasiQuoter
126+ { quoteExp = \s -> [| return $(mkDynExp s) |]
127+ , quotePat = error "mkDyn: pattern splices are not supported"
128+ , quoteType = error "mkDyn: type splices are not supported"
129+ , quoteDec = error "mkDyn: declaration splices are not supported"
130+ }
src/Reflex/DynamicWriter/Base.hs+8−40
@@ -9,7 +9,6 @@
99{-# LANGUAGE TupleSections #-}
1010{-# LANGUAGE TypeFamilies #-}
1111{-# LANGUAGE UndecidableInstances #-}
12−{-# LANGUAGE StandaloneDeriving #-}
1312#ifdef USE_REFLEX_OPTIMIZER
1413{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
1514#endif
@@ -22,8 +21,6 @@ module Reflex.DynamicWriter.Base
2221import Control.Monad.Exception
2322import Control.Monad.Identity
2423import Control.Monad.IO.Class
25−import Control.Monad.Morph
26−import Control.Monad.Primitive
2724import Control.Monad.Reader
2825import Control.Monad.Ref
2926import Control.Monad.State.Strict
@@ -36,22 +33,21 @@ import Data.IntMap (IntMap)
3633import qualified Data.IntMap as IntMap
3734import Data.Map (Map)
3835import qualified Data.Map as Map
39−import Data.Semigroup (Semigroup(..))
36+import Data.Semigroup
4037import Data.Some (Some)
4138import Data.These
42−
43−import Reflex.Adjustable.Class
4439import Reflex.Class
4540import Reflex.DynamicWriter.Class
46−import Reflex.EventWriter.Class (EventWriter, tellEvent)
4741import Reflex.Host.Class
48−import qualified Data.Patch.MapWithMove as MapWithMove
42+import qualified Reflex.Patch.MapWithMove as MapWithMove
4943import Reflex.PerformEvent.Class
5044import Reflex.PostBuild.Class
51−import Reflex.Query.Class
5245import Reflex.Requester.Class
5346import Reflex.TriggerEvent.Class
5447
48+instance MonadTrans (DynamicWriterT t w) where
49+ lift = DynamicWriterT . lift
50+
5551mapIncrementalMapValues :: (Reflex t, Patch (p v), Patch (p v'), PatchTarget (p v) ~ f v, PatchTarget (p v') ~ f v', Functor p, Functor f) => (v -> v') -> Incremental t (p v) -> Incremental t (p v')
5652mapIncrementalMapValues f = unsafeMapIncremental (fmap f) (fmap f)
5753
@@ -86,24 +82,8 @@ mergeDynIncrementalWithMove a = unsafeBuildIncremental (mapM (sample . current)
8682 noLongerMovedMap = Map.fromList $ fmap (, ()) noLongerMoved
8783 in Map.differenceWith (\e _ -> Just $ MapWithMove.nodeInfoSetTo Nothing e) pWithNewVals noLongerMovedMap --TODO: Check if any in the second map are not covered?
8884
89−-- | A basic implementation of 'DynamicWriter'.
90−newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT [Dynamic t w] m a }
91− -- The list is kept in reverse order
92− deriving
93− ( Functor
94− , Applicative
95− , Monad
96− , MonadTrans
97− , MFunctor
98− , MonadIO
99− , MonadFix
100− , MonadAsyncException
101− , MonadException
102− )
103−
104−deriving instance MonadHold t m => MonadHold t (DynamicWriterT t w m)
105−deriving instance MonadSample t m => MonadSample t (DynamicWriterT t w m)
106−
85+-- | A basic implementation of 'MonadDynamicWriter'.
86+newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT [Dynamic t w] m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadHold t, MonadSample t, MonadAsyncException, MonadException) -- The list is kept in reverse order
10787
10888instance MonadRef m => MonadRef (DynamicWriterT t w m) where
10989 type Ref (DynamicWriterT t w m) = Ref m
@@ -125,7 +105,7 @@ runDynamicWriterT (DynamicWriterT a) = do
125105 (result, ws) <- runStateT a []
126106 return (result, mconcat $ reverse ws)
127107
128−instance (Monad m, Monoid w, Reflex t) => DynamicWriter t w (DynamicWriterT t w m) where
108+instance (Monad m, Monoid w, Reflex t) => MonadDynamicWriter t w (DynamicWriterT t w m) where
129109 tellDyn w = DynamicWriterT $ modify (w :)
130110
131111instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where
@@ -150,10 +130,6 @@ instance MonadState s m => MonadState s (DynamicWriterT t w m) where
150130 get = lift get
151131 put = lift . put
152132
153−instance PrimMonad m => PrimMonad (DynamicWriterT t w m) where
154− type PrimState (DynamicWriterT t w m) = PrimState m
155− primitive = lift . primitive
156−
157133newtype DynamicWriterTLoweredResult t w v a = DynamicWriterTLoweredResult (v a, Dynamic t w)
158134
159135-- | When the execution of a 'DynamicWriterT' action is adjusted using
@@ -236,11 +212,3 @@ instance Requester t m => Requester t (DynamicWriterT t w m) where
236212 type Response (DynamicWriterT t w m) = Response m
237213 requesting = lift . requesting
238214 requesting_ = lift . requesting_
239−
240−instance (MonadQuery t q m, Monad m) => MonadQuery t q (DynamicWriterT t w m) where
241− tellQueryIncremental = lift . tellQueryIncremental
242− askQueryResult = lift askQueryResult
243− queryIncremental = lift . queryIncremental
244−
245−instance EventWriter t w m => EventWriter t w (DynamicWriterT t v m) where
246− tellEvent = lift . tellEvent
src/Reflex/DynamicWriter/Class.hs+6−10
@@ -1,28 +1,24 @@
1−-- | This module defines the 'DynamicWriter' class.
2−{-# LANGUAGE ConstraintKinds #-}
1+-- | This module defines the 'MonadDynamicWriter' class.
32{-# LANGUAGE CPP #-}
43{-# LANGUAGE FlexibleInstances #-}
54{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
66{-# LANGUAGE UndecidableInstances #-}
77#ifdef USE_REFLEX_OPTIMIZER
88{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
99#endif
1010module Reflex.DynamicWriter.Class
11− ( MonadDynamicWriter
12− , DynamicWriter(..)
11+ ( MonadDynamicWriter (..)
1312 ) where
1413
1514import Control.Monad.Reader (ReaderT, lift)
1615import Reflex.Class (Dynamic)
1716
18−{-# DEPRECATED MonadDynamicWriter "Use 'DynamicWriter' instead" #-}
19−-- | Type synonym for 'DynamicWriter'
20−type MonadDynamicWriter = DynamicWriter
21−
2217-- | 'MonadDynamicWriter' efficiently collects 'Dynamic' values using 'tellDyn'
2318-- and combines them monoidally to provide a 'Dynamic' result.
24−class (Monad m, Monoid w) => DynamicWriter t w m | m -> t w where
19+class (Monad m, Monoid w) => MonadDynamicWriter t w m | m -> t w where
2520 tellDyn :: Dynamic t w -> m ()
2621
27−instance DynamicWriter t w m => DynamicWriter t w (ReaderT r m) where
22+instance MonadDynamicWriter t w m => MonadDynamicWriter t w (ReaderT r m) where
2823 tellDyn = lift . tellDyn
24+
src/Reflex/EventWriter/Base.hs+63−99
@@ -18,14 +18,11 @@ module Reflex.EventWriter.Base
1818 , runEventWriterT
1919 , runWithReplaceEventWriterTWith
2020 , sequenceDMapWithAdjustEventWriterTWith
21− , mapEventWriterT
2221 , withEventWriterT
2322 ) where
2423
25−import Reflex.Adjustable.Class
2624import Reflex.Class
2725import Reflex.EventWriter.Class (EventWriter, tellEvent)
28−import Reflex.DynamicWriter.Class (DynamicWriter, tellDyn)
2926import Reflex.Host.Class
3027import Reflex.PerformEvent.Class
3128import Reflex.PostBuild.Class
@@ -35,14 +32,12 @@ import Reflex.TriggerEvent.Class
3532
3633import Control.Monad.Exception
3734import Control.Monad.Identity
38−import Control.Monad.Morph
39−import Control.Monad.Primitive
4035import Control.Monad.Reader
4136import Control.Monad.Ref
4237import Control.Monad.State.Strict
43−import Data.Dependent.Map (DMap)
38+import Data.Dependent.Map (DMap, DSum (..))
4439import qualified Data.Dependent.Map as DMap
45−import Data.Dependent.Sum (DSum (..))
40+import Data.Foldable
4641import Data.Functor.Compose
4742import Data.Functor.Misc
4843import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))
@@ -50,7 +45,6 @@ import Data.IntMap.Strict (IntMap)
5045import qualified Data.IntMap.Strict as IntMap
5146import Data.List.NonEmpty (NonEmpty (..))
5247import Data.Map (Map)
53−import qualified Data.Map as Map
5448import Data.Semigroup
5549import Data.Some (Some)
5650import Data.Tuple
@@ -60,7 +54,7 @@ import Unsafe.Coerce
6054
6155{-# DEPRECATED TellId "Do not construct this directly; use tellId instead" #-}
6256newtype TellId w x
63− = TellId Int -- ^ WARNING: Do not construct this directly; use 'tellId' instead
57+ = TellId Int -- ^ WARNING: Do not construct this directly; use 'TellId' instead
6458 deriving (Show, Eq, Ord, Enum)
6559
6660tellId :: Int -> TellId w w
@@ -98,17 +92,7 @@ data EventWriterState t w = EventWriterState
9892
9993-- | A basic implementation of 'EventWriter'.
10094newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (EventWriterState t w) m a }
101− deriving
102− ( Functor
103− , Applicative
104− , Monad
105− , MonadTrans
106− , MFunctor
107− , MonadFix
108− , MonadIO
109− , MonadException
110− , MonadAsyncException
111− )
95+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
11296
11397-- | Run a 'EventWriterT' action.
11498runEventWriterT :: forall t m w a. (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)
@@ -128,6 +112,9 @@ instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m
128112 , _eventWriterState_told = (tellId myId :=> w) : _eventWriterState_told old
129113 }
130114
115+instance MonadTrans (EventWriterT t w) where
116+ lift = EventWriterT . lift
117+
131118instance MonadSample t m => MonadSample t (EventWriterT t w m) where
132119 sample = lift . sample
133120
@@ -142,14 +129,12 @@ instance MonadHold t m => MonadHold t (EventWriterT t w m) where
142129 buildDynamic a0 = lift . buildDynamic a0
143130 {-# INLINABLE headE #-}
144131 headE = lift . headE
145− {-# INLINABLE now #-}
146− now = lift now
147132
148133instance (Reflex t, Adjustable t m, MonadHold t m, Semigroup w) => Adjustable t (EventWriterT t w m) where
149134 runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
150− traverseIntMapWithKeyWithAdjust = sequenceIntMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') mergeIntIncremental coincidencePatchIntMap
151− traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith mergeMapIncremental coincidencePatchMap
152− traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith mergeMapIncrementalWithMove coincidencePatchMapWithMove
135+ traverseIntMapWithKeyWithAdjust = sequenceIntMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElements mergeIntIncremental
136+ traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElements mergeMapIncremental
137+ traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElements mergeMapIncrementalWithMove
153138
154139instance Requester t m => Requester t (EventWriterT t w m) where
155140 type Request (EventWriterT t w m) = Request m
@@ -168,33 +153,26 @@ runWithReplaceEventWriterTWith :: forall m t w a b. (Reflex t, MonadHold t m, Se
168153 -> EventWriterT t w m (a, Event t b)
169154runWithReplaceEventWriterTWith f a0 a' = do
170155 (result0, result') <- f (runEventWriterT a0) $ fmapCheap runEventWriterT a'
171− tellEvent =<< switchHoldPromptOnly (snd result0) (fmapCheap snd result')
156+ request <- holdDyn (snd result0) $ fmapCheap snd result'
157+ -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)
158+ tellEvent $ coincidence $ updated request
159+ tellEvent $ switch $ current request
172160 return (fst result0, fmapCheap fst result')
173161
174162-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceIntMapWithAdjust'.
175−sequenceIntMapWithAdjustEventWriterTWith
176− :: forall t m p w v v'
177− . ( Reflex t
178− , MonadHold t m
179− , Semigroup w
180− , Functor p
181− , Patch (p (Event t w))
182− , PatchTarget (p (Event t w)) ~ IntMap (Event t w)
183− , Patch (p w)
184− , PatchTarget (p w) ~ IntMap w
185− )
186− => ( (IntMap.Key -> v -> m (Event t w, v'))
187− -> IntMap v
188− -> Event t (p v)
189− -> EventWriterT t w m (IntMap (Event t w, v'), Event t (p (Event t w, v')))
190− )
191− -> (Incremental t (p (Event t w)) -> Event t (PatchTarget (p w)))
192− -> (Event t (p (Event t w)) -> Event t (p w))
193− -> (IntMap.Key -> v -> EventWriterT t w m v')
194− -> IntMap v
195− -> Event t (p v)
196− -> EventWriterT t w m (IntMap v', Event t (p v'))
197−sequenceIntMapWithAdjustEventWriterTWith base mergePatchIncremental coincidencePatch f dm0 dm' = do
163+sequenceIntMapWithAdjustEventWriterTWith :: forall t m p w v v'. (Reflex t, MonadHold t m, Semigroup w, Semigroup w, Functor p, Patch (p (Event t w)), PatchTarget (p (Event t w)) ~ IntMap (Event t w))
164+ => ( (IntMap.Key -> v -> m (Event t w, v'))
165+ -> IntMap v
166+ -> Event t (p v)
167+ -> EventWriterT t w m (IntMap (Event t w, v'), Event t (p (Event t w, v')))
168+ )
169+ -> (p (Event t w) -> [Event t w])
170+ -> (Incremental t (p (Event t w)) -> Event t (IntMap w))
171+ -> (IntMap.Key -> v -> EventWriterT t w m v')
172+ -> IntMap v
173+ -> Event t (p v)
174+ -> EventWriterT t w m (IntMap v', Event t (p v'))
175+sequenceIntMapWithAdjustEventWriterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do
198176 let f' :: IntMap.Key -> v -> m (Event t w, v')
199177 f' k v = swap <$> runEventWriterT (f k v)
200178 (children0, children') <- base f' dm0 dm'
@@ -204,39 +182,26 @@ sequenceIntMapWithAdjustEventWriterTWith base mergePatchIncremental coincidenceP
204182 requests0 = fmap fst children0
205183 requests' :: Event t (p (Event t w))
206184 requests' = fmapCheap (fmap fst) children'
207− e <- switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch requests0 requests'
208− tellEvent $ fforMaybeCheap e $ \m ->
209− case IntMap.elems m of
210− [] -> Nothing
211− h : t -> Just $ sconcat $ h :| t
185+ childRequestMap :: Incremental t (p (Event t w)) <- holdIncremental requests0 requests'
186+ tellEventsPromptly requests' patchNewElements $ mergePatchIncremental childRequestMap
212187 return (result0, result')
213188
214189-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.
215−sequenceDMapWithAdjustEventWriterTWith
216− :: forall t m p p' w k v v'
217− . ( Reflex t
218− , MonadHold t m
219− , Semigroup w
220− , Patch (p' (Some k) (Event t w))
221− , PatchTarget (p' (Some k) (Event t w)) ~ Map (Some k) (Event t w)
222− , GCompare k
223− , Patch (p' (Some k) w)
224− , PatchTarget (p' (Some k) w) ~ Map (Some k) w
225− )
226− => ( (forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a))
227− -> DMap k v
228− -> Event t (p k v)
229− -> EventWriterT t w m (DMap k (Compose ((,) (Event t w)) v'), Event t (p k (Compose ((,) (Event t w)) v')))
230− )
231− -> ((forall a. Compose ((,) (Event t w)) v' a -> v' a) -> p k (Compose ((,) (Event t w)) v') -> p k v')
232− -> ((forall a. Compose ((,) (Event t w)) v' a -> Event t w) -> p k (Compose ((,) (Event t w)) v') -> p' (Some k) (Event t w))
233− -> (Incremental t (p' (Some k) (Event t w)) -> Event t (PatchTarget (p' (Some k) w)))
234− -> (Event t (p' (Some k) (Event t w)) -> Event t (p' (Some k) w))
235− -> (forall a. k a -> v a -> EventWriterT t w m (v' a))
236− -> DMap k v
237− -> Event t (p k v)
238− -> EventWriterT t w m (DMap k v', Event t (p k v'))
239−sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith mergePatchIncremental coincidencePatch f dm0 dm' = do
190+sequenceDMapWithAdjustEventWriterTWith :: forall t m p p' w k v v'. (Reflex t, MonadHold t m, Semigroup w, Patch (p' (Some k) (Event t w)), PatchTarget (p' (Some k) (Event t w)) ~ Map (Some k) (Event t w))
191+ => ( (forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a))
192+ -> DMap k v
193+ -> Event t (p k v)
194+ -> EventWriterT t w m (DMap k (Compose ((,) (Event t w)) v'), Event t (p k (Compose ((,) (Event t w)) v')))
195+ )
196+ -> ((forall a. Compose ((,) (Event t w)) v' a -> v' a) -> p k (Compose ((,) (Event t w)) v') -> p k v')
197+ -> ((forall a. Compose ((,) (Event t w)) v' a -> Event t w) -> p k (Compose ((,) (Event t w)) v') -> p' (Some k) (Event t w))
198+ -> (p' (Some k) (Event t w) -> [Event t w])
199+ -> (Incremental t (p' (Some k) (Event t w)) -> Event t (Map (Some k) w))
200+ -> (forall a. k a -> v a -> EventWriterT t w m (v' a))
201+ -> DMap k v
202+ -> Event t (p k v)
203+ -> EventWriterT t w m (DMap k v', Event t (p k v'))
204+sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do
240205 let f' :: forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a)
241206 f' k v = Compose . swap <$> runEventWriterT (f k v)
242207 (children0, children') <- base f' dm0 dm'
@@ -246,13 +211,26 @@ sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith mergePatchI
246211 requests0 = weakenDMapWith (fst . getCompose) children0
247212 requests' :: Event t (p' (Some k) (Event t w))
248213 requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose
249− e <- switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch requests0 requests'
250− tellEvent $ fforMaybeCheap e $ \m ->
251− case Map.elems m of
252− [] -> Nothing
253− h : t -> Just $ sconcat $ h :| t
214+ childRequestMap :: Incremental t (p' (Some k) (Event t w)) <- holdIncremental requests0 requests'
215+ tellEventsPromptly requests' patchNewElements $ mergePatchIncremental childRequestMap
254216 return (result0, result')
255217
218+tellEventsPromptly
219+ :: ( Foldable f
220+ , Reflex t
221+ , EventWriter t w m
222+ )
223+ => Event t a
224+ -> (a -> [Event t w])
225+ -> Event t (f w)
226+ -> m ()
227+tellEventsPromptly requests' patchNewElements mergedChildRequestMap = do
228+ -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)
229+ tellEvent $ coincidence $ fmapCheap (mconcat . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
230+ tellEvent $ fforMaybeCheap mergedChildRequestMap $ \m -> case toList m of
231+ [] -> Nothing
232+ h : t -> Just $ sconcat $ h :| t
233+
256234instance PerformEvent t m => PerformEvent t (EventWriterT t w m) where
257235 type Performable (EventWriterT t w m) = Performable m
258236 performEvent_ = lift . performEvent_
@@ -289,15 +267,8 @@ instance (MonadQuery t q m, Monad m) => MonadQuery t q (EventWriterT t w m) wher
289267 askQueryResult = lift askQueryResult
290268 queryIncremental = lift . queryIncremental
291269
292−instance DynamicWriter t w m => DynamicWriter t w (EventWriterT t v m) where
293− tellDyn = lift . tellDyn
294−
295−instance PrimMonad m => PrimMonad (EventWriterT t w m) where
296− type PrimState (EventWriterT t w m) = PrimState m
297− primitive = lift . primitive
298−
299270-- | Map a function over the output of a 'EventWriterT'.
300−withEventWriterT :: (Semigroup w, Semigroup w', Reflex t, MonadHold t m)
271+withEventWriterT :: (Semigroup w, Semigroup w', Reflex t, MonadHold t m, MonadFix m)
301272 => (w -> w')
302273 -> EventWriterT t w m a
303274 -> EventWriterT t w' m a
@@ -308,10 +279,3 @@ withEventWriterT f ew = do
308279 return (r, e')
309280 tellEvent e
310281 return r
311−
312−-- | Change the monad underlying an EventWriterT
313−mapEventWriterT
314− :: (forall x. m x -> n x)
315− -> EventWriterT t w m a
316− -> EventWriterT t w n a
317−mapEventWriterT f (EventWriterT a) = EventWriterT $ mapStateT f a
src/Reflex/EventWriter/Class.hs+1
@@ -2,6 +2,7 @@
22{-# LANGUAGE CPP #-}
33{-# LANGUAGE FlexibleInstances #-}
44{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
56{-# LANGUAGE UndecidableInstances #-}
67#ifdef USE_REFLEX_OPTIMIZER
78{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
src/Reflex/FastWeak.hs+5−69
@@ -5,19 +5,6 @@
55{-# LANGUAGE ForeignFunctionInterface #-}
66{-# LANGUAGE JavaScriptFFI #-}
77#endif
8−
9−-- |
10−-- Module:
11−-- Reflex.FastWeak
12−-- Description:
13−-- 'FastWeak' is a weak pointer to some value, and 'FastWeakTicket' ensures the value
14−-- referred to by a 'FastWeak' stays live while the ticket is held (live).
15−--
16−-- On GHC or GHCJS when not built with the @fast-weak@ cabal flag, 'FastWeak' is a wrapper
17−-- around the simple version of 'System.Mem.Weak.Weak' where the key and value are the same.
18−--
19−-- On GHCJS when built with the @fast-weak@ cabal flag, 'FastWeak' is implemented directly
20−-- in JS using @h$FastWeak@ and @h$FastWeakTicket@ which are a nonstandard part of the GHCJS RTS.
218module Reflex.FastWeak
229 ( FastWeakTicket
2310 , FastWeak
@@ -48,57 +35,29 @@ import System.Mem.Weak
4835
4936
5037#ifdef GHCJS_FAST_WEAK
51−-- | A 'FastWeak' which has been promoted to a strong reference. 'getFastWeakTicketValue'
52−-- can be used to get the referred to value without fear of @Nothing,
53−-- and 'getFastWeakTicketWeak' can be used to get the weak version.
54−--
55−-- Implemented by way of special support in the GHCJS RTS, @h$FastWeakTicket@.
5638newtype FastWeakTicket a = FastWeakTicket JSVal
5739
58−-- | A reference to some value which can be garbage collected if there are only
59−-- weak references to the value left.
60−--
61−-- 'getFastWeakValue' can be used to try and obtain a strong reference to the value.
62−--
63−-- The value in a @FastWeak@ can also be kept alive by obtaining a 'FastWeakTicket' using
64−-- 'getFastWeakTicket' if the value hasn't been collected yet.
65−--
66−-- Implemented by way of special support in the GHCJS RTS, @h$FastWeak@.
6740newtype FastWeak a = FastWeak JSVal
6841
6942-- Just designed to mirror JSVal, so that we can unsafeCoerce between the two
7043data Val a = Val { unVal :: a }
7144
72−-- | Coerce a JSVal that represents the heap object of a value of type @a@ into a value of type @a@
45+-- | Coerce a JSVal that represents the heap object of a value of type 'a' into a value of type 'a'
7346unsafeFromRawJSVal :: JSVal -> a
7447unsafeFromRawJSVal v = unVal (unsafeCoerce v)
7548
76−-- | Coerce a heap object of type @a@ into a 'JSVal' which represents that object.
7749unsafeToRawJSVal :: a -> JSVal
7850unsafeToRawJSVal v = unsafeCoerce (Val v)
7951#else
80−-- | A 'FastWeak' which has been promoted to a strong reference. 'getFastWeakTicketValue'
81−-- can be used to get the referred to value without fear of @Nothing@,
82−-- and 'getFastWeakTicketWeak' can be used to get the weak version.
8352data FastWeakTicket a = FastWeakTicket
8453 { _fastWeakTicket_val :: !a
8554 , _fastWeakTicket_weak :: {-# UNPACK #-} !(Weak a)
8655 }
8756
88−-- | A reference to some value which can be garbage collected if there are only weak references to the value left.
89−--
90−-- 'getFastWeakValue' can be used to try and obtain a strong reference to the value.
91−--
92−-- The value in a @FastWeak@ can also be kept alive by obtaining a 'FastWeakTicket' using 'getFastWeakTicket'
93−-- if the value hasn't been collected yet.
94−--
95−-- Synonymous with 'Weak'.
9657type FastWeak a = Weak a
9758#endif
9859
99−-- | Return the @a@ kept alive by the given 'FastWeakTicket'.
100−--
101−-- This needs to be in IO so we know that we've relinquished the ticket.
60+-- This needs to be in IO so we know that we've relinquished the ticket
10261getFastWeakTicketValue :: FastWeakTicket a -> IO a
10362#ifdef GHCJS_FAST_WEAK
10463getFastWeakTicketValue t = do
@@ -110,8 +69,6 @@ foreign import javascript unsafe "$r = $1.val;" js_ticketVal :: FastWeakTicket a
11069getFastWeakTicketValue = return . _fastWeakTicket_val
11170#endif
11271
113−-- | Get the value referred to by a 'FastWeak' if it hasn't yet been collected,
114−-- or @Nothing@ if it has been collected.
11572getFastWeakValue :: FastWeak a -> IO (Maybe a)
11673#ifdef GHCJS_FAST_WEAK
11774getFastWeakValue w = do
@@ -127,9 +84,6 @@ foreign import javascript unsafe "$r = ($1.ticket === null) ? null : $1.ticket.v
12784getFastWeakValue = deRefWeak
12885#endif
12986
130−-- | Try to create a 'FastWeakTicket' for the given 'FastWeak' which will ensure the value referred
131−-- remains alive. Returns @Just@ if the value hasn't been collected
132−-- and a ticket can therefore be obtained, @Nothing@ if it's been collected.
13387getFastWeakTicket :: forall a. FastWeak a -> IO (Maybe (FastWeakTicket a))
13488#ifdef GHCJS_FAST_WEAK
13589getFastWeakTicket w = do
@@ -149,21 +103,8 @@ getFastWeakTicket w = do
149103 }
150104#endif
151105
152−-- | Create a 'FastWeakTicket' directly from a value, creating a 'FastWeak' in the process
153−-- which can be obtained with 'getFastWeakTicketValue'.
154−--
155−-- This function is marked NOINLINE so it is opaque to GHC.
156−-- If we do not do this, then GHC will sometimes fuse the constructor away
157−-- so any weak references that are attached to the ticket will have their
158−-- finalizer run. Using the opaque constructor, GHC does not see the
159−-- constructor application, so it behaves like an IORef and cannot be fused away.
160−--
161−-- The result is also evaluated to WHNF, since forcing a thunk invalidates
162−-- the weak pointer to it in some cases.
163−{-# NOINLINE mkFastWeakTicket #-}
106+-- I think it's fine if this is lazy - it'll retain the 'a', but so would the output; we just need to make sure it's forced before we start relying on the associated FastWeak to actually be weak
164107mkFastWeakTicket :: a -> IO (FastWeakTicket a)
165−-- I think it's fine if this is lazy - it'll retain the 'a', but so would the output; we just need to make sure it's forced before we start relying on the
166−-- associated FastWeak to actually be weak
167108#ifdef GHCJS_FAST_WEAK
168109mkFastWeakTicket v = js_fastWeakTicket (unsafeToRawJSVal v)
169110
@@ -178,16 +119,11 @@ mkFastWeakTicket v = do
178119 }
179120#endif
180121
181−-- | Demote a 'FastWeakTicket'; which ensures the value is alive, to a 'FastWeak' which doesn't.
182−-- Note that unless the ticket for the same 'FastWeak' is held in some other way
183−-- the value might be collected immediately.
184−getFastWeakTicketWeak :: FastWeakTicket a -> IO (FastWeak a)
185122-- Needs IO so that it can force the value - otherwise, could end up with a reference to the Ticket, which would retain the value
186123#ifdef GHCJS_FAST_WEAK
187−foreign import javascript unsafe "$r = $1.weak;" getFastWeakTicketWeak' :: FastWeakTicket a -> IO (FastWeak a)
188−{-# INLINE getFastWeakTicketWeak #-}
189−getFastWeakTicketWeak = getFastWeakTicketWeak'
124+foreign import javascript unsafe "$r = $1.weak;" getFastWeakTicketWeak :: FastWeakTicket a -> IO (FastWeak a)
190125#else
126+getFastWeakTicketWeak :: FastWeakTicket a -> IO (FastWeak a)
191127getFastWeakTicketWeak = return . _fastWeakTicket_weak
192128#endif
193129
src/Reflex/FunctorMaybe.hs+18−32
@@ -1,47 +1,33 @@
1−{-# LANGUAGE CPP #-}
2−#if MIN_VERSION_base(4,9,0)
3−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4−{-# LANGUAGE StandaloneDeriving #-}
5−#endif
6−
7−-- |
8−-- Module:
9−-- Reflex.FunctorMaybe
10−-- Description:
11−-- This module defines the FunctorMaybe class, which extends Functors with the
12−-- ability to delete values.
1+-- | This module defines the FunctorMaybe class, which extends Functors with the
2+-- ability to delete values.
133module Reflex.FunctorMaybe
144 ( FunctorMaybe (..)
155 ) where
166
17−import Data.IntMap (IntMap)
18−import Data.Map (Map)
19−#if MIN_VERSION_base(4,9,0)
20−import Data.Semigroup (Option(..))
21−#endif
22−import Data.Witherable
7+import Data.Maybe
238
249--TODO: See if there's a better class in the standard libraries already
2510
2611-- | A class for values that combines filtering and mapping using 'Maybe'.
27−-- Morally, @'FunctorMaybe' ~ KleisliFunctor 'Maybe'@.
28−{-# DEPRECATED FunctorMaybe "Use 'Filterable' from Data.Witherable instead" #-}
12+-- Morally, @'FunctorMaybe' ~ KleisliFunctor 'Maybe'@. Also similar is the
13+-- @Witherable@ typeclass, but it requires @Foldable f@ and @Traverable f@,
14+-- and e.g. 'Event' is instance of neither.
15+--
16+-- A definition of 'fmapMaybe' must satisfy the following laws:
17+--
18+-- [/identity/]
19+-- @'fmapMaybe' 'Just' ≡ 'id'@
20+--
21+-- [/composition/]
22+-- @'fmapMaybe' (f <=< g) ≡ 'fmapMaybe' f . 'fmapMaybe' g@
2923class FunctorMaybe f where
3024 -- | Combined mapping and filtering function.
3125 fmapMaybe :: (a -> Maybe b) -> f a -> f b
3226
27+-- | @fmapMaybe = (=<<)
3328instance FunctorMaybe Maybe where
34− fmapMaybe = mapMaybe
35−
36−#if MIN_VERSION_base(4,9,0)
37−deriving instance FunctorMaybe Option
38−#endif
29+ fmapMaybe = (=<<)
3930
31+-- | @fmapMaybe f = catMaybes . fmap f@
4032instance FunctorMaybe [] where
41− fmapMaybe = mapMaybe
42−
43−instance FunctorMaybe (Map k) where
44− fmapMaybe = mapMaybe
45−
46−instance FunctorMaybe IntMap where
47− fmapMaybe = mapMaybe
33+ fmapMaybe f = catMaybes . fmap f
src/Reflex/Host/Class.hs+1
@@ -4,6 +4,7 @@
44{-# LANGUAGE FlexibleInstances #-}
55{-# LANGUAGE FunctionalDependencies #-}
66{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
78{-# LANGUAGE RankNTypes #-}
89{-# LANGUAGE RoleAnnotations #-}
910{-# LANGUAGE ScopedTypeVariables #-}
src/Reflex/Host/Headless.hsdeleted−128
@@ -1,128 +0,0 @@
1−{-# LANGUAGE LambdaCase #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE RankNTypes #-}
4−{-# LANGUAGE TypeFamilies #-}
5−{-# LANGUAGE ConstraintKinds #-}
6−
7−module Reflex.Host.Headless where
8−
9−import Control.Concurrent.Chan (newChan, readChan)
10−import Control.Monad (unless)
11−import Control.Monad.Fix (MonadFix, fix)
12−import Control.Monad.IO.Class (MonadIO, liftIO)
13−import Control.Monad.Primitive (PrimMonad)
14−import Control.Monad.Ref (MonadRef, Ref, readRef)
15−import Data.Dependent.Sum (DSum (..), (==>))
16−import Data.Foldable (for_)
17−import Data.Functor.Identity (Identity(..))
18−import Data.IORef (IORef, readIORef)
19−import Data.Maybe (catMaybes, fromMaybe)
20−import Data.Traversable (for)
21−
22−import Reflex
23−import Reflex.Host.Class
24−
25−type MonadHeadlessApp t m =
26− ( Adjustable t m
27− , MonadFix m
28− , MonadHold t m
29− , MonadIO (HostFrame t)
30− , MonadIO (Performable m)
31− , MonadIO m
32− , MonadRef (HostFrame t)
33− , NotReady t m
34− , PerformEvent t m
35− , PostBuild t m
36− , PrimMonad (HostFrame t)
37− , Ref (HostFrame t) ~ IORef
38− , Ref m ~ IORef
39− , Reflex t
40− , ReflexHost t
41− , TriggerEvent t m
42− )
43−
44−-- | Run a headless FRP network. Inside the action, you will most probably use
45−-- the capabilities provided by the 'TriggerEvent' and 'PerformEvent' type
46−-- classes to interface the FRP network with the outside world. Useful for
47−-- testing. Each headless network runs on its own spider timeline.
48−runHeadlessApp
49− :: (forall t m. MonadHeadlessApp t m => m (Event t ()))
50− -- ^ The action to be run in the headless FRP network. The FRP network is
51− -- closed at the first occurrence of the resulting 'Event'.
52− -> IO ()
53−runHeadlessApp guest =
54− -- We are using the 'Spider' implementation of reflex. Running the host
55− -- allows us to take actions on the FRP timeline.
56− withSpiderTimeline $ runSpiderHostForTimeline $ do
57− -- Create the "post-build" event and associated trigger. This event fires
58− -- once, when the application starts.
59− (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
60− -- Create a queue to which we will write 'Event's that need to be
61− -- processed.
62− events <- liftIO newChan
63− -- Run the "guest" application, providing the appropriate context. We'll
64− -- pure the result of the action, and a 'FireCommand' that will be used to
65− -- trigger events.
66− (result, fc@(FireCommand fire)) <- do
67− hostPerformEventT $ -- Allows the guest app to run
68− -- 'performEvent', so that actions
69− -- (e.g., IO actions) can be run when
70− -- 'Event's fire.
71−
72− flip runPostBuildT postBuild $ -- Allows the guest app to access to
73− -- a "post-build" 'Event'
74−
75− flip runTriggerEventT events $ -- Allows the guest app to create new
76− -- events and triggers and write
77− -- those triggers to a channel from
78− -- which they will be read and
79− -- processed.
80− guest
81−
82− -- Read the trigger reference for the post-build event. This will be
83− -- 'Nothing' if the guest application hasn't subscribed to this event.
84− mPostBuildTrigger <- readRef postBuildTriggerRef
85−
86− -- Subscribe to an 'Event' of that the guest application can use to
87− -- request application shutdown. We'll check whether this 'Event' is firing
88− -- to determine whether to terminate.
89− shutdown <- subscribeEvent result
90−
91− -- When there is a subscriber to the post-build event, fire the event.
92− soa <- for mPostBuildTrigger $ \postBuildTrigger ->
93− fire [postBuildTrigger :=> Identity ()] $ isFiring shutdown
94−
95− -- The main application loop. We wait for new events and fire those that
96− -- have subscribers. If we detect a shutdown request, the application
97− -- terminates.
98− unless (or (fromMaybe [] soa)) $ fix $ \loop -> do
99− -- Read the next event (blocking).
100− ers <- liftIO $ readChan events
101− stop <- do
102− -- Fire events that have subscribers.
103− fireEventTriggerRefs fc ers $
104− -- Check if the shutdown 'Event' is firing.
105− isFiring shutdown
106− if or stop
107− then pure ()
108− else loop
109− where
110− isFiring ev = readEvent ev >>= \case
111− Nothing -> pure False
112− Just _ -> pure True
113− -- Use the given 'FireCommand' to fire events that have subscribers
114− -- and call the callback for the 'TriggerInvocation' of each.
115− fireEventTriggerRefs
116− :: MonadIO m
117− => FireCommand t m
118− -> [DSum (EventTriggerRef t) TriggerInvocation]
119− -> ReadPhase m a
120− -> m [a]
121− fireEventTriggerRefs (FireCommand fire) ers rcb = do
122− mes <- liftIO $
123− for ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do
124− me <- readIORef er
125− pure $ fmap (==> a) me
126− a <- fire (catMaybes mes) rcb
127− liftIO $ for_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb
128− pure a
src/Reflex/Network.hs+7−14
@@ -3,11 +3,6 @@
33#ifdef USE_REFLEX_OPTIMIZER
44{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
55#endif
6−-- |
7−-- Module:
8−-- Reflex.Network
9−-- Description:
10−-- This module provides combinators for building FRP graphs/networks and modifying them dynamically.
116module Reflex.Network
127 ( networkView
138 , networkHold
@@ -15,31 +10,29 @@ module Reflex.Network
1510 ) where
1611
1712import Reflex.Class
18−import Reflex.Adjustable.Class
1913import Reflex.NotReady.Class
2014import Reflex.PostBuild.Class
2115
22−-- | A 'Dynamic' "network": Takes a 'Dynamic' of network-creating actions and replaces the network whenever the 'Dynamic' updates.
23−-- The returned Event of network results fires at post-build time and when the 'Dynamic' updates.
24−-- Note: Often, the type 'a' is an Event, in which case the return value is an Event-of-Events, where the outer 'Event' fires
25−-- when switching networks. Such an 'Event' would typically be flattened (via 'switchPromptly').
26−networkView :: (NotReady t m, Adjustable t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)
16+-- | Given a Dynamic of network-creating actions, create a network that is recreated whenever the Dynamic updates.
17+-- The returned Event of network results occurs when the Dynamic does.
18+-- Note: Often, the type 'a' is an Event, in which case the return value is an Event-of-Events that would typically be flattened (via 'switchPromptly').
19+networkView :: (Reflex t, NotReady t m, Adjustable t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)
2720networkView child = do
2821 postBuild <- getPostBuild
2922 let newChild = leftmost [updated child, tagCheap (current child) postBuild]
3023 snd <$> runWithReplace notReady newChild
3124
32−-- | Given an initial "network" and an 'Event' of network-creating actions, create a network that is recreated whenever the Event fires.
25+-- | Given an initial network and an Event of network-creating actions, create a network that is recreated whenever the Event fires.
3326-- The returned Dynamic of network results occurs when the Event does.
3427-- Note: Often, the type 'a' is an Event, in which case the return value is a Dynamic-of-Events that would typically be flattened.
35−networkHold :: (Adjustable t m, MonadHold t m) => m a -> Event t (m a) -> m (Dynamic t a)
28+networkHold :: (Reflex t, Adjustable t m, MonadHold t m) => m a -> Event t (m a) -> m (Dynamic t a)
3629networkHold child0 newChild = do
3730 (result0, newResult) <- runWithReplace child0 newChild
3831 holdDyn result0 newResult
3932
4033-- | Render a placeholder network to be shown while another network is not yet
4134-- done building
42−untilReady :: (Adjustable t m, PostBuild t m) => m a -> m b -> m (a, Event t b)
35+untilReady :: (Reflex t, Adjustable t m, PostBuild t m) => m a -> m b -> m (a, Event t b)
4336untilReady a b = do
4437 postBuild <- getPostBuild
4538 runWithReplace a $ b <$ postBuild
src/Reflex/NotReady/Class.hs+1−10
@@ -3,6 +3,7 @@
33{-# LANGUAGE FlexibleContexts #-}
44{-# LANGUAGE FlexibleInstances #-}
55{-# LANGUAGE FunctionalDependencies #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
67{-# LANGUAGE TypeFamilies #-}
78{-# LANGUAGE UndecidableInstances #-}
89#ifdef USE_REFLEX_OPTIMIZER
@@ -14,9 +15,7 @@ module Reflex.NotReady.Class
1415
1516import Control.Monad.Reader (ReaderT)
1617import Control.Monad.Trans
17−import Control.Monad.Trans.Writer (WriterT)
1818
19−import Reflex.BehaviorWriter.Base (BehaviorWriterT)
2019import Reflex.Class
2120import Reflex.DynamicWriter.Base (DynamicWriterT)
2221import Reflex.EventWriter.Base (EventWriterT)
@@ -40,10 +39,6 @@ instance NotReady t m => NotReady t (ReaderT r m) where
4039 notReadyUntil = lift . notReadyUntil
4140 notReady = lift notReady
4241
43−instance (NotReady t m, Monoid w) => NotReady t (WriterT w m) where
44− notReadyUntil = lift . notReadyUntil
45− notReady = lift notReady
46−
4742instance NotReady t m => NotReady t (PostBuildT t m) where
4843 notReadyUntil = lift . notReadyUntil
4944 notReady = lift notReady
@@ -56,10 +51,6 @@ instance NotReady t m => NotReady t (DynamicWriterT t w m) where
5651 notReadyUntil = lift . notReadyUntil
5752 notReady = lift notReady
5853
59−instance NotReady t m => NotReady t (BehaviorWriterT t w m) where
60− notReadyUntil = lift . notReadyUntil
61− notReady = lift notReady
62−
6354instance NotReady t m => NotReady t (QueryT t q m) where
6455 notReadyUntil = lift . notReadyUntil
6556 notReady = lift notReady
src/Reflex/Optimizer.hs+4−13
@@ -1,14 +1,10 @@
1+-- | This module provides a GHC plugin designed to improve code that uses
2+-- Reflex. Currently, it just adds an INLINABLE pragma to any top-level
3+-- definition that doesn't have an explicit inlining pragma. In the future,
4+-- additional optimizations are likely to be added.
15{-# LANGUAGE CPP #-}
26{-# LANGUAGE LambdaCase #-}
37{-# LANGUAGE OverloadedStrings #-}
4−-- |
5−-- Module:
6−-- Reflex.Optimizer
7−-- Description:
8−-- This module provides a GHC plugin designed to improve code that uses
9−-- Reflex. Currently, it just adds an INLINABLE pragma to any top-level
10−-- definition that doesn't have an explicit inlining pragma. In the future,
11−-- additional optimizations are likely to be added.
128module Reflex.Optimizer
139 ( plugin
1410 ) where
@@ -20,11 +16,6 @@ import Control.Arrow
2016import CoreMonad
2117import Data.String
2218import GhcPlugins
23−
24−#if MIN_VERSION_base(4,9,0)
25−import Prelude hiding ((<>))
26−#endif
27−
2819#endif
2920
3021#ifdef ghcjs_HOST_OS
src/Reflex/Patch.hsnew file+39
@@ -0,0 +1,39 @@
1+-- | This module defines the 'Patch' class, which is used by Reflex to manage
2+-- changes to 'Reflex.Class.Incremental' values.
3+{-# LANGUAGE TypeFamilies #-}
4+module Reflex.Patch
5+ ( module Reflex.Patch
6+ , module X
7+ ) where
8+
9+import Reflex.Patch.Class as X
10+import Reflex.Patch.DMap as X hiding (getDeletions)
11+import Reflex.Patch.DMapWithMove as X (PatchDMapWithMove, const2PatchDMapWithMoveWith, mapPatchDMapWithMove,
12+ patchDMapWithMoveToPatchMapWithMoveWith,
13+ traversePatchDMapWithMoveWithKey, unPatchDMapWithMove,
14+ unsafePatchDMapWithMove, weakenPatchDMapWithMoveWith)
15+import Reflex.Patch.IntMap as X hiding (getDeletions)
16+import Reflex.Patch.Map as X
17+import Reflex.Patch.MapWithMove as X (PatchMapWithMove, patchMapWithMoveNewElements,
18+ patchMapWithMoveNewElementsMap, unPatchMapWithMove,
19+ unsafePatchMapWithMove)
20+
21+import Data.Semigroup (Semigroup (..), (<>))
22+
23+---- Patches based on commutative groups
24+
25+-- | A 'Group' is a 'Monoid' where every element has an inverse.
26+class (Semigroup q, Monoid q) => Group q where
27+ negateG :: q -> q
28+ (~~) :: q -> q -> q
29+ r ~~ s = r <> negateG s
30+
31+-- | An 'Additive' 'Semigroup' is one where (<>) is commutative
32+class Semigroup q => Additive q where
33+
34+-- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type.
35+newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }
36+
37+instance Additive p => Patch (AdditivePatch p) where
38+ type PatchTarget (AdditivePatch p) = p
39+ apply (AdditivePatch p) q = Just $ p <> q
src/Reflex/Patch/Class.hsnew file+22
@@ -0,0 +1,22 @@
1+{-# LANGUAGE TypeFamilies #-}
2+-- | The interface for types which represent changes made to other types
3+module Reflex.Patch.Class where
4+
5+import Control.Monad.Identity
6+import Data.Maybe
7+
8+-- | A 'Patch' type represents a kind of change made to a datastructure.
9+class Patch p where
10+ type PatchTarget p :: *
11+ -- | Apply the patch @p a@ to the value @a@. If no change is needed, return
12+ -- 'Nothing'.
13+ apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
14+
15+-- | Apply a 'Patch'; if it does nothing, return the original value
16+applyAlways :: Patch p => p -> PatchTarget p -> PatchTarget p
17+applyAlways p t = fromMaybe t $ apply p t
18+
19+-- | 'Identity' can be used as a 'Patch' that always fully replaces the value
20+instance Patch (Identity a) where
21+ type PatchTarget (Identity a) = a
22+ apply (Identity a) _ = Just a
src/Reflex/Patch/DMap.hsnew file+68
@@ -0,0 +1,68 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE LambdaCase #-}
3+{-# LANGUAGE PolyKinds #-}
4+{-# LANGUAGE Rank2Types #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE StandaloneDeriving #-}
7+{-# LANGUAGE TypeFamilies #-}
8+module Reflex.Patch.DMap where
9+
10+import Reflex.Patch.Class
11+import Reflex.Patch.IntMap
12+import Reflex.Patch.Map
13+
14+import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
15+import qualified Data.Dependent.Map as DMap
16+import Data.Functor.Constant
17+import Data.Functor.Misc
18+import qualified Data.IntMap as IntMap
19+import qualified Data.Map as Map
20+import Data.Semigroup (Semigroup (..))
21+import Data.Some (Some)
22+
23+-- | A set of changes to a 'DMap'. Any element may be inserted/updated or
24+-- deleted.
25+newtype PatchDMap k v = PatchDMap { unPatchDMap :: DMap k (ComposeMaybe v) }
26+
27+deriving instance GCompare k => Semigroup (PatchDMap k v)
28+
29+deriving instance GCompare k => Monoid (PatchDMap k v)
30+
31+instance GCompare k => Patch (PatchDMap k v) where
32+ type PatchTarget (PatchDMap k v) = DMap k v
33+ apply (PatchDMap diff) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
34+ where insertions = DMap.mapMaybeWithKey (const $ getComposeMaybe) diff
35+ deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getComposeMaybe) diff
36+ nothingToJust = \case
37+ Nothing -> Just $ Constant ()
38+ Just _ -> Nothing
39+
40+mapPatchDMap :: (forall a. v a -> v' a) -> PatchDMap k v -> PatchDMap k v'
41+mapPatchDMap f (PatchDMap p) = PatchDMap $ DMap.map (ComposeMaybe . fmap f . getComposeMaybe) p
42+
43+traversePatchDMap :: Applicative m => (forall a. v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v')
44+traversePatchDMap f = traversePatchDMapWithKey $ const f
45+
46+traversePatchDMapWithKey :: Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v')
47+traversePatchDMapWithKey f (PatchDMap p) = PatchDMap <$> DMap.traverseWithKey (\k (ComposeMaybe v) -> ComposeMaybe <$> traverse (f k) v) p
48+
49+weakenPatchDMapWith :: (forall a. v a -> v') -> PatchDMap k v -> PatchMap (Some k) v'
50+weakenPatchDMapWith f (PatchDMap p) = PatchMap $ weakenDMapWith (fmap f . getComposeMaybe) p
51+
52+patchDMapToPatchMapWith :: (f v -> v') -> PatchDMap (Const2 k v) f -> PatchMap k v'
53+patchDMapToPatchMapWith f (PatchDMap p) = PatchMap $ dmapToMapWith (fmap f . getComposeMaybe) p
54+
55+const2PatchDMapWith :: forall k v f a. (v -> f a) -> PatchMap k v -> PatchDMap (Const2 k a) f
56+const2PatchDMapWith f (PatchMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
57+ where g :: (k, Maybe v) -> DSum (Const2 k a) (ComposeMaybe f)
58+ g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)
59+
60+const2IntPatchDMapWith :: forall v f a. (v -> f a) -> PatchIntMap v -> PatchDMap (Const2 IntMap.Key a) f
61+const2IntPatchDMapWith f (PatchIntMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> IntMap.toAscList p
62+ where g :: (IntMap.Key, Maybe v) -> DSum (Const2 IntMap.Key a) (ComposeMaybe f)
63+ g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)
64+
65+-- | Get the values that will be deleted if the given patch is applied to the
66+-- given 'DMap'. Includes values that will be replaced.
67+getDeletions :: GCompare k => PatchDMap k v -> DMap k v' -> DMap k v'
68+getDeletions (PatchDMap p) m = DMap.intersectionWithKey (\_ v _ -> v) m p
src/Reflex/Patch/DMapWithMove.hsnew file+367
@@ -0,0 +1,367 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE LambdaCase #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE PatternGuards #-}
8+{-# LANGUAGE PolyKinds #-}
9+{-# LANGUAGE Rank2Types #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE UndecidableInstances #-}
13+
14+-- |Module containing @'PatchDMapWithMove' k v@ and associated functions, which represents a 'Patch' to a @'DMap' k v@ which can insert, update, delete, and
15+-- move values between keys.
16+module Reflex.Patch.DMapWithMove where
17+
18+import Reflex.Patch.Class
19+import Reflex.Patch.MapWithMove (PatchMapWithMove (..))
20+import qualified Reflex.Patch.MapWithMove as MapWithMove
21+
22+import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
23+import qualified Data.Dependent.Map as DMap
24+import Data.Dependent.Sum (EqTag (..))
25+import Data.Functor.Constant
26+import Data.Functor.Misc
27+import Data.Functor.Product
28+import Data.GADT.Compare (GEq (..))
29+import Data.GADT.Show (GShow, gshow)
30+import qualified Data.Map as Map
31+import Data.Maybe
32+import Data.Semigroup (Semigroup (..), (<>))
33+import Data.Some (Some)
34+import qualified Data.Some as Some
35+import Data.These
36+
37+-- | Like 'PatchMapWithMove', but for 'DMap'. Each key carries a 'NodeInfo' which describes how it will be changed by the patch and connects move sources and
38+-- destinations.
39+--
40+-- Invariants:
41+--
42+-- * A key should not move to itself.
43+-- * A move should always be represented with both the destination key (as a 'From_Move') and the source key (as a @'ComposeMaybe' ('Just' destination)@)
44+newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
45+
46+-- |Structure which represents what changes apply to a particular key. @_nodeInfo_from@ specifies what happens to this key, and in particular what other key
47+-- the current key is moving from, while @_nodeInfo_to@ specifies what key the current key is moving to if involved in a move.
48+data NodeInfo k v a = NodeInfo
49+ { _nodeInfo_from :: !(From k v a)
50+ -- ^Change applying to the current key, be it an insert, move, or delete.
51+ , _nodeInfo_to :: !(To k a)
52+ -- ^Where this key is moving to, if involved in a move. Should only be @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.
53+ }
54+ deriving (Show)
55+
56+-- |Structure describing a particular change to a key, be it inserting a new key (@From_Insert@), updating an existing key (@From_Insert@ again), deleting a
57+-- key (@From_Delete@), or moving a key (@From_Move@).
58+data From (k :: a -> *) (v :: a -> *) :: a -> * where
59+ -- |Insert a new or update an existing key with the given value @v a@
60+ From_Insert :: v a -> From k v a
61+ -- |Delete the existing key
62+ From_Delete :: From k v a
63+ -- |Move the value from the given key @k a@ to this key. The source key should also have an entry in the patch giving the current key as @_nodeInfo_to@,
64+ -- usually but not necessarily with @From_Delete@.
65+ From_Move :: !(k a) -> From k v a
66+ deriving (Show, Read, Eq, Ord)
67+
68+-- |Type alias for the "to" part of a 'NodeInfo'. @'ComposeMaybe' ('Just' k)@ means the key is moving to another key, @ComposeMaybe Nothing@ for any other
69+-- operation.
70+type To = ComposeMaybe
71+
72+-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
73+validPatchDMapWithMove :: forall k v. (GCompare k, GEq k, GShow k) => DMap k (NodeInfo k v) -> Bool
74+validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove
75+
76+-- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid.
77+validationErrorsForPatchDMapWithMove :: forall k v. (GCompare k, GEq k, GShow k) => DMap k (NodeInfo k v) -> [String]
78+validationErrorsForPatchDMapWithMove m =
79+ noSelfMoves <> movesBalanced
80+ where
81+ noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m
82+ selfMove (dst :=> NodeInfo (From_Move src) _) | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"
83+ selfMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
84+ selfMove _ = Nothing
85+ movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m
86+ unbalancedMove (dst :=> NodeInfo (From_Move src) _) =
87+ case DMap.lookup src m of
88+ Nothing -> Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key is not in the patch"
89+ Just (NodeInfo _ (ComposeMaybe (Just dst'))) ->
90+ if isNothing (dst' `geq` dst)
91+ then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead"
92+ else Nothing
93+ _ ->
94+ Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key has no move to key"
95+ unbalancedMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) =
96+ case DMap.lookup dst m of
97+ Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch"
98+ Just (NodeInfo (From_Move src') _) ->
99+ if isNothing (src' `geq` src)
100+ then Just $ "unbalanced move at source key " <> gshow src <> " to " <> gshow dst <> " is coming from " <> gshow src' <> " instead"
101+ else Nothing
102+
103+ _ ->
104+ Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
105+ unbalancedMove _ = Nothing
106+
107+instance EqTag k (NodeInfo k v) => Eq (PatchDMapWithMove k v) where
108+ PatchDMapWithMove a == PatchDMapWithMove b = a == b
109+
110+-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
111+data Pair1 f g a = Pair1 (f a) (g a)
112+
113+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
114+instance GCompare k => Semigroup (PatchDMapWithMove k v) where
115+ (<>) = mappend
116+
117+-- |Helper data structure used for composing patches using the monoid instance.
118+data Fixup k v a
119+ = Fixup_Delete
120+ | Fixup_Update (These (From k v a) (To k a))
121+
122+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
123+instance GCompare k => Monoid (PatchDMapWithMove k v) where
124+ mempty = PatchDMapWithMove mempty
125+ PatchDMapWithMove ma `mappend` PatchDMapWithMove mb = PatchDMapWithMove m
126+ where
127+ connections = DMap.toList $ DMap.intersectionWithKey (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b)) ma mb
128+ h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)]
129+ h (_ :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case (mToAfter, editBefore) of
130+ (Just toAfter, From_Move fromBefore)
131+ | isJust $ fromBefore `geq` toAfter
132+ -> [toAfter :=> Fixup_Delete]
133+ | otherwise
134+ -> [ toAfter :=> Fixup_Update (This editBefore)
135+ , fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))
136+ ]
137+ (Nothing, From_Move fromBefore) -> [fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map
138+ (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)]
139+ (Nothing, _) -> []
140+ mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
141+ mergeFixups _ (Fixup_Update a) (Fixup_Update b)
142+ | This x <- a, That y <- b
143+ = Fixup_Update $ These x y
144+ | That y <- a, This x <- b
145+ = Fixup_Update $ These x y
146+ mergeFixups _ _ _ = error "PatchDMapWithMove: incompatible fixups"
147+ fixups = DMap.fromListWithKey mergeFixups $ concatMap h connections
148+ combineNodeInfos _ nia nib = NodeInfo
149+ { _nodeInfo_from = _nodeInfo_from nia
150+ , _nodeInfo_to = _nodeInfo_to nib
151+ }
152+ applyFixup _ ni = \case
153+ Fixup_Delete -> Nothing
154+ Fixup_Update u -> Just $ NodeInfo
155+ { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u
156+ , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
157+ }
158+ m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups
159+
160+-- |Project the @a@ from a @'These' a b@, identical to @preview '_Here'@ but without using preview
161+getHere :: These a b -> Maybe a
162+getHere = \case
163+ This a -> Just a
164+ These a _ -> Just a
165+ That _ -> Nothing
166+
167+-- |Project the @b@ from a @'These' a b@, identical to @preview '_There'@ but without using preview
168+getThere :: These a b -> Maybe b
169+getThere = \case
170+ This _ -> Nothing
171+ These _ b -> Just b
172+ That b -> Just b
173+
174+{-
175+mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
176+PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
177+ where
178+ getDstAction k m = fromMaybe (From_Move k) $ DMap.lookup k m -- Any key that isn't present is treated as that key moving to itself
179+ removeRedundantDst toKey (From_Move fromKey) | isJust (toKey `geq` fromKey) = Nothing
180+ removeRedundantDst _ a = Just a
181+ f :: forall a. k a -> From k v a -> Maybe (From k v a)
182+ f toKey _ = removeRedundantDst toKey $ case getDstAction toKey dstAfter of
183+ From_Move fromKey -> getDstAction fromKey dstBefore
184+ nonMove -> nonMove
185+ dst = DMap.mapMaybeWithKey f $ DMap.union dstAfter dstBefore
186+ getSrcAction k m = fromMaybe (ComposeMaybe $ Just k) $ DMap.lookup k m
187+ removeRedundantSrc fromKey (ComposeMaybe (Just toKey)) | isJust (fromKey `geq` toKey) = Nothing
188+ removeRedundantSrc _ a = Just a
189+ g :: forall a. k a -> ComposeMaybe k a -> Maybe (ComposeMaybe k a)
190+ g fromKey _ = removeRedundantSrc fromKey $ case getSrcAction fromKey srcBefore of
191+ ComposeMaybe Nothing -> ComposeMaybe Nothing
192+ ComposeMaybe (Just toKeyBefore) -> getSrcAction toKeyBefore srcAfter
193+ src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
194+-}
195+
196+-- |Make a @'PatchDMapWithMove' k v@ which has the effect of inserting or updating a value @v a@ to the given key @k a@, like 'DMap.insert'.
197+insertDMapKey :: k a -> v a -> PatchDMapWithMove k v
198+insertDMapKey k v =
199+ PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing)
200+
201+-- |Make a @'PatchDMapWithMove' k v@ which has the effect of moving the value from the first key @k a@ to the second key @k a@, equivalent to:
202+--
203+-- @
204+-- 'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap))
205+-- @
206+moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
207+moveDMapKey src dst = case src `geq` dst of
208+ Nothing -> PatchDMapWithMove $ DMap.fromList
209+ [ dst :=> NodeInfo (From_Move src) (ComposeMaybe Nothing)
210+ , src :=> NodeInfo From_Delete (ComposeMaybe $ Just dst)
211+ ]
212+ Just _ -> mempty
213+
214+-- |Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
215+--
216+-- @
217+-- let aMay = DMap.lookup a dmap
218+-- bMay = DMap.lookup b dmap
219+-- in maybe id (DMap.insert a) (bMay `mplus` aMay)
220+-- . maybe id (DMap.insert b) (aMay `mplus` bMay)
221+-- . DMap.delete a . DMap.delete b $ dmap
222+-- @
223+swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
224+swapDMapKey src dst = case src `geq` dst of
225+ Nothing -> PatchDMapWithMove $ DMap.fromList
226+ [ dst :=> NodeInfo (From_Move src) (ComposeMaybe $ Just src)
227+ , src :=> NodeInfo (From_Move dst) (ComposeMaybe $ Just dst)
228+ ]
229+ Just _ -> mempty
230+
231+-- |Make a @'PatchDMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'DMap.delete'.
232+deleteDMapKey :: k a -> PatchDMapWithMove k v
233+deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete $ ComposeMaybe Nothing
234+
235+{-
236+k1, k2 :: Const2 Int () ()
237+k1 = Const2 1
238+k2 = Const2 2
239+p1, p2 :: PatchDMapWithMove (Const2 Int ()) Identity
240+p1 = moveDMapKey k1 k2
241+p2 = moveDMapKey k2 k1
242+p12 = p1 <> p2
243+p21 = p2 <> p1
244+p12Slow = p1 `mappendPatchDMapWithMoveSlow` p2
245+p21Slow = p2 `mappendPatchDMapWithMoveSlow` p1
246+
247+testPatchDMapWithMove = do
248+ print p1
249+ print p2
250+ print $ p12 == deleteDMapKey k1
251+ print $ p21 == deleteDMapKey k2
252+ print $ p12Slow == deleteDMapKey k1
253+ print $ p21Slow == deleteDMapKey k2
254+
255+dst (PatchDMapWithMove x _) = x
256+src (PatchDMapWithMove _ x) = x
257+-}
258+
259+-- |Extract the 'DMap' representing the patch changes from the 'PatchDMapWithMove'.
260+unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)
261+unPatchDMapWithMove (PatchDMapWithMove p) = p
262+
263+-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove', without checking any invariants.
264+--
265+-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchDMapWithMove' are preserved; they will not be checked.
266+unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v
267+unsafePatchDMapWithMove = PatchDMapWithMove
268+
269+-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while checking invariants. If the invariants are satisfied, @Right p@ is returned
270+-- otherwise @Left errors@.
271+patchDMapWithMove :: (GCompare k, GEq k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)
272+patchDMapWithMove dm =
273+ case validationErrorsForPatchDMapWithMove dm of
274+ [] -> Right $ unsafePatchDMapWithMove dm
275+ errs -> Left errs
276+
277+-- |Map a natural transform @v -> v'@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.
278+mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'
279+mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $
280+ DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p
281+ where g :: forall a. From k v a -> From k v' a
282+ g = \case
283+ From_Insert v -> From_Insert $ f v
284+ From_Delete -> From_Delete
285+ From_Move k -> From_Move k
286+
287+-- |Traverse an effectful function @forall a. v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.
288+traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
289+traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
290+
291+-- |Map an effectful function @forall a. k a -> v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.
292+traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
293+traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p
294+ where g :: forall a. k a -> From k v a -> m (From k v' a)
295+ g k = \case
296+ From_Insert v -> From_Insert <$> f k v
297+ From_Delete -> pure From_Delete
298+ From_Move fromKey -> pure $ From_Move fromKey
299+
300+-- |Map a function which transforms @'From' k v a@ into a @'From' k v' a@ over a @'NodeInfo' k v a@.
301+nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a
302+nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
303+
304+-- |Map an effectful function which transforms @'From' k v a@ into a @f ('From' k v' a)@ over a @'NodeInfo' k v a@.
305+nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a)
306+nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
307+
308+-- |Weaken a 'PatchDMapWithMove' to a 'PatchMapWithMove' by weakening the keys from @k a@ to @'Some' k@ and applying a given weakening function @v a -> v'@ to
309+-- values.
310+weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'
311+weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
312+ where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) v'
313+ g ni = MapWithMove.NodeInfo
314+ { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
315+ From_Insert v -> MapWithMove.From_Insert $ f v
316+ From_Delete -> MapWithMove.From_Delete
317+ From_Move k -> MapWithMove.From_Move $ Some.This k
318+ , MapWithMove._nodeInfo_to = Some.This <$> getComposeMaybe (_nodeInfo_to ni)
319+ }
320+
321+-- |"Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k v'@. Weaken is in scare quotes because the 'Const2' has already disabled any
322+-- dependency in the typing and all points are already @a@, hence the function to map each value to @v'@ is not higher rank.
323+patchDMapWithMoveToPatchMapWithMoveWith :: forall k v v' a. (v a -> v') -> PatchDMapWithMove (Const2 k a) v -> PatchMapWithMove k v'
324+patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
325+ where g :: NodeInfo (Const2 k a) v a -> MapWithMove.NodeInfo k v'
326+ g ni = MapWithMove.NodeInfo
327+ { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
328+ From_Insert v -> MapWithMove.From_Insert $ f v
329+ From_Delete -> MapWithMove.From_Delete
330+ From_Move (Const2 k) -> MapWithMove.From_Move k
331+ , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)
332+ }
333+
334+-- |"Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove ('Const2' k a)@; that is, turn a non-dependently-typed patch into a dependently typed
335+-- one but which always has a constant key type represented by 'Const2'. Apply the given function to each @v@ to produce a @v' a@.
336+-- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
337+const2PatchDMapWithMoveWith :: forall k v v' a. (v -> v' a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) v'
338+const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
339+ where g :: (k, MapWithMove.NodeInfo k v) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v')
340+ g (k, ni) = Const2 k :=> NodeInfo
341+ { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of
342+ MapWithMove.From_Insert v -> From_Insert $ f v
343+ MapWithMove.From_Delete -> From_Delete
344+ MapWithMove.From_Move fromKey -> From_Move $ Const2 fromKey
345+ , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni
346+ }
347+
348+instance GCompare k => Patch (PatchDMapWithMove k v) where
349+ type PatchTarget (PatchDMapWithMove k v) = DMap k v
350+ apply (PatchDMapWithMove p) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
351+ where insertions = DMap.mapMaybeWithKey insertFunc p
352+ insertFunc :: forall a. k a -> NodeInfo k v a -> Maybe (v a)
353+ insertFunc _ ni = case _nodeInfo_from ni of
354+ From_Insert v -> Just v
355+ From_Move k -> DMap.lookup k old
356+ From_Delete -> Nothing
357+ deletions = DMap.mapMaybeWithKey deleteFunc p
358+ deleteFunc :: forall a. k a -> NodeInfo k v a -> Maybe (Constant () a)
359+ deleteFunc _ ni = case _nodeInfo_from ni of
360+ From_Delete -> Just $ Constant ()
361+ _ -> Nothing
362+
363+-- | Get the values that will be deleted or moved if the given patch is applied
364+-- to the given 'DMap'.
365+getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))
366+getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
367+ where f _ v ni = Pair v $ _nodeInfo_to ni
src/Reflex/Patch/IntMap.hsnew file+49
@@ -0,0 +1,49 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveFoldable #-}
3+{-# LANGUAGE DeriveFunctor #-}
4+{-# LANGUAGE DeriveTraversable #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6+{-# LANGUAGE TypeFamilies #-}
7+module Reflex.Patch.IntMap where
8+
9+import Data.IntMap.Strict (IntMap)
10+import qualified Data.IntMap.Strict as IntMap
11+import Data.Maybe
12+import Data.Semigroup
13+import Reflex.Patch.Class
14+
15+newtype PatchIntMap a = PatchIntMap (IntMap (Maybe a)) deriving (Functor, Foldable, Traversable, Monoid)
16+
17+instance Patch (PatchIntMap a) where
18+ type PatchTarget (PatchIntMap a) = IntMap a
19+ apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $
20+ let removes = IntMap.filter isNothing p
21+ adds = IntMap.mapMaybe id p
22+ in IntMap.union adds $ v `IntMap.difference` removes
23+
24+-- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@.
25+-- If the same key is modified by both patches, the one on the left will take
26+-- precedence.
27+instance Semigroup (PatchIntMap v) where
28+ PatchIntMap a <> PatchIntMap b = PatchIntMap $ a `mappend` b --TODO: Add a semigroup instance for Map
29+ -- PatchMap is idempotent, so stimes n is id for every n
30+#if MIN_VERSION_semigroups(0,17,0)
31+ stimes = stimesIdempotentMonoid
32+#else
33+ times1p n x = case compare n 0 of
34+ LT -> error "stimesIdempotentMonoid: negative multiplier"
35+ EQ -> mempty
36+ GT -> x
37+#endif
38+
39+traverseIntMapPatchWithKey :: Applicative t => (Int -> a -> t b) -> PatchIntMap a -> t (PatchIntMap b)
40+traverseIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap <$> IntMap.traverseWithKey (\k mv -> traverse (f k) mv) m
41+
42+patchIntMapNewElements :: PatchIntMap a -> [a]
43+patchIntMapNewElements (PatchIntMap m) = catMaybes $ IntMap.elems m
44+
45+patchIntMapNewElementsMap :: PatchIntMap a -> IntMap a
46+patchIntMapNewElementsMap (PatchIntMap m) = IntMap.mapMaybe id m
47+
48+getDeletions :: PatchIntMap v -> IntMap v' -> IntMap v'
49+getDeletions (PatchIntMap m) v = IntMap.intersection v m
src/Reflex/Patch/Map.hsnew file+64
@@ -0,0 +1,64 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE LambdaCase #-}
3+{-# LANGUAGE TypeFamilies #-}
4+-- | 'Patch'es on 'Map' that consist only of insertions (including overwrites)
5+-- and deletions
6+module Reflex.Patch.Map where
7+
8+import Reflex.Patch.Class
9+
10+import Data.Map (Map)
11+import qualified Data.Map as Map
12+import Data.Maybe
13+import Data.Semigroup
14+
15+-- | A set of changes to a 'Map'. Any element may be inserted/updated or
16+-- deleted. Insertions are represented as values wrapped in 'Just', while
17+-- deletions are represented as 'Nothing's
18+newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }
19+ deriving (Show, Read, Eq, Ord)
20+
21+-- | Applying a 'PatchMap' will update the 'Map' by performing the insertions
22+-- and deletions specified
23+instance Ord k => Patch (PatchMap k v) where
24+ type PatchTarget (PatchMap k v) = Map k v
25+ {-# INLINABLE apply #-}
26+ apply (PatchMap p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
27+ where insertions = Map.mapMaybeWithKey (const id) p
28+ deletions = Map.mapMaybeWithKey (const nothingToJust) p
29+ nothingToJust = \case
30+ Nothing -> Just ()
31+ Just _ -> Nothing
32+
33+-- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@.
34+-- If the same key is modified by both patches, the one on the left will take
35+-- precedence.
36+instance Ord k => Semigroup (PatchMap k v) where
37+ PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map
38+ -- PatchMap is idempotent, so stimes n is id for every n
39+#if MIN_VERSION_semigroups(0,17,0)
40+ stimes = stimesIdempotentMonoid
41+#else
42+ times1p n x = case compare n 0 of
43+ LT -> error "stimesIdempotentMonoid: negative multiplier"
44+ EQ -> mempty
45+ GT -> x
46+#endif
47+
48+-- | The empty 'PatchMap' contains no insertions or deletions
49+instance Ord k => Monoid (PatchMap k v) where
50+ mempty = PatchMap mempty
51+ mappend = (<>)
52+
53+-- | 'fmap'ping a 'PatchMap' will alter all of the values it will insert.
54+-- Deletions are unaffected.
55+instance Functor (PatchMap k) where
56+ fmap f = PatchMap . fmap (fmap f) . unPatchMap
57+
58+-- | Returns all the new elements that will be added to the 'Map'
59+patchMapNewElements :: PatchMap k v -> [v]
60+patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p
61+
62+-- | Returns all the new elements that will be added to the 'Map'
63+patchMapNewElementsMap :: PatchMap k v -> Map k v
64+patchMapNewElementsMap (PatchMap p) = Map.mapMaybe id p
src/Reflex/Patch/MapWithMove.hsnew file+156
@@ -0,0 +1,156 @@
1+{-# LANGUAGE DeriveFoldable #-}
2+{-# LANGUAGE DeriveFunctor #-}
3+{-# LANGUAGE DeriveTraversable #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE LambdaCase #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE TypeFamilies #-}
8+-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
9+-- another
10+module Reflex.Patch.MapWithMove where
11+
12+import Reflex.Patch.Class
13+
14+import Control.Arrow
15+import Control.Monad.State
16+import Data.Foldable
17+import Data.Function
18+import Data.List
19+import Data.Map (Map)
20+import qualified Data.Map as Map
21+import Data.Maybe
22+import qualified Data.Set as Set
23+import Data.Tuple
24+
25+-- | Patch a DMap with additions, deletions, and moves. Invariant: If key @k1@
26+-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
27+-- and vice versa. There should never be any unpaired From/To keys.
28+newtype PatchMapWithMove k v = PatchMapWithMove (Map k (NodeInfo k v)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
29+
30+-- | Holds the information about each key: where its new value should come from,
31+-- and where its old value should go to
32+data NodeInfo k v = NodeInfo
33+ { _nodeInfo_from :: !(From k v)
34+ -- ^ Where do we get the new value for this key?
35+ , _nodeInfo_to :: !(To k)
36+ -- ^ If the old value is being kept (i.e. moved rather than deleted or
37+ -- replaced), where is it going?
38+ }
39+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
40+
41+-- | Create a 'PatchMapWithMove', validating it
42+patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
43+patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing
44+ where valid = forwardLinks == backwardLinks
45+ forwardLinks = Map.mapMaybe _nodeInfo_to m
46+ backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, v) ->
47+ case _nodeInfo_from v of
48+ From_Move from -> Just (from, to)
49+ _ -> Nothing
50+
51+-- | Extract the internal representation of the 'PatchMapWithMove'
52+unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)
53+unPatchMapWithMove (PatchMapWithMove p) = p
54+
55+-- | Warning: when using this function, you must ensure that the invariants of
56+-- 'PatchMapWithMove' are preserved; they will not be checked.
57+unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
58+unsafePatchMapWithMove = PatchMapWithMove
59+
60+-- | Describe how a key's new value should be produced
61+data From k v
62+ = From_Insert v -- ^ Insert the given value here
63+ | From_Delete -- ^ Delete the existing value, if any, from here
64+ | From_Move !k -- ^ Move the value here from the given key
65+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
66+
67+-- | Describe where a key's old value will go. If this is 'Just', that means
68+-- the key's old value will be moved to the given other key; if it is 'Nothing',
69+-- that means it will be deleted.
70+type To = Maybe
71+
72+-- | Apply the insertions, deletions, and moves to a given 'Map'
73+instance Ord k => Patch (PatchMapWithMove k v) where
74+ type PatchTarget (PatchMapWithMove k v) = Map k v
75+ apply (PatchMapWithMove p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
76+ where insertions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of
77+ From_Insert v -> Just v
78+ From_Move k -> Map.lookup k old
79+ From_Delete -> Nothing
80+ deletions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of
81+ From_Delete -> Just ()
82+ _ -> Nothing
83+
84+-- | Returns all the new elements that will be added to the 'Map'
85+patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
86+patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap
87+
88+patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v
89+patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p
90+ where f ni = case _nodeInfo_from ni of
91+ From_Insert v -> Just v
92+ From_Move _ -> Nothing
93+ From_Delete -> Nothing
94+
95+-- | Create a 'PatchMapWithMove' that, if applied to the given 'Map', will sort
96+-- its values using the given ordering function. The set keys of the 'Map' is
97+-- not changed.
98+patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v
99+patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted
100+ where unsorted = Map.toList m
101+ sorted = sortBy (cmp `on` snd) unsorted
102+ f (to, _) (from, _) = if to == from then Nothing else
103+ Just (from, to)
104+ reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
105+ g (to, _) (from, _) = if to == from then Nothing else
106+ let Just movingTo = Map.lookup from reverseMapping
107+ in Just (to, NodeInfo (From_Move from) $ Just movingTo)
108+
109+-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
110+-- will produce a 'Map' with the same values as the second 'Map' but with the
111+-- values sorted with the given ordering function.
112+patchThatChangesAndSortsMapWith :: forall k v. (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
113+patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patch
114+ where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
115+ newList = Map.toList newByIndexUnsorted
116+ newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
117+ insertsAndMoves :: Map k (NodeInfo k v)
118+ (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
119+ let f k v = do
120+ remainingValues <- get
121+ let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
122+ then Map.delete v remainingValues
123+ else Map.insert v remainingKeys remainingValues
124+ case Map.lookup v remainingValues of
125+ Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
126+ Just fromKs ->
127+ if k `Set.member` fromKs
128+ then do
129+ putRemainingKeys $ Set.delete k fromKs
130+ return $ NodeInfo (From_Move k) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
131+ else do
132+ Just (fromK, remainingKeys) <- return $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
133+ putRemainingKeys remainingKeys
134+ return $ NodeInfo (From_Move fromK) $ Just undefined
135+ Map.traverseWithKey f newByIndex
136+ unusedOldKeys = fold unusedValuesByValue
137+ pointlessMove k = \case
138+ From_Move k' | k == k' -> True
139+ _ -> False
140+ keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
141+ then Just undefined
142+ else Nothing
143+ patch = unsafePatchMapWithMove $ Map.filterWithKey (\k -> not . pointlessMove k . _nodeInfo_from) $ Map.mergeWithKey (\k a _ -> Just $ nodeInfoSetTo (keyWasMoved k) a) (Map.mapWithKey $ \k -> nodeInfoSetTo $ keyWasMoved k) (Map.mapWithKey $ \k _ -> NodeInfo From_Delete $ keyWasMoved k) insertsAndMoves oldByIndex
144+
145+-- | Change the 'From' value of a 'NodeInfo'
146+nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
147+nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
148+
149+-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
150+-- 'Applicative', 'Monad', etc.) action to get the new value
151+nodeInfoMapMFrom :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
152+nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
153+
154+-- | Set the 'To' field of a 'NodeInfo'
155+nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v
156+nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
src/Reflex/PerformEvent/Base.hs+4−7
@@ -25,7 +25,6 @@ module Reflex.PerformEvent.Base
2525 ) where
2626
2727import Reflex.Class
28−import Reflex.Adjustable.Class
2928import Reflex.Host.Class
3029import Reflex.PerformEvent.Class
3130import Reflex.Requester.Base
@@ -61,14 +60,14 @@ deriving instance ReflexHost t => Monad (PerformEventT t m)
6160deriving instance ReflexHost t => MonadFix (PerformEventT t m)
6261deriving instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (PerformEventT t m)
6362deriving instance (ReflexHost t, MonadException (HostFrame t)) => MonadException (PerformEventT t m)
64−deriving instance (ReflexHost t, Monoid a) => Monoid (PerformEventT t m a)
65−deriving instance (ReflexHost t, S.Semigroup a) => S.Semigroup (PerformEventT t m a)
63+deriving instance (ReflexHost t, Applicative m, Monoid a) => Monoid (PerformEventT t m a)
64+deriving instance (ReflexHost t, Applicative m, S.Semigroup a) => S.Semigroup (PerformEventT t m a)
6665
6766instance (PrimMonad (HostFrame t), ReflexHost t) => PrimMonad (PerformEventT t m) where
6867 type PrimState (PerformEventT t m) = PrimState (HostFrame t)
6968 primitive = PerformEventT . lift . primitive
7069
71−instance (ReflexHost t, Ref m ~ Ref IO) => PerformEvent t (PerformEventT t m) where
70+instance (ReflexHost t, Ref m ~ Ref IO, PrimMonad (HostFrame t)) => PerformEvent t (PerformEventT t m) where
7271 type Performable (PerformEventT t m) = HostFrame t
7372 {-# INLINABLE performEvent_ #-}
7473 performEvent_ = PerformEventT . requesting_
@@ -141,7 +140,7 @@ hostPerformEventT a = do
141140 case mToPerform of
142141 Nothing -> return [result']
143142 Just toPerform -> do
144− responses <- runHostFrame $ traverseRequesterData (fmap Identity) toPerform
143+ responses <- runHostFrame $ traverseRequesterData (\v -> Identity <$> v) toPerform
145144 mrt <- readRef responseTrigger
146145 let followupEventTriggers = case mrt of
147146 Just rt -> [rt :=> Identity responses]
@@ -164,8 +163,6 @@ instance (ReflexHost t, MonadHold t m) => MonadHold t (PerformEventT t m) where
164163 buildDynamic getV0 v' = PerformEventT $ lift $ buildDynamic getV0 v'
165164 {-# INLINABLE headE #-}
166165 headE = PerformEventT . lift . headE
167− {-# INLINABLE now #-}
168− now = PerformEventT . lift $ now
169166
170167instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m) where
171168 type Ref (PerformEventT t m) = Ref (HostFrame t)
src/Reflex/PerformEvent/Class.hs+2−6
@@ -5,9 +5,11 @@
55{-# LANGUAGE FlexibleContexts #-}
66{-# LANGUAGE FlexibleInstances #-}
77{-# LANGUAGE FunctionalDependencies #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
89{-# LANGUAGE RankNTypes #-}
910{-# LANGUAGE ScopedTypeVariables #-}
1011{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE TypeOperators #-}
1113{-# LANGUAGE UndecidableInstances #-}
1214#ifdef USE_REFLEX_OPTIMIZER
1315{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
@@ -21,7 +23,6 @@ import Reflex.Class
2123import Reflex.TriggerEvent.Class
2224
2325import Control.Monad.Reader
24−import Control.Monad.Trans.Maybe (MaybeT (..))
2526
2627-- | 'PerformEvent' represents actions that can trigger other actions based on
2728-- 'Event's.
@@ -61,8 +62,3 @@ instance PerformEvent t m => PerformEvent t (ReaderT r m) where
6162 performEvent e = do
6263 r <- ask
6364 lift $ performEvent $ flip runReaderT r <$> e
64−
65−instance PerformEvent t m => PerformEvent t (MaybeT m) where
66− type Performable (MaybeT m) = MaybeT (Performable m)
67− performEvent_ = lift . performEvent_ . fmapCheap (void . runMaybeT)
68− performEvent = lift . fmap (fmapMaybe id) . performEvent . fmapCheap runMaybeT
src/Reflex/PostBuild/Base.hs+1−3
@@ -9,6 +9,7 @@
99{-# LANGUAGE RecursiveDo #-}
1010{-# LANGUAGE ScopedTypeVariables #-}
1111{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE TypeOperators #-}
1213{-# LANGUAGE UndecidableInstances #-}
1314#ifdef USE_REFLEX_OPTIMIZER
1415{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
@@ -22,7 +23,6 @@ module Reflex.PostBuild.Base
2223 ) where
2324
2425import Reflex.Class
25−import Reflex.Adjustable.Class
2626import Reflex.Host.Class
2727import Reflex.PerformEvent.Class
2828import Reflex.PostBuild.Class
@@ -83,8 +83,6 @@ instance MonadHold t m => MonadHold t (PostBuildT t m) where
8383 buildDynamic a0 = lift . buildDynamic a0
8484 {-# INLINABLE headE #-}
8585 headE = lift . headE
86− {-# INLINABLE now #-}
87− now = lift now
8886
8987instance PerformEvent t m => PerformEvent t (PostBuildT t m) where
9088 type Performable (PostBuildT t m) = Performable m
src/Reflex/PostBuild/Class.hs+2
@@ -4,8 +4,10 @@
44{-# LANGUAGE DataKinds #-}
55{-# LANGUAGE FlexibleInstances #-}
66{-# LANGUAGE FunctionalDependencies #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
78{-# LANGUAGE ScopedTypeVariables #-}
89{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeOperators #-}
911{-# LANGUAGE UndecidableInstances #-}
1012#ifdef USE_REFLEX_OPTIMIZER
1113{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
src/Reflex/Profiled.hs+19−89
@@ -8,28 +8,17 @@
88{-# LANGUAGE StandaloneDeriving #-}
99{-# LANGUAGE TypeFamilies #-}
1010{-# LANGUAGE UndecidableInstances #-}
11−{-# LANGUAGE PolyKinds #-}
12−{-# LANGUAGE TypeApplications #-}
13−{-# LANGUAGE RankNTypes #-}
14−-- |
15−-- Module:
16−-- Reflex.Profiled
17−-- Description:
18−-- This module contains an instance of the 'Reflex' class that provides
19−-- profiling/cost-center information.
2011module Reflex.Profiled where
2112
13+import Control.Lens hiding (children)
2214import Control.Monad
23−import Control.Monad.Exception
2415import Control.Monad.Fix
2516import Control.Monad.Primitive
2617import Control.Monad.Reader
2718import Control.Monad.Ref
2819import Control.Monad.State.Strict (StateT, execStateT, modify)
29−import Data.Bifunctor
3020import Data.Coerce
31−import Data.Dependent.Map (DMap)
32−import Data.GADT.Compare (GCompare)
21+import Data.Dependent.Map (DMap, GCompare)
3322import Data.FastMutableIntMap
3423import Data.IORef
3524import Data.List
@@ -37,27 +26,18 @@ import Data.Map (Map)
3726import qualified Data.Map.Strict as Map
3827import Data.Monoid ((<>))
3928import Data.Ord
40−import Data.Profunctor.Unsafe ((#.))
4129import qualified Data.Semigroup as S
4230import Data.Type.Coercion
4331import Foreign.Ptr
4432import GHC.Foreign
4533import GHC.IO.Encoding
4634import GHC.Stack
47−import Reflex.Adjustable.Class
48−import Reflex.BehaviorWriter.Class
4935import Reflex.Class
50−import Reflex.DynamicWriter.Class
51−import Reflex.EventWriter.Class
5236import Reflex.Host.Class
53−import Reflex.NotReady.Class
5437import Reflex.PerformEvent.Class
55−import Reflex.PostBuild.Class
56−import Reflex.Query.Class
57−import Reflex.Requester.Class
58−import Reflex.TriggerEvent.Class
5938
6039import System.IO.Unsafe
40+import Unsafe.Coerce
6141
6242data ProfiledTimeline t
6343
@@ -90,9 +70,9 @@ getCostCentreStack = go []
9070 go (cc : l) parent
9171
9272toCostCentreTree :: Ptr CostCentreStack -> Int -> IO CostCentreTree
93−toCostCentreTree ccs n =
94− foldr (\cc child -> CostCentreTree 0 n $ Map.singleton cc child) (CostCentreTree n n mempty)
95− <$> getCostCentreStack ccs
73+toCostCentreTree ccs n = do
74+ ccList <- getCostCentreStack ccs
75+ return $ foldr (\cc child -> CostCentreTree 0 n $ Map.singleton cc child) (CostCentreTree n n mempty) ccList
9676
9777getCostCentreTree :: IO CostCentreTree
9878getCostCentreTree = do
@@ -121,8 +101,7 @@ writeProfilingData :: FilePath -> IO ()
121101writeProfilingData p = do
122102 writeFile p =<< formatCostCentreTree =<< getCostCentreTree
123103
124−newtype ProfiledM m a = ProfiledM { runProfiledM :: m a }
125− deriving (Functor, Applicative, Monad, MonadFix, MonadException, MonadAsyncException)
104+newtype ProfiledM m a = ProfiledM { runProfiledM :: m a } deriving (Functor, Applicative, Monad, MonadFix)
126105
127106profileEvent :: Reflex t => Event t a -> Event t a
128107profileEvent e = unsafePerformIO $ do
@@ -146,32 +125,27 @@ instance Reflex t => Reflex (ProfiledTimeline t) where
146125 push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us
147126 pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e
148127 pull = Behavior_Profiled . pull . coerce
149− fanG (Event_Profiled e) = EventSelectorG $ coerce $ selectG (fanG $ profileEvent e)
150− mergeG :: forall z (k :: z -> *) q v. GCompare k
151− => (forall a. q a -> Event (ProfiledTimeline t) (v a))
152− -> DMap k q -> Event (ProfiledTimeline t) (DMap k v)
153− mergeG nt = Event_Profiled #. mergeG (coerce nt)
128+ merge :: forall k. GCompare k => DMap k (Event (ProfiledTimeline t)) -> Event (ProfiledTimeline t) (DMap k Identity)
129+ merge = Event_Profiled . merge . (unsafeCoerce :: DMap k (Event (ProfiledTimeline t)) -> DMap k (Event t))
130+ fan (Event_Profiled e) = EventSelector $ coerce $ select (fan $ profileEvent e)
154131 switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b)
155132 coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e)
156133 current (Dynamic_Profiled d) = coerce $ current d
157134 updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d
158135 unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'
159136 unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'
160− mergeIncrementalG nt res = Event_Profiled $ mergeIncrementalG (coerce nt) (coerce res)
161− mergeIncrementalWithMoveG nt res = Event_Profiled $ mergeIncrementalWithMoveG (coerce nt) (coerce res)
137+ mergeIncremental = Event_Profiled . mergeIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMap k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMap k (Event t)))
138+ mergeIncrementalWithMove = Event_Profiled . mergeIncrementalWithMove . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMapWithMove k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMapWithMove k (Event t)))
162139 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i
163140 updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i
164141 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i
165− behaviorCoercion c =
166− Coercion `trans` behaviorCoercion @t c `trans` Coercion
167− eventCoercion c =
168− Coercion `trans` eventCoercion @t c `trans` Coercion
169− dynamicCoercion c =
170− Coercion `trans` dynamicCoercion @t c `trans` Coercion
171− incrementalCoercion c d =
172− Coercion `trans` incrementalCoercion @t c d `trans` Coercion
173− mergeIntIncremental = Event_Profiled . mergeIntIncremental .
174− coerceWith (Coercion `trans` incrementalCoercion Coercion Coercion `trans` Coercion)
142+ behaviorCoercion (c :: Coercion a b) = case behaviorCoercion c :: Coercion (Behavior t a) (Behavior t b) of
143+ Coercion -> unsafeCoerce (Coercion :: Coercion (Behavior (ProfiledTimeline t) a) (Behavior (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
144+ eventCoercion (c :: Coercion a b) = case eventCoercion c :: Coercion (Event t a) (Event t b) of
145+ Coercion -> unsafeCoerce (Coercion :: Coercion (Event (ProfiledTimeline t) a) (Event (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
146+ dynamicCoercion (c :: Coercion a b) = case dynamicCoercion c :: Coercion (Dynamic t a) (Dynamic t b) of
147+ Coercion -> unsafeCoerce (Coercion :: Coercion (Dynamic (ProfiledTimeline t) a) (Dynamic (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
148+ mergeIntIncremental = Event_Profiled . mergeIntIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchIntMap (Event (ProfiledTimeline t) a)) -> Incremental t (PatchIntMap (Event t a)))
175149 fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e
176150
177151deriving instance Functor (Dynamic t) => Functor (Dynamic (ProfiledTimeline t))
@@ -184,21 +158,10 @@ instance MonadHold t m => MonadHold (ProfiledTimeline t) (ProfiledM m) where
184158 holdIncremental v0 (Event_Profiled v') = ProfiledM $ Incremental_Profiled <$> holdIncremental v0 v'
185159 buildDynamic (ProfiledM v0) (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> buildDynamic v0 v'
186160 headE (Event_Profiled e) = ProfiledM $ Event_Profiled <$> headE e
187− now = ProfiledM $ Event_Profiled <$> now
188161
189162instance MonadSample t m => MonadSample (ProfiledTimeline t) (ProfiledM m) where
190163 sample (Behavior_Profiled b) = ProfiledM $ sample b
191164
192−instance Adjustable t m => Adjustable (ProfiledTimeline t) (ProfiledM m) where
193− runWithReplace a0 a' = (fmap . fmap) coerce . lift $
194− runWithReplace (coerce a0) (coerce $ coerce <$> a')
195− traverseIntMapWithKeyWithAdjust f dm0 dm' = (fmap . fmap) coerce . lift $
196− traverseIntMapWithKeyWithAdjust (\k v -> coerce $ f k v) dm0 (coerce dm')
197− traverseDMapWithKeyWithAdjust f dm0 dm' = (fmap . fmap) coerce . lift $
198− traverseDMapWithKeyWithAdjust (\k v -> coerce $ f k v) dm0 (coerce dm')
199− traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = (fmap . fmap) coerce . lift $
200− traverseDMapWithKeyWithAdjustWithMove (\k v -> coerce $ f k v) dm0 (coerce dm')
201−
202165instance MonadTrans ProfiledM where
203166 lift = ProfiledM
204167
@@ -210,39 +173,6 @@ instance PerformEvent t m => PerformEvent (ProfiledTimeline t) (ProfiledM m) whe
210173 performEvent_ = lift . performEvent_ . coerce
211174 performEvent = lift . fmap coerce . performEvent . coerce
212175
213−instance TriggerEvent t m => TriggerEvent (ProfiledTimeline t) (ProfiledM m) where
214− newTriggerEvent = first coerce <$> lift newTriggerEvent
215− newTriggerEventWithOnComplete = first coerce <$> lift newTriggerEventWithOnComplete
216− newEventWithLazyTriggerWithOnComplete f = coerce <$> lift (newEventWithLazyTriggerWithOnComplete f)
217−
218−instance PostBuild t m => PostBuild (ProfiledTimeline t) (ProfiledM m) where
219− getPostBuild = coerce <$> lift getPostBuild
220−
221−instance NotReady t m => NotReady (ProfiledTimeline t) (ProfiledM m) where
222− notReady = lift notReady
223− notReadyUntil = lift . notReadyUntil . coerce
224−
225−instance BehaviorWriter t w m => BehaviorWriter (ProfiledTimeline t) w (ProfiledM m) where
226− tellBehavior = lift . tellBehavior . coerce
227−
228−instance DynamicWriter t w m => DynamicWriter (ProfiledTimeline t) w (ProfiledM m) where
229− tellDyn = lift . tellDyn . coerce
230−
231−instance EventWriter t w m => EventWriter (ProfiledTimeline t) w (ProfiledM m) where
232− tellEvent = lift . tellEvent . coerce
233−
234−instance MonadQuery t q m => MonadQuery (ProfiledTimeline t) q (ProfiledM m) where
235− tellQueryIncremental = lift . tellQueryIncremental . coerce
236− askQueryResult = coerce <$> lift askQueryResult
237− queryIncremental = fmap coerce . lift . queryIncremental . coerce
238−
239−instance Requester t m => Requester (ProfiledTimeline t) (ProfiledM m) where
240− type Request (ProfiledM m) = Request m
241− type Response (ProfiledM m) = Response m
242−
243− requesting = fmap coerce . lift . requesting . coerce
244− requesting_ = lift . requesting_ . coerce
245−
246176instance MonadRef m => MonadRef (ProfiledM m) where
247177 type Ref (ProfiledM m) = Ref m
248178 newRef = lift . newRef
src/Reflex/Pure.hs+27−38
@@ -5,9 +5,6 @@
55{-# LANGUAGE MultiParamTypeClasses #-}
66{-# LANGUAGE ScopedTypeVariables #-}
77{-# LANGUAGE TypeFamilies #-}
8−{-# LANGUAGE RankNTypes #-}
9−{-# LANGUAGE PolyKinds #-}
10−
118#ifdef USE_REFLEX_OPTIMIZER
129{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
1310#endif
@@ -16,13 +13,11 @@
1613-- * MonadSample (Pure t) ((->) t)
1714-- * MonadHold (Pure t) ((->) t)
1815{-# OPTIONS_GHC -fno-warn-orphans #-}
19−-- |
20−-- Module: Reflex.Pure
21−-- Description:
22−-- This module provides a pure implementation of Reflex, which is intended to
23−-- serve as a reference for the semantics of the Reflex class. All
24−-- implementations of Reflex should produce the same results as this
25−-- implementation, although performance and laziness/strictness may differ.
16+
17+-- | This module provides a pure implementation of Reflex, which is intended to
18+-- serve as a reference for the semantics of the Reflex class. All
19+-- implementations of Reflex should produce the same results as this
20+-- implementation, although performance and laziness/strictness may differ.
2621module Reflex.Pure
2722 ( Pure
2823 , Behavior (..)
@@ -31,10 +26,14 @@ module Reflex.Pure
3126 , Incremental (..)
3227 ) where
3328
29+#if !MIN_VERSION_base(4,8,0)
30+import Control.Applicative
31+#endif
32+
3433import Control.Monad
35−import Data.Dependent.Map (DMap)
36−import Data.GADT.Compare (GCompare)
34+import Data.Dependent.Map (DMap, GCompare)
3735import qualified Data.Dependent.Map as DMap
36+import Data.Functor.Identity
3837import Data.IntMap (IntMap)
3938import qualified Data.IntMap as IntMap
4039import Data.Maybe
@@ -42,15 +41,14 @@ import Data.MemoTrie
4241import Data.Monoid
4342import Data.Type.Coercion
4443import Reflex.Class
45−import Data.Kind (Type)
4644
4745-- | A completely pure-functional 'Reflex' timeline, identifying moments in time
48−-- with the type @/t/@.
49−data Pure (t :: Type)
46+-- with the type @t@.
47+data Pure t
5048
51−-- | The 'Enum' instance of @/t/@ must be dense: for all @/x :: t/@, there must not exist
52−-- any @/y :: t/@ such that @/'pred' x < y < x/@. The 'HasTrie' instance will be used
53−-- exclusively to memoize functions of @/t/@, not for any of its other capabilities.
49+-- | The Enum instance of t must be dense: for all x :: t, there must not exist
50+-- any y :: t such that pred x < y < x. The HasTrie instance will be used
51+-- exclusively to memoize functions of t, not for any of its other capabilities.
5452instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
5553
5654 newtype Behavior (Pure t) a = Behavior { unBehavior :: t -> a }
@@ -79,19 +77,17 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
7977 -- [UNUSED_CONSTRAINT]: The following type signature for merge will produce a
8078 -- warning because the GCompare instance is not used; however, removing the
8179 -- GCompare instance produces a different warning, due to that constraint
82− -- being present in the original class definition.
80+ -- being present in the original class definition
8381
84− --mergeG :: GCompare k => (forall a. q a -> Event (Pure t) (v a))
85− -- -> DMap k q -> Event (Pure t) (DMap k v)
86− mergeG nt events = Event $ memo $ \t ->
87− let currentOccurrences = DMap.mapMaybeWithKey (\_ q -> case nt q of Event a -> a t) events
82+ --merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity)
83+ merge events = Event $ memo $ \t ->
84+ let currentOccurrences = DMap.mapMaybeWithKey (\_ (Event a) -> Identity <$> a t) events
8885 in if DMap.null currentOccurrences
8986 then Nothing
9087 else Just currentOccurrences
9188
92−-- The instance signature doeesn't compile, leave commented for documentation
93−-- fanG :: GCompare k => Event (Pure t) (DMap k v) -> EventSelectorG (Pure t) k v
94− fanG e = EventSelectorG $ \k -> Event $ \t -> unEvent e t >>= DMap.lookup k
89+ fan :: GCompare k => Event (Pure t) (DMap k Identity) -> EventSelector (Pure t) k
90+ fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= fmap runIdentity . DMap.lookup k
9591
9692 switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a
9793 switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t
@@ -114,8 +110,8 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
114110 --a) -> Incremental (Pure t) p a
115111 unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t)
116112
117− mergeIncrementalG = mergeIncrementalImpl
118− mergeIncrementalWithMoveG = mergeIncrementalImpl
113+ mergeIncremental = mergeIncrementalImpl
114+ mergeIncrementalWithMove = mergeIncrementalImpl
119115
120116 currentIncremental i = Behavior $ \t -> fst $ unIncremental i t
121117
@@ -130,17 +126,14 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
130126 behaviorCoercion Coercion = Coercion
131127 eventCoercion Coercion = Coercion
132128 dynamicCoercion Coercion = Coercion
133− incrementalCoercion Coercion Coercion = Coercion
134129
135130 fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k
136131
137132 mergeIntIncremental = mergeIntIncrementalImpl
138133
139−mergeIncrementalImpl :: (PatchTarget p ~ DMap k q, GCompare k)
140− => (forall a. q a -> Event (Pure t) (v a))
141− -> Incremental (Pure t) p -> Event (Pure t) (DMap k v)
142−mergeIncrementalImpl nt i = Event $ \t ->
143− let results = DMap.mapMaybeWithKey (\_ q -> case nt q of Event e -> e t) $ fst $ unIncremental i t
134+mergeIncrementalImpl :: (PatchTarget p ~ DMap k (Event (Pure t)), GCompare k) => Incremental (Pure t) p -> Event (Pure t) (DMap k Identity)
135+mergeIncrementalImpl i = Event $ \t ->
136+ let results = DMap.mapMaybeWithKey (\_ (Event e) -> Identity <$> e t) $ fst $ unIncremental i t
144137 in if DMap.null results
145138 then Nothing
146139 else Just results
@@ -211,7 +204,3 @@ instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where
211204 Just x -> fromMaybe lastValue $ apply x lastValue
212205
213206 headE = slowHeadE
214− now t = Event $ guard . (t ==)
215−
216−
217−
src/Reflex/Query/Base.hs+49−108
@@ -1,14 +1,13 @@
11{-# LANGUAGE FlexibleInstances #-}
22{-# LANGUAGE GeneralizedNewtypeDeriving #-}
33{-# LANGUAGE InstanceSigs #-}
4+{-# LANGUAGE KindSignatures #-}
45{-# LANGUAGE LambdaCase #-}
56{-# LANGUAGE MultiParamTypeClasses #-}
67{-# LANGUAGE RankNTypes #-}
78{-# LANGUAGE ScopedTypeVariables #-}
89{-# LANGUAGE TypeFamilies #-}
910{-# LANGUAGE UndecidableInstances #-}
10−{-# LANGUAGE StandaloneDeriving #-}
11−
1211module Reflex.Query.Base
1312 ( QueryT (..)
1413 , runQueryT
@@ -16,41 +15,33 @@ module Reflex.Query.Base
1615 , mapQueryResult
1716 , dynWithQueryT
1817 , withQueryT
19− , mapQueryT
2018 ) where
2119
2220import Control.Applicative (liftA2)
2321import Control.Monad.Exception
2422import Control.Monad.Fix
25−import Control.Monad.Morph
26−import Control.Monad.Primitive
2723import Control.Monad.Reader
2824import Control.Monad.Ref
2925import Control.Monad.State.Strict
3026import Data.Align
31−import Data.Dependent.Map (DMap)
27+import Data.Dependent.Map (DMap, DSum (..))
3228import qualified Data.Dependent.Map as DMap
33−import Data.Dependent.Sum (DSum(..))
3429import Data.Foldable
3530import Data.Functor.Compose
3631import Data.Functor.Misc
37−import Data.GADT.Compare (GCompare)
38−import Data.IntMap (IntMap)
39−import qualified Data.IntMap as IntMap
4032import Data.Map (Map)
4133import qualified Data.Map as Map
4234import Data.Monoid ((<>))
4335import qualified Data.Semigroup as S
44−import Data.Some (Some(Some))
36+import Data.Some (Some)
37+import qualified Data.Some as Some
4538import Data.These
4639
4740import Reflex.Class
48−import Reflex.Adjustable.Class
49−import Reflex.DynamicWriter.Class
5041import Reflex.EventWriter.Base
5142import Reflex.EventWriter.Class
5243import Reflex.Host.Class
53−import qualified Data.Patch.MapWithMove as MapWithMove
44+import qualified Reflex.Patch.MapWithMove as MapWithMove
5445import Reflex.PerformEvent.Class
5546import Reflex.PostBuild.Class
5647import Reflex.Query.Class
@@ -58,10 +49,7 @@ import Reflex.Requester.Class
5849import Reflex.TriggerEvent.Class
5950
6051newtype QueryT t q m a = QueryT { unQueryT :: StateT [Behavior t q] (EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m)) a }
61− deriving (Functor, Applicative, Monad, MonadException, MonadFix, MonadIO, MonadAtomicRef)
62−
63−deriving instance MonadHold t m => MonadHold t (QueryT t q m)
64−deriving instance MonadSample t m => MonadSample t (QueryT t q m)
52+ deriving (Functor, Applicative, Monad, MonadException, MonadFix, MonadIO, MonadHold t, MonadSample t, MonadAtomicRef)
6553
6654runQueryT :: (MonadFix m, Additive q, Group q, Reflex t) => QueryT t q m a -> Dynamic t (QueryResult q) -> m (a, Incremental t (AdditivePatch q))
6755runQueryT (QueryT a) qr = do
@@ -76,69 +64,30 @@ getQueryTLoweredResultValue (QueryTLoweredResult (v, _)) = v
7664getQueryTLoweredResultWritten :: QueryTLoweredResult t q v -> [Behavior t q]
7765getQueryTLoweredResultWritten (QueryTLoweredResult (_, w)) = w
7866
79−maskMempty :: (Eq a, Monoid a) => a -> Maybe a
80−maskMempty x = if x == mempty then Nothing else Just x
81−
82−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
67+{-
68+let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
69+ sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
70+ bs' = fmapCheap snd $ r'
71+ patches = unsafeBuildIncremental (sampleBs bs0) $
72+ flip pushCheap bs' $ \bs -> do
73+ p <- (~~) <$> sampleBs bs <*> sample (currentIncremental patches)
74+ return (Just (AdditivePatch p))
75+-}
76+
77+instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Adjustable t m) => Adjustable t (QueryT t q m) where
8378 runWithReplace (QueryT a0) a' = do
8479 ((r0, bs0), r') <- QueryT $ lift $ runWithReplace (runStateT a0 []) $ fmapCheap (flip runStateT [] . unQueryT) a'
8580 let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
8681 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
8782 bs' = fmapCheap snd $ r'
8883 bbs <- hold bs0 bs'
89− let patches = flip pushCheap bs' $ \newBs -> do
84+ let patches = flip pushAlwaysCheap bs' $ \newBs -> do
9085 oldBs <- sample bbs
91− maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)
86+ (~~) <$> sampleBs newBs <*> sampleBs oldBs
9287 QueryT $ modify $ (:) $ pull $ sampleBs =<< sample bbs
9388 QueryT $ lift $ tellEvent patches
9489 return (r0, fmapCheap fst r')
95−
96− traverseIntMapWithKeyWithAdjust :: forall v v'. (IntMap.Key -> v -> QueryT t q m v') -> IntMap v -> Event t (PatchIntMap v) -> QueryT t q m (IntMap v', Event t (PatchIntMap v'))
97− traverseIntMapWithKeyWithAdjust f im0 im' = do
98− let f' :: IntMap.Key -> v -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (QueryTLoweredResult t q v')
99− f' k v = fmap QueryTLoweredResult $ flip runStateT [] $ unQueryT $ f k v
100− (result0, result') <- QueryT $ lift $ traverseIntMapWithKeyWithAdjust f' im0 im'
101− let liftedResult0 = IntMap.map getQueryTLoweredResultValue result0
102− liftedResult' = fforCheap result' $ \(PatchIntMap p) -> PatchIntMap $
103− IntMap.map (fmap getQueryTLoweredResultValue) p
104− liftedBs0 :: IntMap [Behavior t q]
105− liftedBs0 = IntMap.map getQueryTLoweredResultWritten result0
106− liftedBs' :: Event t (PatchIntMap [Behavior t q])
107− liftedBs' = fforCheap result' $ \(PatchIntMap p) -> PatchIntMap $
108− IntMap.map (fmap getQueryTLoweredResultWritten) p
109− sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
110− sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
111− accumBehaviors :: forall m'. MonadHold t m'
112− => IntMap [Behavior t q]
113− -> PatchIntMap [Behavior t q]
114− -> m' ( Maybe (IntMap [Behavior t q])
115− , Maybe (AdditivePatch q))
116− -- f accumulates the child behavior state we receive from running traverseIntMapWithKeyWithAdjust for the underlying monad.
117− -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.
118− -- bs0 is a Map denoting the behaviors of the current children.
119− -- pbs is a PatchMap denoting an update to the behaviors of the current children
120− accumBehaviors bs0 pbs@(PatchIntMap bs') = do
121− let p k bs = case IntMap.lookup k bs0 of
122− Nothing -> case bs of
123− -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
124− Nothing -> return mempty
125− -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.
126− Just newBs -> sampleBs newBs
127− Just oldBs -> case bs of
128− -- If the update is to delete the state for a child that already exists, the patch is the negation of the child's current state
129− Nothing -> negateG <$> sampleBs oldBs
130− -- If the update is to update the state for a child that already exists, the patch is the negation of sampling the child's current state
131− -- composed with the sampling the child's new state.
132− Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
133− -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
134− -- child patches and wrap them in AdditivePatch.
135− patch <- AdditivePatch . fold <$> IntMap.traverseWithKey p bs'
136− return (apply pbs bs0, Just patch)
137− (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'
138− tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
139− return (liftedResult0, liftedResult')
140−
141− 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'))
90+ traverseDMapWithKeyWithAdjust :: forall (k :: * -> *) v v'. (DMap.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'))
14291 traverseDMapWithKeyWithAdjust f dm0 dm' = do
14392 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
14493 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
@@ -147,10 +96,10 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t
14796 liftedResult' = fforCheap result' $ \(PatchDMap p) -> PatchDMap $
14897 mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mr) -> k :=> ComposeMaybe (fmap (getQueryTLoweredResultValue . getCompose) mr)) p
14998 liftedBs0 :: Map (Some k) [Behavior t q]
150− liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0
99+ liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0
151100 liftedBs' :: Event t (PatchMap (Some k) [Behavior t q])
152101 liftedBs' = fforCheap result' $ \(PatchDMap p) -> PatchMap $
153− Map.fromDistinctAscList $ (\(k :=> ComposeMaybe mr) -> (Some k, fmap (getQueryTLoweredResultWritten . getCompose) mr)) <$> DMap.toList p
102+ Map.fromDistinctAscList $ (\(k :=> ComposeMaybe mr) -> (Some.This k, fmap (getQueryTLoweredResultWritten . getCompose) mr)) <$> DMap.toList p
154103 sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
155104 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
156105 accumBehaviors :: forall m'. MonadHold t m'
@@ -166,24 +115,23 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t
166115 let p k bs = case Map.lookup k bs0 of
167116 Nothing -> case bs of
168117 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
169− Nothing -> return Nothing
118+ Nothing -> return mempty
170119 -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.
171− Just newBs -> maskMempty <$> sampleBs newBs
120+ Just newBs -> sampleBs newBs
172121 Just oldBs -> case bs of
173122 -- If the update is to delete the state for a child that already exists, the patch is the negation of the child's current state
174− Nothing -> maskMempty . negateG <$> sampleBs oldBs
123+ Nothing -> negateG <$> sampleBs oldBs
175124 -- If the update is to update the state for a child that already exists, the patch is the negation of sampling the child's current state
176125 -- composed with the sampling the child's new state.
177− Just newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)
126+ Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
178127 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
179128 -- child patches and wrap them in AdditivePatch.
180− patch <- fold <$> Map.traverseWithKey p bs'
181− return (apply pbs bs0, AdditivePatch <$> patch)
129+ patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'
130+ return (apply pbs bs0, Just patch)
182131 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'
183132 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
184133 return (liftedResult0, liftedResult')
185−
186− 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'))
134+ traverseDMapWithKeyWithAdjustWithMove :: forall (k :: * -> *) v v'. (DMap.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'))
187135 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do
188136 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
189137 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
@@ -191,10 +139,10 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t
191139 let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0
192140 liftedResult' = fforCheap result' $ mapPatchDMapWithMove (getQueryTLoweredResultValue . getCompose)
193141 liftedBs0 :: Map (Some k) [Behavior t q]
194− liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0
142+ liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0
195143 liftedBs' :: Event t (PatchMapWithMove (Some k) [Behavior t q])
196144 liftedBs' = fforCheap result' $ weakenPatchDMapWithMoveWith (getQueryTLoweredResultWritten . getCompose) {- \(PatchDMap p) -> PatchMapWithMove $
197− Map.fromDistinctAscList $ (\(k :=> mr) -> (Some k, fmap (fmap (getQueryTLoweredResultWritten . getCompose)) mr)) <$> DMap.toList p -}
145+ Map.fromDistinctAscList $ (\(k :=> mr) -> (Some.This k, fmap (fmap (getQueryTLoweredResultWritten . getCompose)) mr)) <$> DMap.toList p -}
198146 sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
199147 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
200148 accumBehaviors' :: forall m'. MonadHold t m'
@@ -211,28 +159,28 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t
211159 p k bs = case Map.lookup k bs0 of
212160 Nothing -> case MapWithMove._nodeInfo_from bs of
213161 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
214− MapWithMove.From_Delete -> return Nothing
162+ MapWithMove.From_Delete -> return mempty
215163 -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.
216− MapWithMove.From_Insert newBs -> maskMempty <$> sampleBs newBs
164+ MapWithMove.From_Insert newBs -> sampleBs newBs
217165 MapWithMove.From_Move k' -> case Map.lookup k' bs0 of
218− Nothing -> return Nothing
219− Just newBs -> maskMempty <$> sampleBs newBs
166+ Nothing -> return mempty
167+ Just newBs -> sampleBs newBs
220168 Just oldBs -> case MapWithMove._nodeInfo_from bs of
221169 -- If the update is to delete the state for a child that already exists, the patch is the negation of the child's current state
222− MapWithMove.From_Delete -> maskMempty . negateG <$> sampleBs oldBs
170+ MapWithMove.From_Delete -> negateG <$> sampleBs oldBs
223171 -- If the update is to update the state for a child that already exists, the patch is the negation of sampling the child's current state
224172 -- composed with the sampling the child's new state.
225− MapWithMove.From_Insert newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)
173+ MapWithMove.From_Insert newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
226174 MapWithMove.From_Move k'
227− | k' == k -> return Nothing
175+ | k' == k -> return mempty
228176 | otherwise -> case Map.lookup k' bs0 of
229177 -- If we are moving from a non-existent key, that is a delete
230− Nothing -> maskMempty . negateG <$> sampleBs oldBs
231− Just newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)
178+ Nothing -> negateG <$> sampleBs oldBs
179+ Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
232180 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
233181 -- child patches and wrap them in AdditivePatch.
234− patch <- fold <$> Map.traverseWithKey p bs'
235− return (apply pbs bs0, AdditivePatch <$> patch)
182+ patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'
183+ return (apply pbs bs0, Just patch)
236184 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors' liftedBs0 liftedBs'
237185 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
238186 return (liftedResult0, liftedResult')
@@ -240,13 +188,6 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t
240188instance MonadTrans (QueryT t q) where
241189 lift = QueryT . lift . lift . lift
242190
243−instance MFunctor (QueryT t q) where
244− hoist = mapQueryT
245−
246−instance PrimMonad m => PrimMonad (QueryT t q m) where
247− type PrimState (QueryT t q m) = PrimState m
248− primitive = lift . primitive
249−
250191instance PostBuild t m => PostBuild t (QueryT t q m) where
251192 getPostBuild = lift getPostBuild
252193
@@ -281,6 +222,13 @@ instance (Monoid a, Monad m) => Monoid (QueryT t q m a) where
281222instance (S.Semigroup a, Monad m) => S.Semigroup (QueryT t q m a) where
282223 (<>) = liftA2 (S.<>)
283224
225+
226+mapQuery :: QueryMorphism q q' -> q -> q'
227+mapQuery = _queryMorphism_mapQuery
228+
229+mapQueryResult :: QueryMorphism q q' -> QueryResult q' -> QueryResult q
230+mapQueryResult = _queryMorphism_mapQueryResult
231+
284232-- | withQueryT's QueryMorphism argument needs to be a group homomorphism in order to behave correctly
285233withQueryT :: (MonadFix m, PostBuild t m, Group q, Group q', Additive q, Additive q', Query q')
286234 => QueryMorphism q q'
@@ -294,10 +242,6 @@ withQueryT f a = do
294242 (fmapCheap (AdditivePatch . mapQuery f . unAdditivePatch) $ updatedIncremental q)
295243 return result
296244
297−-- | Maps a function over a 'QueryT' that can change the underlying monad
298−mapQueryT :: (forall b. m b -> n b) -> QueryT t q m a -> QueryT t q n a
299−mapQueryT f (QueryT a) = QueryT $ mapStateT (mapEventWriterT (mapReaderT f)) a
300−
301245-- | dynWithQueryT's (Dynamic t QueryMorphism) argument needs to be a group homomorphism at all times in order to behave correctly
302246dynWithQueryT :: (MonadFix m, PostBuild t m, Group q, Additive q, Group q', Additive q', Query q')
303247 => Dynamic t (QueryMorphism q q')
@@ -341,6 +285,3 @@ instance Requester t m => Requester t (QueryT t q m) where
341285
342286instance EventWriter t w m => EventWriter t w (QueryT t q m) where
343287 tellEvent = lift . tellEvent
344−
345−instance DynamicWriter t w m => DynamicWriter t w (QueryT t q m) where
346− tellDyn = lift . tellDyn
src/Reflex/Query/Class.hs+9−91
@@ -1,18 +1,11 @@
1−{-# LANGUAGE CPP #-}
21{-# LANGUAGE DeriveDataTypeable #-}
32{-# LANGUAGE FlexibleContexts #-}
43{-# LANGUAGE FlexibleInstances #-}
54{-# LANGUAGE FunctionalDependencies #-}
65{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
77{-# LANGUAGE TypeFamilies #-}
88{-# LANGUAGE UndecidableInstances #-}
9−-- |
10−-- Module:
11−-- Reflex.Query.Class
12−-- Description:
13−-- A class that ties together queries to some data source and their results,
14−-- providing methods for requesting data from the source and accumulating
15−-- streamed results.
169module Reflex.Query.Class
1710 ( Query (..)
1811 , QueryMorphism (..)
@@ -22,94 +15,29 @@ module Reflex.Query.Class
2215 , MonadQuery (..)
2316 , tellQueryDyn
2417 , queryDyn
25− , subQuery
26− , mapQuery
27− , mapQueryResult
2818 ) where
2919
30−import Control.Category (Category)
31−import qualified Control.Category as Cat
3220import Control.Monad.Reader
3321import Data.Bits
3422import Data.Data
3523import Data.Ix
36−import Data.Map.Monoidal (MonoidalMap)
37−import qualified Data.Map.Monoidal as MonoidalMap
38−import Data.Semigroup (Semigroup(..))
24+import Data.Semigroup
3925import Foreign.Storable
40−import Data.Void
41−import Data.Monoid hiding ((<>))
42−import Control.Applicative
4326
4427import Reflex.Class
4528
46−-- | A 'Query' can be thought of as a declaration of interest in some set of data.
47−-- A 'QueryResult' is the set of data associated with that interest set.
48−-- The @crop@ function provides a way to determine what part of a given 'QueryResult'
49−-- is relevant to a given 'Query'.
5029class (Monoid (QueryResult a), Semigroup (QueryResult a)) => Query a where
5130 type QueryResult a :: *
5231 crop :: a -> QueryResult a -> QueryResult a
5332
54−instance (Ord k, Query v) => Query (MonoidalMap k v) where
55− type QueryResult (MonoidalMap k v) = MonoidalMap k (QueryResult v)
56− crop q r = MonoidalMap.intersectionWith (flip crop) r q
57−
58−-- | the result of two queries is both results.
59−instance (Query a, Query b) => Query (a, b) where
60− type QueryResult (a, b) = (QueryResult a, QueryResult b)
61− crop (x, x') (y, y') = (crop x y, crop x' y')
62−
63−-- | Trivial queries have trivial results.
64−instance Query () where
65− type QueryResult () = ()
66− crop _ _ = ()
67−
68−-- | The result of an absurd query is trivial; If you can ask the question, the
69−-- answer cannot tell you anything you didn't already know.
70−--
71−-- 'QueryResult Void = @Void@' seems like it would also work, but that has
72−-- problems of robustness. In some applications, an unasked question can still
73−-- be answered, so it is important that the result is inhabited even when the
74−-- question isn't. Applications that wish to prevent this can mandate that the
75−-- query result be paired with the query: then the whole response will be
76−-- uninhabited as desired.
77−instance Query Void where
78− type QueryResult Void = ()
79− crop = absurd
80−
81−#if MIN_VERSION_base(4,12,0)
82−-- | We can lift queries into monoidal containers.
83−-- But beware of Applicatives whose monoid is different from (pure mempty, liftA2 mappend)
84−instance (Query q, Applicative f) => Query (Ap f q) where
85− type QueryResult (Ap f q) = Ap f (QueryResult q)
86− crop = liftA2 crop
87−#endif
88−
89−-- | QueryMorphism's must be group homomorphisms when acting on the query type
90−-- and compatible with the query relationship when acting on the query result.
33+-- | NB: QueryMorphism's must be group homomorphisms when acting on the query type
34+-- and compatible with the query relationship when acting on the query result
9135data QueryMorphism q q' = QueryMorphism
9236 { _queryMorphism_mapQuery :: q -> q'
9337 , _queryMorphism_mapQueryResult :: QueryResult q' -> QueryResult q
9438 }
9539
96−instance Category QueryMorphism where
97− id = QueryMorphism id id
98− qm . qm' = QueryMorphism
99− { _queryMorphism_mapQuery = mapQuery qm . mapQuery qm'
100− , _queryMorphism_mapQueryResult = mapQueryResult qm' . mapQueryResult qm
101− }
102−
103−-- | Apply a 'QueryMorphism' to a 'Query'
104−mapQuery :: QueryMorphism q q' -> q -> q'
105−mapQuery = _queryMorphism_mapQuery
106−
107−-- | Map a 'QueryMorphism' to a 'QueryResult'
108−mapQueryResult :: QueryMorphism q q' -> QueryResult q' -> QueryResult q
109−mapQueryResult = _queryMorphism_mapQueryResult
110−
111−-- | This type can be used to track of the frequency of interest in a given 'Query'. See note on
112−-- 'combineSelectedCounts'
40+-- | This type keeps track of the multiplicity of elements of the view selector that are being used by the app
11341newtype SelectedCount = SelectedCount { unSelectedCount :: Int }
11442 deriving (Eq, Ord, Show, Read, Integral, Num, Bounded, Enum, Real, Ix, Bits, FiniteBits, Storable, Data)
11543
@@ -125,34 +53,24 @@ instance Group SelectedCount where
12553
12654instance Additive SelectedCount
12755
128−-- | The Semigroup\/Monoid\/Group instances for a Query containing 'SelectedCount's should use
129−-- this function which returns Nothing if the result is 0. This allows the pruning of leaves
130−-- of the 'Query' that are no longer wanted.
56+-- | The Semigroup/Monoid/Group instances for a ViewSelector should use this function which returns Nothing if the result is 0. This allows the pruning of leaves that are no longer wanted.
13157combineSelectedCounts :: SelectedCount -> SelectedCount -> Maybe SelectedCount
13258combineSelectedCounts (SelectedCount i) (SelectedCount j) = if i == negate j then Nothing else Just $ SelectedCount (i + j)
13359
134−-- | A class that allows sending of 'Query's and retrieval of 'QueryResult's. See 'queryDyn' for a commonly
135−-- used interface.
136−class (Group q, Additive q, Query q, Monad m) => MonadQuery t q m | m -> q t where
60+class (Group q, Additive q, Query q) => MonadQuery t q m | m -> q t where
13761 tellQueryIncremental :: Incremental t (AdditivePatch q) -> m ()
13862 askQueryResult :: m (Dynamic t (QueryResult q))
13963 queryIncremental :: Incremental t (AdditivePatch q) -> m (Dynamic t (QueryResult q))
14064
141−instance MonadQuery t q m => MonadQuery t q (ReaderT r m) where
65+instance (Monad m, MonadQuery t q m) => MonadQuery t q (ReaderT r m) where
14266 tellQueryIncremental = lift . tellQueryIncremental
14367 askQueryResult = lift askQueryResult
14468 queryIncremental = lift . queryIncremental
14569
146−-- | Produce and send an 'Incremental' 'Query' from a 'Dynamic' 'Query'.
14770tellQueryDyn :: (Reflex t, MonadQuery t q m) => Dynamic t q -> m ()
14871tellQueryDyn d = tellQueryIncremental $ unsafeBuildIncremental (sample (current d)) $ attachWith (\old new -> AdditivePatch $ new ~~ old) (current d) (updated d)
14972
150−-- | Retrieve 'Dynamic'ally updating 'QueryResult's for a 'Dynamic'ally updating 'Query'.
151−queryDyn :: (Reflex t, MonadQuery t q m) => Dynamic t q -> m (Dynamic t (QueryResult q))
73+queryDyn :: (Reflex t, Monad m, MonadQuery t q m) => Dynamic t q -> m (Dynamic t (QueryResult q))
15274queryDyn q = do
15375 tellQueryDyn q
15476 zipDynWith crop q <$> askQueryResult
155−
156−-- | Use a query morphism to operate on a smaller version of a query.
157−subQuery :: (Reflex t, MonadQuery t q2 m) => QueryMorphism q1 q2 -> Dynamic t q1 -> m (Dynamic t (QueryResult q1))
158−subQuery (QueryMorphism f g) x = fmap g <$> queryDyn (fmap f x)
src/Reflex/Requester/Base.hs+19−198
@@ -1,7 +1,6 @@
11-- | This module provides 'RequesterT', the standard implementation of
22-- 'Requester'.
33{-# LANGUAGE AllowAmbiguousTypes #-}
4−{-# LANGUAGE ApplicativeDo #-}
54{-# LANGUAGE CPP #-}
65{-# LANGUAGE EmptyDataDecls #-}
76{-# LANGUAGE ExistentialQuantification #-}
@@ -22,25 +21,17 @@
2221module Reflex.Requester.Base
2322 ( RequesterT (..)
2423 , runRequesterT
25− , withRequesterT
2624 , runWithReplaceRequesterTWith
2725 , traverseIntMapWithKeyWithAdjustRequesterTWith
2826 , traverseDMapWithKeyWithAdjustRequesterTWith
2927 , RequesterData
3028 , RequesterDataKey
3129 , traverseRequesterData
32− , forRequesterData
3330 , requesterDataToList
3431 , singletonRequesterData
35− , matchResponsesWithRequests
36− , matchResponseMapWithRequests
37− , multiEntry
38− , unMultiEntry
39− , requesting'
4032 ) where
4133
4234import Reflex.Class
43−import Reflex.Adjustable.Class
4435import Reflex.Dynamic
4536import Reflex.Host.Class
4637import Reflex.PerformEvent.Class
@@ -51,17 +42,13 @@ import Reflex.TriggerEvent.Class
5142import Control.Applicative (liftA2)
5243import Control.Monad.Exception
5344import Control.Monad.Identity
54−import Control.Monad.Morph
55−import Control.Monad.Primitive
5645import Control.Monad.Reader
5746import Control.Monad.Ref
5847import Control.Monad.State.Strict
5948import Data.Bits
6049import Data.Coerce
61−import Data.Constraint
62−import Data.Dependent.Map (DMap)
50+import Data.Dependent.Map (DMap, DSum (..))
6351import qualified Data.Dependent.Map as DMap
64−import Data.Dependent.Sum (DSum (..))
6552import Data.Functor.Compose
6653import Data.Functor.Misc
6754import Data.IntMap.Strict (IntMap)
@@ -71,7 +58,8 @@ import qualified Data.Map as Map
7158import Data.Monoid ((<>))
7259import Data.Proxy
7360import qualified Data.Semigroup as S
74−import Data.Some (Some(Some))
61+import Data.Some (Some)
62+import qualified Data.Some as Some
7563import Data.Type.Equality
7664import Data.Unique.Tag
7765
@@ -84,51 +72,19 @@ newtype TagMap (f :: * -> *) = TagMap (IntMap Any)
8472
8573newtype RequesterData f = RequesterData (TagMap (Entry f))
8674
87−emptyRequesterData :: RequesterData f
88−emptyRequesterData = RequesterData $ TagMap IntMap.empty
89−
9075data RequesterDataKey a where
9176 RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a
9277 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
93− RequesterDataKey_Multi2 :: GCompare k => {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
78+ RequesterDataKey_Multi2 :: {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
9479 RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
9580
9681singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f
9782singletonRequesterData rdk v = case rdk of
9883 RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v
9984 RequesterDataKey_Multi k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v
100− RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Multi2Contents
101− { _multi2Contents_values = Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
102− , _multi2Contents_dict = Dict
103− }
85+ RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
10486 RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
10587
106−mergeRequesterData :: RequesterData f -> RequesterData f -> RequesterData f
107−mergeRequesterData (RequesterData a) (RequesterData b) = RequesterData $ mergeTagMap a b
108−
109−mergeTagMap :: forall f. TagMap (Entry f) -> TagMap (Entry f) -> TagMap (Entry f)
110−mergeTagMap (TagMap m) (TagMap n) =
111− TagMap $ IntMap.unionWithKey (g' combiner) m n
112− where
113− combiner :: forall a. MyTag a -> Entry f a -> Entry f a -> Entry f a
114− combiner k (Entry a) (Entry b) = Entry $ case myKeyType k of
115− MyTagType_Single -> a
116− MyTagType_Multi -> IntMap.unionWith mergeRequesterData a b
117− MyTagType_Multi2 -> case _multi2Contents_dict a of
118− Dict -> Multi2Contents
119− { _multi2Contents_values = Map.unionWith (IntMap.unionWith mergeRequesterData) (_multi2Contents_values a) (_multi2Contents_values b)
120− , _multi2Contents_dict = Dict
121− }
122− MyTagType_Multi3 -> IntMap.unionWith (IntMap.unionWith mergeRequesterData) a b
123− g' :: (forall a. MyTag a -> Entry f a -> Entry f a -> Entry f a) -> Int -> Any -> Any -> Any
124− g' f rawKey a b =
125− let k = MyTag rawKey :: MyTag a
126− fromAny :: Any -> Entry f a
127− fromAny = unsafeCoerce
128− toAny :: Entry f a -> Any
129− toAny = unsafeCoerce
130− in toAny $ f k (fromAny a) (fromAny b)
131−
13288requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]
13389requesterDataToList (RequesterData m) = do
13490 k :=> Entry e <- tagMapToList m
@@ -138,12 +94,11 @@ requesterDataToList (RequesterData m) = do
13894 (k', e') <- IntMap.toList e
13995 k'' :=> e'' <- requesterDataToList e'
14096 return $ RequesterDataKey_Multi k k' k'' :=> e''
141− MyTagType_Multi2 -> case _multi2Contents_dict e of
142− Dict -> do
143− (k', e') <- Map.toList $ _multi2Contents_values e
144− (k'', e'') <- IntMap.toList e'
145− k''' :=> e''' <- requesterDataToList e''
146− return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''
97+ MyTagType_Multi2 -> do
98+ (k', e') <- Map.toList e
99+ (k'', e'') <- IntMap.toList e'
100+ k''' :=> e''' <- requesterDataToList e''
101+ return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''
147102 MyTagType_Multi3 -> do
148103 (k', e') <- IntMap.toList e
149104 (k'', e'') <- IntMap.toList e'
@@ -171,19 +126,9 @@ traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWith
171126 go k (Entry request) = Entry <$> case myKeyType k of
172127 MyTagType_Single -> f request
173128 MyTagType_Multi -> traverse (traverseRequesterData f) request
174− MyTagType_Multi2 -> case request of
175− Multi2Contents { _multi2Contents_values = request', _multi2Contents_dict = Dict } -> do
176− v <- traverse (traverse (traverseRequesterData f)) request'
177− pure $ Multi2Contents
178− { _multi2Contents_values = v
179− , _multi2Contents_dict = Dict
180− }
129+ MyTagType_Multi2 -> traverse (traverse (traverseRequesterData f)) request
181130 MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request
182131
183−-- | 'traverseRequesterData' with its arguments flipped
184−forRequesterData :: forall request response m. Applicative m => RequesterData request -> (forall a. request a -> m (response a)) -> m (RequesterData response)
185−forRequesterData r f = traverseRequesterData f r
186−
187132data MyTagType :: * -> * where
188133 MyTagType_Single :: MyTagType (Single a)
189134 MyTagType_Multi :: MyTagType Multi
@@ -221,14 +166,9 @@ instance MyTagTypeOffset Multi3 where
221166type family EntryContents request a where
222167 EntryContents request (Single a) = request a
223168 EntryContents request Multi = IntMap (RequesterData request)
224− EntryContents request (Multi2 k) = Multi2Contents k request
169+ EntryContents request (Multi2 k) = Map (Some k) (IntMap (RequesterData request))
225170 EntryContents request Multi3 = IntMap (IntMap (RequesterData request))
226171
227−data Multi2Contents k request = Multi2Contents
228− { _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
229− , _multi2Contents_values :: {-# UNPACK #-} !(Map (Some k) (IntMap (RequesterData request)))
230− }
231−
232172newtype Entry request x = Entry { unEntry :: EntryContents request x }
233173
234174{-# INLINE singleEntry #-}
@@ -298,10 +238,6 @@ deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)
298238deriving instance PostBuild t m => PostBuild t (RequesterT t request response m)
299239deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)
300240
301−instance PrimMonad m => PrimMonad (RequesterT t request response m) where
302− type PrimState (RequesterT t request response m) = PrimState m
303− primitive = lift . primitive
304−
305241-- TODO: Monoid and Semigroup can likely be derived once StateT has them.
306242instance (Monoid a, Monad m) => Monoid (RequesterT t request response m a) where
307243 mempty = pure mempty
@@ -315,6 +251,7 @@ instance (S.Semigroup a, Monad m) => S.Semigroup (RequesterT t request response
315251-- requests are made, and responses should be provided in the input 'Event'.
316252-- The 'Tag' keys will be used to return the responses to the same place the
317253-- requests were issued.
254+
318255runRequesterT :: (Reflex t, Monad m)
319256 => RequesterT t request response m a
320257 -> Event t (RequesterData response) --TODO: This DMap will be in reverse order, so we need to make sure the caller traverses it in reverse
@@ -324,20 +261,6 @@ runRequesterT (RequesterT a) responses = do
324261 coerceEvent responses
325262 return (result, fmapCheap (RequesterData . TagMap) $ mergeInt $ IntMap.fromDistinctAscList $ _requesterState_requests s)
326263
327−-- | Map a function over the request and response of a 'RequesterT'
328−withRequesterT
329− :: (Reflex t, MonadFix m)
330− => (forall x. req x -> req' x) -- ^ The function to map over the request
331− -> (forall x. rsp' x -> rsp x) -- ^ The function to map over the response
332− -> RequesterT t req rsp m a -- ^ The internal 'RequesterT' whose input and output will be transformed
333− -> RequesterT t req' rsp' m a -- ^ The resulting 'RequesterT'
334−withRequesterT freq frsp child = do
335− rec let rsp = fmap (runIdentity . traverseRequesterData (Identity . frsp)) rsp'
336− (a, req) <- lift $ runRequesterT child rsp
337− rsp' <- fmap (flip selectInt 0 . fanInt . fmapCheap unMultiEntry) $ requesting' $
338− fmapCheap (multiEntry . IntMap.singleton 0) $ fmap (runIdentity . traverseRequesterData (Identity . freq)) req
339− return a
340−
341264instance (Reflex t, Monad m) => Requester t (RequesterT t request response m) where
342265 type Request (RequesterT t request response m) = request
343266 type Response (RequesterT t request response m) = response
@@ -357,7 +280,7 @@ tagRequest req = do
357280 return t
358281
359282{-# INLINE responseFromTag #-}
360−responseFromTag :: forall m t request response x. Monad m => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))
283+responseFromTag :: (Monad m, Reflex t) => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))
361284responseFromTag (MyTagWrap t) = do
362285 responses :: EventSelectorInt t Any <- RequesterT ask
363286 return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t
@@ -365,9 +288,6 @@ responseFromTag (MyTagWrap t) = do
365288instance MonadTrans (RequesterT t request response) where
366289 lift = RequesterT . lift . lift
367290
368−instance MFunctor (RequesterT t request response) where
369− hoist f = RequesterT . hoist (hoist f) . unRequesterT
370−
371291instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where
372292 type Performable (RequesterT t request response m) = Performable m
373293 performEvent_ = lift . performEvent_
@@ -395,7 +315,7 @@ instance (Reflex t, Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (
395315 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental
396316 traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove
397317
398−requesting' :: (MyTagTypeOffset x, Monad m) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x))
318+requesting' :: (MyTagTypeOffset x, Monad m, Reflex t) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x))
399319requesting' = responseFromTag . castMyTagWrap <=< tagRequest
400320
401321{-# INLINABLE runWithReplaceRequesterTWith #-}
@@ -444,7 +364,7 @@ traverseIntMapWithKeyWithAdjustRequesterTWith base patchNewElements mergePatchIn
444364 pack = Entry
445365 f' :: IntMap.Key -> (Int, v) -> m (Event t (IntMap (RequesterData request)), v')
446366 f' k (n, v) = do
447− (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?
367+ (result, myRequests) <- runRequesterT (f k v) $ fmapMaybeCheap (IntMap.lookup n) $ selectInt responses k --TODO: Instead of doing fmapMaybeCheap, can we share a fanInt across all instances of a given key, or at least the ones that are adjacent in time?
448368 return (fmapCheap (IntMap.singleton n) myRequests, result)
449369 ndm' <- numberOccurrencesFrom 1 dm'
450370 (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
@@ -487,12 +407,12 @@ traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchN
487407 let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))
488408 responses = fanMap $ fmapCheap unpack response
489409 unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))
490− unpack = _multi2Contents_values . unEntry
410+ unpack = unEntry
491411 pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)
492− pack m = Entry $ Multi2Contents { _multi2Contents_values = m, _multi2Contents_dict = Dict }
412+ pack = Entry
493413 f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)
494414 f' k (Compose (n, v)) = do
495− (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some k))
415+ (result, myRequests) <- runRequesterT (f k v) $ fmapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some.This k))
496416 return $ Compose (fmapCheap (IntMap.singleton n) myRequests, result)
497417 ndm' <- numberOccurrencesFrom 1 dm'
498418 (children0, children') <- base f' (DMap.map (\v -> Compose (0, v)) dm0) $ fmap (\(n, dm) -> mapPatch (\v -> Compose (n, v)) dm) ndm'
@@ -506,102 +426,3 @@ traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchN
506426 promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
507427 requests <- holdIncremental requests0 requests'
508428 return (result0, result')
509−
510−data Decoder rawResponse response =
511− forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)
512−
513−matchResponsesWithRequests
514− :: forall t rawRequest rawResponse request response m.
515− ( MonadFix m
516− , MonadHold t m
517− , Reflex t
518− )
519− => (forall a. request a -> (rawRequest, rawResponse -> response a))
520− -- ^ Given a request (from 'Requester'), produces the wire format of the
521− -- request and a function used to process the associated response
522− -> Event t (RequesterData request)
523− -- ^ The outgoing requests
524− -> Event t (Int, rawResponse)
525− -- ^ The incoming responses, tagged by an identifying key
526− -> m ( Event t (Map Int rawRequest)
527− , Event t (RequesterData response)
528− )
529− -- ^ A map of outgoing wire-format requests and an event of responses keyed
530− -- by the 'RequesterData' key of the associated outgoing request
531−matchResponsesWithRequests f send recv = matchResponseMapWithRequests f send $ uncurry Map.singleton <$> recv
532−
533−-- | Matches incoming responses with previously-sent requests
534−-- and uses the provided request "decoder" function to process
535−-- incoming responses.
536−matchResponseMapWithRequests
537− :: forall t rawRequest rawResponse request response m.
538− ( MonadFix m
539− , MonadHold t m
540− , Reflex t
541− )
542− => (forall a. request a -> (rawRequest, rawResponse -> response a))
543− -- ^ Given a request (from 'Requester'), produces the wire format of the
544− -- request and a function used to process the associated response
545− -> Event t (RequesterData request)
546− -- ^ The outgoing requests
547− -> Event t (Map Int rawResponse)
548− -- ^ A map of incoming responses, tagged by an identifying key
549− -> m ( Event t (Map Int rawRequest)
550− , Event t (RequesterData response)
551− )
552− -- ^ A map of outgoing wire-format requests and an event of responses keyed
553− -- by the 'RequesterData' key of the associated outgoing request
554−matchResponseMapWithRequests f send recv = do
555− rec nextId <- hold 1 $ fmap (\(next, _, _) -> next) outgoing
556− waitingFor :: Incremental t (PatchMap Int (Decoder rawResponse response)) <-
557− holdIncremental mempty $ leftmost
558− [ fmap (\(_, outstanding, _) -> outstanding) outgoing
559− , snd <$> incoming
560− ]
561− let outgoing = processOutgoing nextId send
562− incoming = processIncoming waitingFor recv
563− return (fmap (\(_, _, rawReqs) -> rawReqs) outgoing, fst <$> incoming)
564− where
565− -- Tags each outgoing request with an identifying integer key
566− -- and returns the next available key, a map of response decoders
567− -- for requests for which there are outstanding responses, and the
568− -- raw requests to be sent out.
569− processOutgoing
570− :: Behavior t Int
571− -- The next available key
572− -> Event t (RequesterData request)
573− -- The outgoing request
574− -> Event t ( Int
575− , PatchMap Int (Decoder rawResponse response)
576− , Map Int rawRequest )
577− -- The new next-available-key, a map of requests expecting responses, and the tagged raw requests
578− processOutgoing nextId out = flip pushAlways out $ \dm -> do
579− oldNextId <- sample nextId
580− let (result, newNextId) = flip runState oldNextId $ forM (requesterDataToList dm) $ \(k :=> v) -> do
581− n <- get
582− put $ succ n
583− let (rawReq, rspF) = f v
584− return (n, rawReq, Decoder k rspF)
585− patchWaitingFor = PatchMap $ Map.fromList $
586− (\(n, _, dec) -> (n, Just dec)) <$> result
587− toSend = Map.fromList $ (\(n, rawReq, _) -> (n, rawReq)) <$> result
588− return (newNextId, patchWaitingFor, toSend)
589− -- Looks up the each incoming raw response in a map of response
590− -- decoders and returns the decoded response and a patch that can
591− -- be used to clear the ID of the consumed response out of the queue
592− -- of expected responses.
593− processIncoming
594− :: Incremental t (PatchMap Int (Decoder rawResponse response))
595− -- A map of outstanding expected responses
596− -> Event t (Map Int rawResponse)
597− -- A incoming response paired with its identifying key
598− -> Event t (RequesterData response, PatchMap Int v)
599− -- The decoded response and a patch that clears the outstanding responses queue
600− processIncoming waitingFor inc = flip push inc $ \rspMap -> do
601− wf <- sample $ currentIncremental waitingFor
602− let match rawRsp (Decoder k rspF) =
603− let rsp = rspF rawRsp
604− in singletonRequesterData k rsp
605− matches = Map.intersectionWith match rspMap wf
606− pure $ if Map.null matches then Nothing else Just
607− (Map.foldl' mergeRequesterData emptyRequesterData matches, PatchMap $ Nothing <$ matches)
src/Reflex/Requester/Class.hs+1
@@ -6,6 +6,7 @@
66{-# LANGUAGE CPP #-}
77{-# LANGUAGE FlexibleInstances #-}
88{-# LANGUAGE FunctionalDependencies #-}
9+{-# LANGUAGE MultiParamTypeClasses #-}
910{-# LANGUAGE RecursiveDo #-}
1011{-# LANGUAGE TypeFamilies #-}
1112{-# LANGUAGE UndecidableInstances #-}
src/Reflex/Spider.hs+2−5
@@ -1,9 +1,6 @@
11{-# LANGUAGE CPP #-}
2−-- |
3−-- Module:
4−-- Reflex.Spider
5−-- Description:
6−-- This module exports all of the user-facing functionality of the 'Spider' 'Reflex' engine
2+-- | This module exports all of the user-facing functionality of the 'Spider'
3+-- 'Reflex' engine
74module Reflex.Spider
85 ( Spider
96 , SpiderTimeline
src/Reflex/Spider/Internal.hs+469−774
@@ -9,22 +9,17 @@
99{-# LANGUAGE GADTs #-}
1010{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1111{-# LANGUAGE LambdaCase #-}
12+{-# LANGUAGE MultiParamTypeClasses #-}
13+{-# LANGUAGE MultiWayIf #-}
1214{-# LANGUAGE RankNTypes #-}
1315{-# LANGUAGE RoleAnnotations #-}
1416{-# LANGUAGE ScopedTypeVariables #-}
1517{-# LANGUAGE TypeFamilies #-}
1618{-# LANGUAGE TypeOperators #-}
1719{-# LANGUAGE UndecidableInstances #-}
18−{-# LANGUAGE PolyKinds #-}
19−{-# LANGUAGE DeriveFunctor #-}
20−{-# LANGUAGE StandaloneDeriving #-}
21−{-# LANGUAGE InstanceSigs #-}
22−{-# LANGUAGE MultiWayIf #-}
23−
2420#ifdef USE_REFLEX_OPTIMIZER
2521{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
2622#endif
27−{-# OPTIONS_GHC -Wunused-binds #-}
2823-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
2924-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
3025module Reflex.Spider.Internal (module Reflex.Spider.Internal) where
@@ -38,17 +33,12 @@ import Control.Monad hiding (forM, forM_, mapM, mapM_)
3833import Control.Monad.Exception
3934import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)
4035import Control.Monad.Primitive
41−import Control.Monad.Reader.Class
42−import Control.Monad.IO.Class
43−import Control.Monad.ReaderIO
36+import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_)
4437import Control.Monad.Ref
45−import Control.Monad.Fail (MonadFail)
46−import qualified Control.Monad.Fail as MonadFail
4738import Data.Align
4839import Data.Coerce
49−import Data.Dependent.Map (DMap)
40+import Data.Dependent.Map (DMap, DSum (..))
5041import qualified Data.Dependent.Map as DMap
51−import Data.Dependent.Sum (DSum (..))
5242import Data.FastMutableIntMap (FastMutableIntMap, PatchIntMap (..))
5343import qualified Data.FastMutableIntMap as FastMutableIntMap
5444import Data.Foldable hiding (concat, elem, sequence_)
@@ -59,73 +49,54 @@ import Data.GADT.Compare
5949import Data.IntMap.Strict (IntMap)
6050import qualified Data.IntMap.Strict as IntMap
6151import Data.IORef
62−import Data.Kind (Type)
63−import Data.Maybe hiding (mapMaybe)
64−import Data.Monoid (mempty, (<>))
52+import Data.Maybe
53+import Data.Monoid ((<>))
6554import Data.Proxy
6655import Data.These
6756import Data.Traversable
68−import Data.Type.Equality ((:~:)(Refl))
69−import Data.Witherable (Filterable, mapMaybe)
70−import GHC.Exts hiding (toList)
57+import GHC.Exts
7158import GHC.IORef (IORef (..))
7259import GHC.Stack
7360import Reflex.FastWeak
61+import Reflex.FunctorMaybe
7462import System.IO.Unsafe
7563import System.Mem.Weak
7664import Unsafe.Coerce
7765
78−#ifdef MIN_VERSION_semialign
79−#if MIN_VERSION_these(0,8,0)
80−import Data.These.Combinators (justThese)
81−#endif
82−#if MIN_VERSION_semialign(1,1,0)
83−import Data.Zip (Zip (..))
84−#endif
85−#endif
86−
8766#ifdef DEBUG_CYCLES
8867import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)
89−#endif
90−
9168import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
9269import qualified Data.List.NonEmpty as NonEmpty
70+import Data.Monoid (mempty)
9371import Data.Tree (Forest, Tree (..), drawForest)
94−import Data.List (isPrefixOf)
72+#endif
9573
96−import Data.FastWeakBag (FastWeakBag, FastWeakBagTicket)
74+import Data.FastWeakBag (FastWeakBag)
9775import qualified Data.FastWeakBag as FastWeakBag
98−
9976import Data.Reflection
100−import Data.Some (Some(Some))
77+import Data.Some (Some)
78+import qualified Data.Some as Some
10179import Data.Type.Coercion
102−import Data.Profunctor.Unsafe ((#.), (.#))
10380import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)
10481import qualified Data.WeakBag as WeakBag
10582import qualified Reflex.Class
10683import qualified Reflex.Class as R
10784import qualified Reflex.Host.Class
10885import Reflex.NotReady.Class
109−import Data.Patch
110−import qualified Data.Patch.DMapWithMove as PatchDMapWithMove
111−import Reflex.PerformEvent.Base (PerformEventT)
86+import Reflex.Patch
87+import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
11288
11389#ifdef DEBUG_TRACE_EVENTS
11490import qualified Data.ByteString.Char8 as BS8
11591import System.IO (stderr)
116−import Data.List (isPrefixOf)
11792#endif
11893
119−-- TODO stdout might not be the best channel for debug output
120−debugStrLn :: String -> IO ()
121−debugStrLn = putStrLn
122−
12394#ifdef DEBUG_TRACE_EVENTS
95+
12496withStackOneLine :: (BS8.ByteString -> a) -> a
12597withStackOneLine expr = unsafePerformIO $ do
12698 stack <- currentCallStack
127− return (expr . BS8.pack . unwords . dropInternal . reverse $ stack)
128− where dropInternal = filterStack "Reflex.Spider.Internal"
99+ return (expr (BS8.pack (unwords (reverse stack))))
129100
130101#endif
131102
@@ -136,42 +107,28 @@ debugInvalidateHeight :: Bool
136107debugInvalidate :: Bool
137108
138109#ifdef DEBUG
110+
139111#define DEBUG_NODEIDS
140112
141−#ifdef DEBUG_TRACE_PROPAGATION
142113debugPropagate = True
143−#else
144−debugPropagate = False
145−#endif
146114
147−#ifdef DEBUG_TRACE_HEIGHT
148−debugInvalidateHeight = True
149−#else
150115debugInvalidateHeight = False
151−#endif
152116
153−#ifdef DEBUG_TRACE_INVALIDATION
154117debugInvalidate = True
155−#else
156−debugInvalidate = False
157−#endif
158118
159119class HasNodeId a where
160120 getNodeId :: a -> Int
161121
162−instance HasNodeId (CacheSubscribed x a) where
163− getNodeId = _cacheSubscribed_nodeId
164−
165−instance HasNodeId (FanInt x a) where
166− getNodeId = _fanInt_nodeId
167−
168−instance HasNodeId (Hold x p) where
122+instance HasNodeId (Hold x p a) where
169123 getNodeId = holdNodeId
170124
125+instance HasNodeId (PushSubscribed x a b) where
126+ getNodeId = pushSubscribedNodeId
127+
171128instance HasNodeId (SwitchSubscribed x a) where
172129 getNodeId = switchSubscribedNodeId
173130
174−instance HasNodeId (FanSubscribed x v a) where
131+instance HasNodeId (FanSubscribed x a) where
175132 getNodeId = fanSubscribedNodeId
176133
177134instance HasNodeId (CoincidenceSubscribed x a) where
@@ -185,16 +142,41 @@ instance HasNodeId (Pull x a) where
185142
186143{-# INLINE showNodeId #-}
187144showNodeId :: HasNodeId a => a -> String
188−showNodeId = showNodeId' . getNodeId
189−
190−showNodeId' :: Int -> String
191−showNodeId' = ("#"<>) . show
192−
145+showNodeId = ("#"<>) . show . getNodeId
146+
147+showSubscriberType :: Subscriber x a -> String
148+showSubscriberType = \case
149+ SubscriberPush _ _ -> "SubscriberPush"
150+ SubscriberMerge _ _ -> "SubscriberMerge"
151+ SubscriberFan _ -> "SubscriberFan"
152+ SubscriberMergeChange _ -> "SubscriberMergeChange"
153+ SubscriberHold _ -> "SubscriberHold"
154+ SubscriberHoldIdentity _ -> "SubscriberHoldIdentity"
155+ SubscriberSwitch _ -> "SubscriberSwitch"
156+ SubscriberCoincidenceOuter _ -> "SubscriberCoincidenceOuter"
157+ SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"
158+ SubscriberHandle -> "SubscriberHandle"
159+
160+showEventType :: Event x a -> String
161+showEventType = \case
162+ EventRoot _ _ -> "EventRoot"
163+ EventNever -> "EventNever"
164+ EventPush _ -> "EventPush"
165+ EventMerge _ -> "EventMerge"
166+ EventFan _ _ -> "EventFan"
167+ EventSwitch _ -> "EventSwitch"
168+ EventCoincidence _ -> "EventCoincidence"
169+ EventHold _ -> "EventHold"
170+ EventDyn _ -> "EventDyn"
171+ EventHoldIdentity _ -> "EventHoldIdentity"
172+ EventDynIdentity _ -> "EventDynIdentity"
193173
194174#else
195175
196176debugPropagate = False
177+
197178debugInvalidateHeight = False
179+
198180debugInvalidate = False
199181
200182-- This must be inline, or error messages will cause memory leaks due to retaining the node in question
@@ -202,10 +184,6 @@ debugInvalidate = False
202184showNodeId :: a -> String
203185showNodeId _ = ""
204186
205−{-# INLINE showNodeId' #-}
206−showNodeId' :: Int -> String
207−showNodeId' _ = ""
208−
209187#endif
210188
211189#ifdef DEBUG_NODEIDS
@@ -215,6 +193,12 @@ nextNodeIdRef = unsafePerformIO $ newIORef 1
215193
216194newNodeId :: IO Int
217195newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
196+
197+{-# NOINLINE unsafeNodeId #-}
198+unsafeNodeId :: a -> Int
199+unsafeNodeId a = unsafePerformIO $ do
200+ touch a
201+ newNodeId
218202#endif
219203
220204--------------------------------------------------------------------------------
@@ -253,7 +237,7 @@ subscribeAndRead = unEvent
253237{-# INLINE [1] pushCheap #-}
254238pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
255239pushCheap !f e = Event $ \sub -> do
256− (subscription, occ) <- subscribeAndRead e $ debugSubscriber' "push" $ sub
240+ (subscription, occ) <- subscribeAndRead e $ sub
257241 { subscriberPropagate = \a -> do
258242 mb <- f a
259243 mapM_ (subscriberPropagate sub) mb
@@ -272,10 +256,10 @@ terminalSubscriber p = Subscriber
272256
273257-- | Subscribe to an Event only for the duration of one occurrence
274258{-# INLINE subscribeAndReadHead #-}
275−subscribeAndReadHead :: HasSpiderTimeline x => Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)
259+subscribeAndReadHead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)
276260subscribeAndReadHead e sub = do
277261 subscriptionRef <- liftIO $ newIORef $ error "subscribeAndReadHead: not initialized"
278− (subscription, occ) <- subscribeAndRead e $ debugSubscriber' "head" $ sub
262+ (subscription, occ) <- subscribeAndRead e $ sub
279263 { subscriberPropagate = \a -> do
280264 liftIO $ unsubscribe =<< readIORef subscriptionRef
281265 subscriberPropagate sub a
@@ -286,42 +270,24 @@ subscribeAndReadHead e sub = do
286270 return (subscription, occ)
287271
288272--TODO: Make this lazy in its input event
289−headE :: (MonadIO m, Defer (SomeMergeInit x) m, HasSpiderTimeline x) => Event x a -> m (Event x a)
273+headE :: (MonadIO m, Defer (SomeMergeInit x) m) => Event x a -> m (Event x a)
290274headE originalE = do
291275 parent <- liftIO $ newIORef $ Just originalE
292276 defer $ SomeMergeInit $ do --TODO: Rename SomeMergeInit appropriately
293277 let clearParent = liftIO $ writeIORef parent Nothing
294− (_, occ) <- subscribeAndReadHead originalE $ terminalSubscriber $ const clearParent
278+ (_, occ) <- subscribeAndReadHead originalE $ terminalSubscriber $ \_ -> clearParent
295279 when (isJust occ) clearParent
296− return $ Event $ \sub ->
280+ return $ Event $ \sub -> do
297281 liftIO (readIORef parent) >>= \case
298− Nothing -> subscribeAndReadNever
282+ Nothing -> return (EventSubscription (return ()) $ EventSubscribed zeroRef $ toAny (), Nothing)
299283 Just e -> subscribeAndReadHead e sub
300284
301285data CacheSubscribed x a
302286 = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(FastWeakBag (Subscriber x a))
303287 , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)
304288 , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))
305−#ifdef DEBUG_NODEIDS
306− , _cacheSubscribed_nodeId :: {-# UNPACK #-} !Int
307−#endif
308289 }
309290
310−nowSpiderEventM :: (HasSpiderTimeline x) => EventM x (R.Event (SpiderTimeline x) ())
311−nowSpiderEventM =
312− SpiderEvent <$> now
313−
314−now :: (MonadIO m, Defer (Some Clear) m, HasSpiderTimeline x
315− ) => m (Event x ())
316−now = do
317− nowOrNot <- liftIO $ newIORef $ Just ()
318− scheduleClear nowOrNot
319− return . Event $ \_ -> do
320− occ <- liftIO . readIORef $ nowOrNot
321− return ( EventSubscription (return ()) eventSubscribedNow
322− , occ
323− )
324−
325291-- | Construct an 'Event' whose value is guaranteed not to be recomputed
326292-- repeatedly
327293--
@@ -336,33 +302,27 @@ cacheEvent e =
336302#else
337303 Event $
338304#endif
339− unsafePerformIO $ do
340− mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))
341− <- newIORef emptyFastWeak
342− pure $ \sub -> {-# SCC "cacheEvent" #-} do
305+ let mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))
306+ !mSubscribedRef = unsafeNewIORef e emptyFastWeak
307+ in \sub -> {-# SCC "cacheEvent" #-} do
343308#ifdef DEBUG_TRACE_EVENTS
344309 unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite
345310#endif
346311 subscribedTicket <- liftIO (readIORef mSubscribedRef >>= getFastWeakTicket) >>= \case
347312 Just subscribedTicket -> return subscribedTicket
348313 Nothing -> do
349−#ifdef DEBUG_NODEIDS
350− nodeId <- liftIO newNodeId
351−#endif
352314 subscribers <- liftIO FastWeakBag.empty
353315 occRef <- liftIO $ newIORef Nothing -- This should never be read prior to being set below
354−#ifdef DEBUG_NODEIDS
355− (parentSub, occ) <- subscribeAndRead e $ debugSubscriber' ("cacheEvent" <> showNodeId' nodeId) $ Subscriber
356−#else
357316 (parentSub, occ) <- subscribeAndRead e $ Subscriber
358−#endif
359− { subscriberPropagate = \a -> do
360− liftIO $ writeIORef occRef (Just a)
361− scheduleClear occRef
362− propagateFast a subscribers
363− , subscriberInvalidateHeight = FastWeakBag.traverse_ subscribers . invalidateSubscriberHeight
364− , subscriberRecalculateHeight = FastWeakBag.traverse_ subscribers . recalculateSubscriberHeight
365− }
317+ { subscriberPropagate = \a -> do
318+ liftIO $ writeIORef occRef $ Just a
319+ scheduleClear occRef
320+ propagateFast a subscribers
321+ , subscriberInvalidateHeight = \old -> do
322+ FastWeakBag.traverse subscribers $ invalidateSubscriberHeight old
323+ , subscriberRecalculateHeight = \new -> do
324+ FastWeakBag.traverse subscribers $ recalculateSubscriberHeight new
325+ }
366326 when (isJust occ) $ do
367327 liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing
368328 scheduleClear occRef
@@ -370,45 +330,29 @@ cacheEvent e =
370330 { _cacheSubscribed_subscribers = subscribers
371331 , _cacheSubscribed_parent = parentSub
372332 , _cacheSubscribed_occurrence = occRef
373−#ifdef DEBUG_NODEIDS
374− , _cacheSubscribed_nodeId = nodeId
375−#endif
376333 }
377334 subscribedTicket <- liftIO $ mkFastWeakTicket subscribed
378335 liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket
379336 return subscribedTicket
380− liftIO $ cacheSubscription sub mSubscribedRef subscribedTicket
381−
382−cacheSubscription :: Subscriber x a -> IORef (FastWeak (CacheSubscribed x a))
383− -> FastWeakTicket (CacheSubscribed x a) -> IO (EventSubscription x, Maybe a)
384−cacheSubscription sub mSubscribedRef subscribedTicket = do
385− subscribed <- getFastWeakTicketValue subscribedTicket
386− ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed
387− occ <- readIORef $ _cacheSubscribed_occurrence subscribed
388−
389− let parentSub = _cacheSubscribed_parent subscribed
390− es = EventSubscription
391− { _eventSubscription_unsubscribe = do
392− FastWeakBag.remove ticket
393−
394− isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed
395− when isEmpty $ do
396− writeIORef mSubscribedRef emptyFastWeak
397− unsubscribe parentSub
398− touch ticket
399− touch subscribedTicket
400− , _eventSubscription_subscribed = EventSubscribed
401− { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed parentSub
402− , eventSubscribedRetained = toAny subscribedTicket
403−#ifdef DEBUG_CYCLES
404− , eventSubscribedGetParents = return [_eventSubscription_subscribed parentSub]
405− , eventSubscribedHasOwnHeightRef = False
406− , eventSubscribedWhoCreated = whoCreatedIORef mSubscribedRef
407−#endif
408− }
409− }
410− return (es, occ)
411−
337+ liftIO $ do
338+ subscribed <- getFastWeakTicketValue subscribedTicket
339+ ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed
340+ occ <- readIORef $ _cacheSubscribed_occurrence subscribed
341+ let es = EventSubscription
342+ { _eventSubscription_unsubscribe = do
343+ FastWeakBag.remove ticket
344+ isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed
345+ when isEmpty $ do
346+ writeIORef mSubscribedRef emptyFastWeak
347+ unsubscribe $ _cacheSubscribed_parent subscribed
348+ touch ticket
349+ touch subscribedTicket
350+ , _eventSubscription_subscribed = EventSubscribed
351+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed
352+ , eventSubscribedRetained = toAny subscribedTicket
353+ }
354+ }
355+ return (es, occ)
412356
413357subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)
414358subscribe e s = fst <$> subscribeAndRead e s
@@ -420,16 +364,13 @@ wrap tag getSpecificSubscribed sub = do
420364 let es = tag subd
421365 return (EventSubscription (WeakBag.remove sln >> touch sln) es, occ)
422366
423−eventRoot :: (GCompare k, HasSpiderTimeline x) => k a -> Root x k -> Event x a
367+eventRoot :: GCompare k => k a -> Root x k -> Event x a
424368eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r
425369
426−subscribeAndReadNever :: EventM x (EventSubscription x, Maybe a)
427−subscribeAndReadNever = return (EventSubscription (return ()) eventSubscribedNever, Nothing)
428−
429370eventNever :: Event x a
430−eventNever = Event $ const subscribeAndReadNever
371+eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
431372
432−eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k v -> Event x (v a)
373+eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k -> Event x a
433374eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
434375
435376eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a
@@ -438,7 +379,7 @@ eventSwitch !s = Event $ wrap eventSubscribedSwitch $ getSwitchSubscribed s
438379eventCoincidence :: HasSpiderTimeline x => Coincidence x a -> Event x a
439380eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSubscribed c
440381
441−eventHold :: Hold x p -> Event x p
382+eventHold :: HasSpiderTimeline x => Hold x p -> Event x p
442383eventHold !h = Event $ subscribeHoldEvent h
443384
444385eventDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Event x p
@@ -464,6 +405,16 @@ data Subscriber x a = Subscriber
464405 , subscriberRecalculateHeight :: !(Height -> IO ())
465406 }
466407
408+--TODO: Move this comment to WeakBag
409+-- These function are constructor functions that are marked NOINLINE so they are
410+-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away
411+-- so any weak references that are attached to the constructors will have their
412+-- finalizer run. Using the opaque constructor, does not see the
413+-- constructor application, so it behaves like an IORef and cannot be fused away.
414+--
415+-- The result is also evaluated to WHNF, since forcing a thunk invalidates
416+-- the weak pointer to it in some cases.
417+
467418newSubscriberHold :: (HasSpiderTimeline x, Patch p) => Hold x p -> IO (Subscriber x p)
468419newSubscriberHold h = return $ Subscriber
469420 { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h
@@ -471,68 +422,85 @@ newSubscriberHold h = return $ Subscriber
471422 , subscriberRecalculateHeight = \_ -> return ()
472423 }
473424
474−newSubscriberFan :: forall x k v. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k v -> IO (Subscriber x (DMap k v))
475−newSubscriberFan subscribed = debugSubscriber ("SubscriberFan " <> showNodeId subscribed) $ Subscriber
425+newSubscriberFan :: forall x k. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k -> IO (Subscriber x (DMap k Identity))
426+newSubscriberFan subscribed = return $ Subscriber
476427 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
477428 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
478− tracePropagate (Proxy :: Proxy x) $ show (DMap.size subs) <> " keys subscribed, " <> show (DMap.size a) <> " keys firing"
429+ tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
479430 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
480431 scheduleClear $ fanSubscribedOccurrence subscribed
481− let f _ (Pair v subsubs) = do
432+ let f _ (Pair (Identity v) subsubs) = do
482433 propagate v $ _fanSubscribedChildren_list subsubs
483434 return $ Constant ()
484435 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
485436 return ()
486437 , subscriberInvalidateHeight = \old -> do
438+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
487439 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
488− forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old
440+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old
441+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
489442 , subscriberRecalculateHeight = \new -> do
443+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
490444 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
491− forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new
445+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new
446+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
492447 }
493448
494449newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)
495−newSubscriberSwitch subscribed = debugSubscriber ("SubscriberCoincidenceOuter" <> showNodeId subscribed) $ Subscriber
450+newSubscriberSwitch subscribed = return $ Subscriber
496451 { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do
452+ tracePropagate (Proxy :: Proxy x) $ "SubscriberSwitch" <> showNodeId subscribed
497453 liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a
498454 scheduleClear $ switchSubscribedOccurrence subscribed
499455 propagate a $ switchSubscribedSubscribers subscribed
500456 , subscriberInvalidateHeight = \_ -> do
457+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
501458 oldHeight <- readIORef $ switchSubscribedHeight subscribed
502459 when (oldHeight /= invalidHeight) $ do
503460 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
504− WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
505− , subscriberRecalculateHeight = (`updateSwitchHeight` subscribed)
506− }
461+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
462+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
463+ , subscriberRecalculateHeight = \new -> do
464+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
465+ updateSwitchHeight new subscribed
466+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
467+ }
507468
508469newSubscriberCoincidenceOuter :: forall x b. HasSpiderTimeline x => CoincidenceSubscribed x b -> IO (Subscriber x (Event x b))
509−newSubscriberCoincidenceOuter subscribed = debugSubscriber ("SubscriberCoincidenceOuter" <> showNodeId subscribed) $ Subscriber
470+newSubscriberCoincidenceOuter subscribed = return $ Subscriber
510471 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do
472+ tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceOuter" <> showNodeId subscribed
511473 outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed
512474 tracePropagate (Proxy :: Proxy x) $ " outerHeight = " <> show outerHeight
513475 (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed
514476 tracePropagate (Proxy :: Proxy x) $ " isJust occ = " <> show (isJust occ)
515477 tracePropagate (Proxy :: Proxy x) $ " innerHeight = " <> show innerHeight
516−
517478 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd
518479 scheduleClear $ coincidenceSubscribedInnerParent subscribed
519480 case occ of
520− Nothing ->
481+ Nothing -> do
521482 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
522483 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight
523− WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight
524− WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight
484+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight
485+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight
525486 Just o -> do -- Since it's already firing, no need to adjust height
526487 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
527488 scheduleClear $ coincidenceSubscribedOccurrence subscribed
528489 propagate o $ coincidenceSubscribedSubscribers subscribed
529− , subscriberInvalidateHeight = \_ -> invalidateCoincidenceHeight subscribed
530− , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed
490+ , subscriberInvalidateHeight = \_ -> do
491+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
492+ invalidateCoincidenceHeight subscribed
493+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
494+ , subscriberRecalculateHeight = \_ -> do
495+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
496+ recalculateCoincidenceHeight subscribed
497+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
531498 }
532499
533500newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)
534−newSubscriberCoincidenceInner subscribed = debugSubscriber ("SubscriberCoincidenceInner" <> showNodeId subscribed) $ Subscriber
501+newSubscriberCoincidenceInner subscribed = return $ Subscriber
535502 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do
503+ tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceInner" <> showNodeId subscribed
536504 occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed
537505 case occ of
538506 Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event
@@ -540,8 +508,14 @@ newSubscriberCoincidenceInner subscribed = debugSubscriber ("SubscriberCoinciden
540508 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a
541509 scheduleClear $ coincidenceSubscribedOccurrence subscribed
542510 propagate a $ coincidenceSubscribedSubscribers subscribed
543− , subscriberInvalidateHeight = \_ -> invalidateCoincidenceHeight subscribed
544− , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed
511+ , subscriberInvalidateHeight = \_ -> do
512+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
513+ invalidateCoincidenceHeight subscribed
514+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
515+ , subscriberRecalculateHeight = \_ -> do
516+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
517+ recalculateCoincidenceHeight subscribed
518+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
545519 }
546520
547521invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()
@@ -551,18 +525,18 @@ recalculateSubscriberHeight :: Height -> Subscriber x a -> IO ()
551525recalculateSubscriberHeight = flip subscriberRecalculateHeight
552526
553527-- | Propagate everything at the current height
554−propagate :: forall x a. HasSpiderTimeline x => a -> WeakBag (Subscriber x a) -> EventM x ()
555−propagate a subscribers = withIncreasedDepth (Proxy::Proxy x) $
528+propagate :: a -> WeakBag (Subscriber x a) -> EventM x ()
529+propagate a subscribers = withIncreasedDepth $ do
556530 -- 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
557531 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
558− WeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a
532+ WeakBag.traverse subscribers $ \s -> subscriberPropagate s a
559533
560534-- | Propagate everything at the current height
561−propagateFast :: forall x a. HasSpiderTimeline x => a -> FastWeakBag (Subscriber x a) -> EventM x ()
562−propagateFast a subscribers = withIncreasedDepth (Proxy::Proxy x) $
535+propagateFast :: a -> FastWeakBag (Subscriber x a) -> EventM x ()
536+propagateFast a subscribers = withIncreasedDepth $ do
563537 -- 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
564538 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
565− FastWeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a
539+ FastWeakBag.traverse subscribers $ \s -> subscriberPropagate s a
566540
567541--------------------------------------------------------------------------------
568542-- EventSubscribed
@@ -571,16 +545,11 @@ propagateFast a subscribers = withIncreasedDepth (Proxy::Proxy x) $
571545toAny :: a -> Any
572546toAny = unsafeCoerce
573547
574−-- Why do we use Any here, instead of just giving eventSubscribedRetained an
575−-- existential type? Sadly, GHC does not currently know how to unbox types
576−-- with existentially quantified fields. So instead we just coerce values
577−-- to type Any on the way in. Since we never coerce them back, this is
578−-- perfectly safe.
579548data EventSubscribed x = EventSubscribed
580549 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
581550 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
582551#ifdef DEBUG_CYCLES
583− , eventSubscribedGetParents :: !(IO [EventSubscribed x]) -- For debugging loops
552+ , eventSubscribedGetParents :: !(IO [Some (EventSubscribed x)]) -- For debugging loops
584553 , eventSubscribedHasOwnHeightRef :: !Bool
585554 , eventSubscribedWhoCreated :: !(IO [String])
586555#endif
@@ -607,23 +576,13 @@ eventSubscribedNever = EventSubscribed
607576 , eventSubscribedWhoCreated = return ["never"]
608577#endif
609578 }
610−eventSubscribedNow :: EventSubscribed x
611−eventSubscribedNow = EventSubscribed
612− { eventSubscribedHeightRef = zeroRef
613− , eventSubscribedRetained = toAny ()
614−#ifdef DEBUG_CYCLES
615− , eventSubscribedGetParents = return []
616− , eventSubscribedHasOwnHeightRef = False
617− , eventSubscribedWhoCreated = return ["now"]
618−#endif
619− }
620579
621−eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x
580+eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x
622581eventSubscribedFan !subscribed = EventSubscribed
623582 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
624583 , eventSubscribedRetained = toAny subscribed
625584#ifdef DEBUG_CYCLES
626− , eventSubscribedGetParents = return [_eventSubscription_subscribed $ fanSubscribedParent subscribed]
585+ , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
627586 , eventSubscribedHasOwnHeightRef = False
628587 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
629588#endif
@@ -636,7 +595,7 @@ eventSubscribedSwitch !subscribed = EventSubscribed
636595#ifdef DEBUG_CYCLES
637596 , eventSubscribedGetParents = do
638597 s <- readIORef $ switchSubscribedCurrentParent subscribed
639− return [_eventSubscription_subscribed s]
598+ return [Some.This $ _eventSubscription_subscribed s]
640599 , eventSubscribedHasOwnHeightRef = True
641600 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
642601#endif
@@ -649,8 +608,8 @@ eventSubscribedCoincidence !subscribed = EventSubscribed
649608#ifdef DEBUG_CYCLES
650609 , eventSubscribedGetParents = do
651610 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
652− let outerParent = _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
653− innerParents = maybeToList $ innerSubscription
611+ let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
612+ innerParents = maybeToList $ fmap Some.This innerSubscription
654613 return $ outerParent : innerParents
655614 , eventSubscribedHasOwnHeightRef = True
656615 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
@@ -664,20 +623,20 @@ getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es
664623whoCreatedEventSubscribed :: EventSubscribed x -> IO [String]
665624whoCreatedEventSubscribed = eventSubscribedWhoCreated
666625
667−walkInvalidHeightParents :: EventSubscribed x -> IO [EventSubscribed x]
626+walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)]
668627walkInvalidHeightParents s0 = do
669− subscribers <- flip execStateT mempty $ ($ s0) $ fix $ \loop s -> do
628+ subscribers <- flip execStateT mempty $ ($ Some.This s0) $ fix $ \loop (Some.This s) -> do
670629 h <- liftIO $ readIORef $ eventSubscribedHeightRef s
671630 when (h == invalidHeight) $ do
672631 when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed
673− modify (s :)
632+ modify (Some.This s :)
674633 mapM_ loop =<< liftIO (eventSubscribedGetParents s)
675− forM_ subscribers $ \s -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
634+ forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
676635 return subscribers
677636#endif
678637
679638{-# INLINE subscribeHoldEvent #-}
680−subscribeHoldEvent :: Hold x p -> Subscriber x p -> EventM x (EventSubscription x, Maybe p)
639+subscribeHoldEvent :: HasSpiderTimeline x => Hold x p -> Subscriber x p -> EventM x (EventSubscription x, Maybe p)
681640subscribeHoldEvent = subscribeAndRead . holdEvent
682641
683642--------------------------------------------------------------------------------
@@ -700,7 +659,7 @@ behaviorPull !p = Behavior $ do
700659 val <- liftIO $ readIORef $ pullValue p
701660 case val of
702661 Just subscribed -> do
703− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedPull subscribed)) :))
662+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
704663 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))
705664 liftIO $ touch $ pullSubscribedOwnInvalidator subscribed
706665 return $ pullSubscribedValue subscribed
@@ -709,7 +668,7 @@ behaviorPull !p = Behavior $ do
709668 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
710669 parentsRef <- liftIO $ newIORef []
711670 holdInits <- askBehaviorHoldInits
712− a <- liftIO $ runReaderIO (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
671+ a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
713672 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
714673 parents <- liftIO $ readIORef parentsRef
715674 let subscribed = PullSubscribed
@@ -719,7 +678,7 @@ behaviorPull !p = Behavior $ do
719678 , pullSubscribedParents = parents
720679 }
721680 liftIO $ writeIORef (pullValue p) $ Just subscribed
722− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedPull subscribed)) :))
681+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
723682 return a
724683
725684behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p)
@@ -730,7 +689,7 @@ readHoldTracked :: Hold x p -> BehaviorM x (PatchTarget p)
730689readHoldTracked h = do
731690 result <- liftIO $ readIORef $ holdValue h
732691 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))
733− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedHold h)) :))
692+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))
734693 liftIO $ touch h -- Otherwise, if this gets inlined enough, the hold's parent reference may get collected
735694 return result
736695
@@ -744,46 +703,42 @@ readBehaviorUntracked b = do
744703-- Dynamic
745704--------------------------------------------------------------------------------
746705
747−type DynamicS x p = Dynamic x (PatchTarget p) p
748−
749−data Dynamic x target p = Dynamic
750− { dynamicCurrent :: !(Behavior x target)
751− , dynamicUpdated :: Event x p -- This must be lazy; see the comment on holdEvent --TODO: Would this let us eliminate `Dyn`?
706+data Dynamic x p = Dynamic
707+ { dynamicCurrent :: !(Behavior x (PatchTarget p))
708+ , dynamicUpdated :: !(Event x p)
752709 }
753710
754−deriving instance (HasSpiderTimeline x) => Functor (Dynamic x target)
755−
756−
757−
758−
759−dynamicHold :: Hold x p -> DynamicS x p
711+dynamicHold :: HasSpiderTimeline x => Hold x p -> Dynamic x p
760712dynamicHold !h = Dynamic
761713 { dynamicCurrent = behaviorHold h
762714 , dynamicUpdated = eventHold h
763715 }
764716
765−dynamicHoldIdentity :: Hold x (Identity a) -> DynamicS x (Identity a)
717+dynamicHoldIdentity :: HasSpiderTimeline x => Hold x (Identity a) -> Dynamic x (Identity a)
766718dynamicHoldIdentity = dynamicHold
767719
768−dynamicConst :: PatchTarget p -> DynamicS x p
720+dynamicConst :: PatchTarget p -> Dynamic x p
769721dynamicConst !a = Dynamic
770722 { dynamicCurrent = behaviorConst a
771723 , dynamicUpdated = eventNever
772724 }
773725
774−dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> DynamicS x p
726+dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p
775727dynamicDyn !d = Dynamic
776728 { dynamicCurrent = behaviorDyn d
777729 , dynamicUpdated = eventDyn d
778730 }
779731
780−dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> DynamicS x (Identity a)
732+dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a)
781733dynamicDynIdentity = dynamicDyn
782734
783735--------------------------------------------------------------------------------
784736-- Combinators
785737--------------------------------------------------------------------------------
786738
739+--TODO: Figure out why certain things are not 'representational', then make them
740+--representational so we can use coerce
741+
787742--type role Hold representational
788743data Hold x p
789744 = Hold { holdValue :: !(IORef (PatchTarget p))
@@ -804,25 +759,20 @@ globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv
804759
805760-- | Stores all global data relevant to a particular Spider timeline; only one
806761-- value should exist for each type @x@
807−newtype SpiderTimelineEnv x = STE {unSTE :: SpiderTimelineEnv' x}
808−-- We implement SpiderTimelineEnv with a newtype wrapper so
809−-- we can get the coercions we want safely.
810−type role SpiderTimelineEnv nominal
811−
812−data SpiderTimelineEnv' x = SpiderTimelineEnv
762+data SpiderTimelineEnv x = SpiderTimelineEnv
813763 { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
814764 , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
815765#ifdef DEBUG
816766 , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
817767#endif
818768 }
819−type role SpiderTimelineEnv' phantom
769+type role SpiderTimelineEnv nominal
820770
821771instance Eq (SpiderTimelineEnv x) where
822772 _ == _ = True -- Since only one exists of each type
823773
824774instance GEq SpiderTimelineEnv where
825− a `geq` b = if _spiderTimeline_lock (unSTE a) == _spiderTimeline_lock (unSTE b)
775+ a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b
826776 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
827777 else Nothing
828778
@@ -832,9 +782,9 @@ data EventEnv x
832782 , eventEnvDynInits :: !(IORef [SomeDynInit x])
833783 , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])
834784 , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe
835− , eventEnvClears :: !(IORef [Some Clear]) -- Needed for Subscribe
836− , eventEnvIntClears :: !(IORef [Some IntClear])
837− , eventEnvRootClears :: !(IORef [Some RootClear])
785+ , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe
786+ , eventEnvIntClears :: !(IORef [SomeIntClear])
787+ , eventEnvRootClears :: !(IORef [SomeRootClear])
838788 , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe
839789 , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe
840790 , eventEnvDelayedMerges :: !(IORef (IntMap [EventM x ()]))
@@ -845,7 +795,7 @@ runEventM :: EventM x a -> IO a
845795runEventM = unEventM
846796
847797asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a
848−asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (unSTE (spiderTimeline :: SpiderTimelineEnv x))
798+asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
849799
850800class MonadIO m => Defer a m where
851801 getDeferralQueue :: m (IORef [a])
@@ -906,29 +856,29 @@ putCurrentHeight h = do
906856 heightRef <- asksEventEnv eventEnvCurrentHeight
907857 liftIO $ writeIORef heightRef $! h
908858
909−instance HasSpiderTimeline x => Defer (Some Clear) (EventM x) where
859+instance HasSpiderTimeline x => Defer SomeClear (EventM x) where
910860 {-# INLINE getDeferralQueue #-}
911861 getDeferralQueue = asksEventEnv eventEnvClears
912862
913863{-# INLINE scheduleClear #-}
914−scheduleClear :: Defer (Some Clear) m => IORef (Maybe a) -> m ()
915−scheduleClear r = defer $ Some $ Clear r
864+scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()
865+scheduleClear r = defer $ SomeClear r
916866
917−instance HasSpiderTimeline x => Defer (Some IntClear) (EventM x) where
867+instance HasSpiderTimeline x => Defer SomeIntClear (EventM x) where
918868 {-# INLINE getDeferralQueue #-}
919869 getDeferralQueue = asksEventEnv eventEnvIntClears
920870
921871{-# INLINE scheduleIntClear #-}
922−scheduleIntClear :: Defer (Some IntClear) m => IORef (IntMap a) -> m ()
923−scheduleIntClear r = defer $ Some $ IntClear r
872+scheduleIntClear :: Defer SomeIntClear m => IORef (IntMap a) -> m ()
873+scheduleIntClear r = defer $ SomeIntClear r
924874
925−instance HasSpiderTimeline x => Defer (Some RootClear) (EventM x) where
875+instance HasSpiderTimeline x => Defer SomeRootClear (EventM x) where
926876 {-# INLINE getDeferralQueue #-}
927877 getDeferralQueue = asksEventEnv eventEnvRootClears
928878
929879{-# INLINE scheduleRootClear #-}
930−scheduleRootClear :: Defer (Some RootClear) m => IORef (DMap k Identity) -> m ()
931−scheduleRootClear r = defer $ Some $ RootClear r
880+scheduleRootClear :: Defer SomeRootClear m => IORef (DMap k Identity) -> m ()
881+scheduleRootClear r = defer $ SomeRootClear r
932882
933883instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where
934884 {-# INLINE getDeferralQueue #-}
@@ -983,9 +933,9 @@ getHoldEventSubscription h = do
983933
984934type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
985935
936+--type role BehaviorM representational
986937-- BehaviorM can sample behaviors
987−newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderIO (BehaviorEnv x) a }
988− deriving (Functor, Applicative, MonadIO, MonadFix, MonadReader (BehaviorEnv x))
938+newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderT (BehaviorEnv x) IO a } deriving (Functor, Applicative, MonadIO, MonadFix)
989939
990940instance Monad (BehaviorM x) where
991941 {-# INLINE (>>=) #-}
@@ -994,16 +944,14 @@ instance Monad (BehaviorM x) where
994944 BehaviorM x >> BehaviorM y = BehaviorM $ x >> y
995945 {-# INLINE return #-}
996946 return x = BehaviorM $ return x
997−#if !MIN_VERSION_base(4,13,0)
998947 {-# INLINE fail #-}
999948 fail s = BehaviorM $ fail s
1000−#endif
1001949
1002950data BehaviorSubscribed x a
1003951 = forall p. BehaviorSubscribedHold (Hold x p)
1004952 | BehaviorSubscribedPull (PullSubscribed x a)
1005953
1006−newtype SomeBehaviorSubscribed x = SomeBehaviorSubscribed (Some (BehaviorSubscribed x))
954+data SomeBehaviorSubscribed x = forall a. SomeBehaviorSubscribed (BehaviorSubscribed x a)
1007955
1008956--type role PullSubscribed representational
1009957data PullSubscribed x a
@@ -1038,7 +986,7 @@ data RootSubscribed x a = forall k. GCompare k => RootSubscribed
1038986#endif
1039987 }
1040988
1041−data Root x k
989+data Root x (k :: * -> *)
1042990 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
1043991 , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))
1044992 , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))
@@ -1057,7 +1005,7 @@ data SomeMergeUpdate x = SomeMergeUpdate
10571005newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }
10581006
10591007-- EventM can do everything BehaviorM can, plus create holds
1060−newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException)
1008+newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException) -- The environment should be Nothing if we are not in a frame, and Just if we are - in which case it is a list of assignments to be done after the frame is over
10611009
10621010newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }
10631011
@@ -1082,8 +1030,7 @@ heightBagFromList :: [Height] -> HeightBag
10821030heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights
10831031
10841032heightBagAdd :: Height -> HeightBag -> HeightBag
1085−heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $
1086− IntMap.insertWithKey (\_ _ old -> succ old) h 0 c
1033+heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $ IntMap.insertWithKey (\_ _ old -> succ old) h 0 c
10871034
10881035heightBagRemove :: Height -> HeightBag -> HeightBag
10891036heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of
@@ -1092,13 +1039,6 @@ heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.loo
10921039 0 -> IntMap.delete h c
10931040 _ -> IntMap.insert h (pred old) c
10941041
1095−heightBagRemoveMaybe :: Height -> HeightBag -> Maybe HeightBag
1096−heightBagRemoveMaybe (Height h) b@(HeightBag s c) = heightBagVerify . removed <$> IntMap.lookup h c where
1097− removed old = HeightBag (pred s) $ case old of
1098− 0 -> IntMap.delete h c
1099− _ -> IntMap.insert h (pred old) c
1100−
1101−
11021042heightBagMax :: HeightBag -> Height
11031043heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of
11041044 Just ((h, _), _) -> Height h
@@ -1116,25 +1056,25 @@ heightBagVerify b@(HeightBag s c) = if
11161056heightBagVerify = id
11171057#endif
11181058
1119−data FanSubscribedChildren x k v a = FanSubscribedChildren
1120− { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x (v a)))
1121− , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k v)
1122− , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k v)))
1059+data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren
1060+ { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a))
1061+ , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k)
1062+ , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k)))
11231063 }
11241064
1125−data FanSubscribed x k v
1126− = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))
1127− , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k v)))
1128− , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k v))) -- This DMap should never be empty
1065+data FanSubscribed (x :: *) k
1066+ = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1067+ , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
1068+ , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty
11291069 , fanSubscribedParent :: !(EventSubscription x)
11301070#ifdef DEBUG_NODEIDS
11311071 , fanSubscribedNodeId :: Int
11321072#endif
11331073 }
11341074
1135−data Fan x k v
1136− = Fan { fanParent :: !(Event x (DMap k v))
1137− , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))
1075+data Fan x k
1076+ = Fan { fanParent :: !(Event x (DMap k Identity))
1077+ , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
11381078 }
11391079
11401080data SwitchSubscribed x a
@@ -1188,35 +1128,20 @@ newInvalidatorSwitch subd = return $! InvalidatorSwitch subd
11881128newInvalidatorPull :: Pull x a -> IO (Invalidator x)
11891129newInvalidatorPull p = return $! InvalidatorPull p
11901130
1191−instance HasSpiderTimeline x => Filterable (Event x) where
1192− mapMaybe f = push $ return . f
1131+instance HasSpiderTimeline x => FunctorMaybe (Event x) where
1132+ fmapMaybe f = push $ return . f
11931133
11941134instance HasSpiderTimeline x => Align (Event x) where
11951135 nil = eventNever
1196−#if MIN_VERSION_these(0, 8, 0)
1197−instance HasSpiderTimeline x => Semialign (Event x) where
1198−#endif
1199− align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $
1200− DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
1136+ align ea eb = fmapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
12011137
1202−#ifdef MIN_VERSION_semialign
1203−#if MIN_VERSION_semialign(1,1,0)
1204−instance HasSpiderTimeline x => Zip (Event x) where
1205−#endif
1206− zip x y = mapMaybe justThese $ align x y
1207−#endif
1138+newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (PatchTarget p), Event x p) (Hold x p)) }
12081139
1209−data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)
1210− | BuildDyn !(EventM x (PatchTarget p), Event x p)
1211− | HoldDyn !(Hold x p)
1212−
1213−newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }
1214−
1215−newMapDyn :: HasSpiderTimeline x => (a -> b) -> DynamicS x (Identity a) -> DynamicS x (Identity b)
1140+newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)
12161141newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
12171142
12181143--TODO: Avoid the duplication between this and R.zipDynWith
1219−zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> DynamicS x (Identity a) -> DynamicS x (Identity b) -> DynamicS x (Identity c)
1144+zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c)
12201145zipDynWith f da db =
12211146 let eab = align (dynamicUpdated da) (dynamicUpdated db)
12221147 ec = flip push eab $ \o -> do
@@ -1231,20 +1156,26 @@ zipDynWith f da db =
12311156 return $ Just $ Identity $ f a b
12321157 in dynamicDynIdentity $ unsafeBuildDynamic (f <$> readBehaviorUntracked (dynamicCurrent da) <*> readBehaviorUntracked (dynamicCurrent db)) ec
12331158
1234−buildDynamic :: (Defer (SomeDynInit x) m, Patch p) => EventM x (PatchTarget p) -> Event x p -> m (Dyn x p)
1159+buildDynamic :: (Defer (SomeDynInit x) m, Patch p) => BehaviorM x (PatchTarget p) -> Event x p -> m (Dyn x p)
12351160buildDynamic readV0 v' = do
1236− result <- liftIO $ newIORef $ BuildDyn (readV0, v')
1161+ result <- liftIO $ newIORef $ Left (readV0, v')
12371162 let !d = Dyn result
12381163 defer $ SomeDynInit d
12391164 return d
12401165
12411166unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
1242−unsafeBuildDynamic readV0 v' =
1243− Dyn $ unsafePerformIO $ newIORef $ UnsafeDyn (readV0, v')
1167+unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ Left x
1168+ where x = (readV0, v')
12441169
12451170-- ResultM can read behaviors and events
12461171type ResultM = EventM
12471172
1173+{-# NOINLINE unsafeNewIORef #-}
1174+unsafeNewIORef :: a -> b -> IORef b
1175+unsafeNewIORef a b = unsafePerformIO $ do
1176+ touch a
1177+ newIORef b
1178+
12481179instance HasSpiderTimeline x => Functor (Event x) where
12491180 fmap f = push $ return . Just . f
12501181
@@ -1257,42 +1188,33 @@ push f e = cacheEvent (pushCheap f e)
12571188
12581189{-# INLINABLE pull #-}
12591190pull :: BehaviorM x a -> Behavior x a
1260−pull a = unsafePerformIO $ do
1261− ref <- newIORef Nothing
1191+pull a = behaviorPull $ Pull
1192+ { pullCompute = a
1193+ , pullValue = unsafeNewIORef a Nothing
12621194#ifdef DEBUG_NODEIDS
1263− nid <- newNodeId
1195+ , pullNodeId = unsafeNodeId a
12641196#endif
1265− pure $ behaviorPull $ Pull
1266− { pullCompute = a
1267− , pullValue = ref
1268−#ifdef DEBUG_NODEIDS
1269− , pullNodeId = nid
1270−#endif
1271− }
1197+ }
12721198
12731199{-# INLINABLE switch #-}
12741200switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a
1275−switch a = unsafePerformIO $ do
1276− ref <- newIORef Nothing
1277− pure $ eventSwitch $ Switch
1278− { switchParent = a
1279− , switchSubscribed = ref
1280− }
1201+switch a = eventSwitch $ Switch
1202+ { switchParent = a
1203+ , switchSubscribed = unsafeNewIORef a Nothing
1204+ }
12811205
12821206coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a
1283−coincidence a = unsafePerformIO $ do
1284− ref <- newIORef Nothing
1285− pure $ eventCoincidence $ Coincidence
1286− { coincidenceParent = a
1287− , coincidenceSubscribed = ref
1288− }
1207+coincidence a = eventCoincidence $ Coincidence
1208+ { coincidenceParent = a
1209+ , coincidenceSubscribed = unsafeNewIORef a Nothing
1210+ }
12891211
12901212-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
12911213run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
12921214run roots after = do
12931215 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
1294− let t = spiderTimeline :: SpiderTimelineEnv x
1295− result <- SpiderHost $ withMVar (_spiderTimeline_lock (unSTE t)) $ \_ -> unSpiderHost $ runFrame $ do
1216+ t <- SpiderHost ask
1217+ result <- SpiderHost $ lift $ withMVar (_spiderTimeline_lock t) $ \_ -> flip runReaderT t $ unSpiderHost $ runFrame $ do
12961218 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
12971219 occBefore <- liftIO $ do
12981220 occBefore <- readIORef occRef
@@ -1330,11 +1252,11 @@ scheduleMerge' initialHeight heightRef a = scheduleMerge initialHeight $ do
13301252 GT -> scheduleMerge' height heightRef a -- The height has been increased (by a coincidence event; TODO: is this the only way?)
13311253 EQ -> a
13321254
1333−newtype Clear a = Clear (IORef (Maybe a))
1255+data SomeClear = forall a. SomeClear {-# UNPACK #-} !(IORef (Maybe a))
13341256
1335−newtype IntClear a = IntClear (IORef (IntMap a))
1257+data SomeIntClear = forall a. SomeIntClear {-# UNPACK #-} !(IORef (IntMap a))
13361258
1337−newtype RootClear k = RootClear (IORef (DMap k Identity))
1259+data SomeRootClear = forall k. SomeRootClear {-# UNPACK #-} !(IORef (DMap k Identity))
13381260
13391261data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a
13401262
@@ -1346,110 +1268,55 @@ mkWeakPtrWithDebug x debugNote = do
13461268 x' <- evaluate x
13471269 mkWeakPtr x' $
13481270 if debugFinalize
1349− then Just $ debugStrLn $ "finalizing: " ++ debugNote
1271+ then Just $ putStrLn $ "finalizing: " ++ debugNote
13501272 else Nothing
13511273
13521274type WeakList a = [Weak a]
13531275
1354−type CanTrace x m = (HasSpiderTimeline x, MonadIO m)
1355−
1356−
1357−
1358−
1359−#ifdef DEBUG
1360−
1361−debugSubscriber :: forall x a. HasSpiderTimeline x => String -> Subscriber x a -> IO (Subscriber x a)
1362−debugSubscriber description = return . debugSubscriber' description
1363−
1364−debugSubscriber' :: forall x a. HasSpiderTimeline x => String -> Subscriber x a -> Subscriber x a
1365−debugSubscriber' description subscribed = Subscriber
1366− {
1367− subscriberPropagate = \m -> do
1368− tracePropagate (Proxy :: Proxy x) ("subscriberPropagate: " <> description)
1369− subscriberPropagate subscribed m
1370− , subscriberInvalidateHeight = \old -> do
1371− traceInvalidateHeight $ "invalidateSubscriberHeight: " <> description <> ", old = " <> show (unHeight old)
1372− subscriberInvalidateHeight subscribed old
1373− traceInvalidateHeight $ "invalidateSubscriberHeight: " <> description <> ", done"
1374− , subscriberRecalculateHeight = \new -> do
1375− traceInvalidateHeight $ "subscriberRecalculateHeight: " <> description <> ", new = " <> show (unHeight new)
1376− subscriberRecalculateHeight subscribed new
1377− traceInvalidateHeight $ "subscriberRecalculateHeight: " <> description <> ", done"
1378− }
1379−
1380−
13811276{-# INLINE withIncreasedDepth #-}
1382−withIncreasedDepth :: forall proxy x m a. CanTrace x m => proxy x -> m a -> m a
1383−withIncreasedDepth _ a = do
1384− liftIO $ modifyIORef' (_spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)) succ
1277+#ifdef DEBUG
1278+withIncreasedDepth :: CanTrace x m => m a -> m a
1279+withIncreasedDepth a = do
1280+ spiderTimeline <- askSpiderTimelineEnv
1281+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ
13851282 result <- a
1386− liftIO $ modifyIORef' (_spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)) pred
1283+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred
13871284 return result
1388−
1389−{-# INLINE tracePropagate #-}
1390−tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1391−tracePropagate p = when debugPropagate . trace p
1392−
1393−{-# INLINE traceInvalidate #-}
1394−traceInvalidate :: String -> IO ()
1395−traceInvalidate = when debugInvalidate . liftIO . debugStrLn
1396−
1397−{-# INLINE traceInvalidateHeight #-}
1398−traceInvalidateHeight :: String -> IO ()
1399−traceInvalidateHeight = when debugInvalidateHeight . liftIO . debugStrLn
1400−
1401−{-# INLINE trace #-}
1402−trace :: (CanTrace x m) => proxy x -> String -> m ()
1403−trace p message = traceM p $ return message
1404−
1405−{-# INLINE traceM #-}
1406−traceM :: forall x proxy m. (CanTrace x m) => proxy x -> m String -> m ()
1407−traceM _ getMessage = do
1408− message <- getMessage
1409− d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)
1410− liftIO $ debugStrLn $ replicate d ' ' <> message
1411−
14121285#else
1286+withIncreasedDepth :: m a -> m a
1287+withIncreasedDepth = id
1288+#endif
14131289
1414−{-# INLINE withIncreasedDepth #-}
1415−withIncreasedDepth :: proxy x -> m a -> m a
1416−withIncreasedDepth _ = id
1290+type CanTrace x m = (HasSpiderTimeline x, MonadIO m)
14171291
14181292{-# INLINE tracePropagate #-}
14191293tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1420−tracePropagate _ _ = return ()
1294+tracePropagate p = traceWhen p debugPropagate
14211295
14221296{-# INLINE traceInvalidate #-}
14231297traceInvalidate :: String -> IO ()
1424−traceInvalidate _ = return ()
1425−
1426−{-# INLINE traceInvalidateHeight #-}
1427−traceInvalidateHeight :: String -> IO ()
1428−traceInvalidateHeight _ = return ()
1429−
1430−{-# INLINE debugSubscriber #-}
1431−debugSubscriber :: String -> Subscriber x a -> IO (Subscriber x a)
1432−debugSubscriber _ = return
1298+traceInvalidate = when debugInvalidate . liftIO . putStrLn
14331299
1434−{-# INLINE debugSubscriber' #-}
1435−debugSubscriber' :: String -> Subscriber x a -> Subscriber x a
1436−debugSubscriber' _ = id
1437−
1438−
1439−
1440−{-# INLINE trace #-}
1441−trace :: (CanTrace x m) => proxy x -> String -> m ()
1442−trace _ _ = return ()
1443−
1444−{-# INLINE traceM #-}
1445−traceM :: (CanTrace x m) => proxy x -> m String -> m ()
1446−traceM _ _ = return ()
1300+{-# INLINE traceWhen #-}
1301+traceWhen :: (CanTrace x m) => proxy x -> Bool -> String -> m ()
1302+traceWhen p b message = traceMWhen p b $ return message
14471303
1304+{-# INLINE traceMWhen #-}
1305+traceMWhen :: (CanTrace x m) => proxy x -> Bool -> m String -> m ()
1306+traceMWhen _ b getMessage = when b $ do
1307+ message <- getMessage
1308+#ifdef DEBUG
1309+ spiderTimeline <- askSpiderTimelineEnv
1310+ d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline
1311+#else
1312+ let d = 0
14481313#endif
1314+ liftIO $ putStrLn $ replicate d ' ' <> message
14491315
14501316whoCreatedIORef :: IORef a -> IO [String]
14511317whoCreatedIORef (IORef a) = whoCreated $! a
14521318
1319+#ifdef DEBUG_CYCLES
14531320groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
14541321groupByHead = \case
14551322 [] -> []
@@ -1460,54 +1327,20 @@ groupByHead = \case
14601327 | otherwise -> (x, xs :| []) : l
14611328
14621329listsToForest :: Eq a => [[a]] -> Forest a
1463−listsToForest lists = buildForest <$> groupByHead (mapMaybe nonEmpty lists)
1464− where buildForest (a, lists') = Node a $ listsToForest $ toList lists'
1465−
1466−showStacks :: [[String]] -> String
1467−showStacks = drawForest . listsToForest . fmap (filterStack "Reflex.Spider.Internal")
1468−
1469−filterStack :: String -> [String] -> [String]
1470−#ifdef DEBUG_HIDE_INTERNALS
1471−filterStack prefix = filter (not . (prefix `isPrefixOf`))
1472−#else
1473−filterStack prefix = id
1330+listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l
14741331#endif
14751332
1476−#ifdef DEBUG_CYCLES
1477−
1478−data EventLoopException = EventLoopException [[String]]
1479−instance Exception EventLoopException
1480−
1481−instance Show EventLoopException where
1482− show (EventLoopException stacks) = "causality loop detected:\n" <> if null stacks
1483− then "no location information, compile with profiling enabled for stack tree"
1484− else showStacks stacks
1485−
1486−#else
1487−
1488−data EventLoopException = EventLoopException
1489−instance Exception EventLoopException
1490−
1491−instance Show EventLoopException where
1492− show EventLoopException = "causality loop detected: \n" <>
1493− "compile reflex with flag 'debug-cycles' and compile with profiling enabled for stack tree"
1494−
1495−#endif
1496−
1497−
14981333{-# INLINE propagateSubscriberHold #-}
14991334propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()
15001335propagateSubscriberHold h a = do
1501− {-# SCC "trace" #-} when debugPropagate $ traceM (Proxy :: Proxy x) $ liftIO $ do
1336+ {-# SCC "trace" #-} traceMWhen (Proxy :: Proxy x) debugPropagate $ liftIO $ do
15021337 invalidators <- liftIO $ readIORef $ holdInvalidators h
15031338 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
1504−
15051339 v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h
15061340 case {-# SCC "apply" #-} apply a v of
15071341 Nothing -> return ()
15081342 Just v' -> do
1509− {-# SCC "trace2" #-} withIncreasedDepth (Proxy :: Proxy x) $
1510− tracePropagate (Proxy :: Proxy x) ("propagateSubscriberHold: assigning Hold" <> showNodeId h)
1343+ {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate (Proxy :: Proxy x) $ "propagateSubscriberHold: assigning Hold" <> showNodeId h
15111344 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
15121345 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
15131346 defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'
@@ -1515,25 +1348,25 @@ propagateSubscriberHold h a = do
15151348data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
15161349
15171350runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a
1518−runBehaviorM a mwi holdInits = runReaderIO (unBehaviorM a) (mwi, holdInits)
1351+runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)
15191352
15201353askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
15211354askInvalidator = do
1522− (!m, _) <- ask
1355+ (!m, _) <- BehaviorM ask
15231356 case m of
15241357 Nothing -> return Nothing
15251358 Just (!wi, _) -> return $ Just wi
15261359
15271360askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
15281361askParentsRef = do
1529− (!m, _) <- ask
1362+ (!m, _) <- BehaviorM ask
15301363 case m of
15311364 Nothing -> return Nothing
15321365 Just (_, !p) -> return $ Just p
15331366
15341367askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
15351368askBehaviorHoldInits = do
1536− (_, !his) <- ask
1369+ (_, !his) <- BehaviorM ask
15371370 return his
15381371
15391372{-# INLINE getDynHold #-}
@@ -1541,27 +1374,20 @@ getDynHold :: (Defer (SomeHoldInit x) m, Patch p) => Dyn x p -> m (Hold x p)
15411374getDynHold d = do
15421375 mh <- liftIO $ readIORef $ unDyn d
15431376 case mh of
1544− HoldDyn h -> return h
1545− UnsafeDyn (readV0, v') -> do
1377+ Right h -> return h
1378+ Left (readV0, v') -> do
15461379 holdInits <- getDeferralQueue
15471380 v0 <- liftIO $ runBehaviorM readV0 Nothing holdInits
1548− hold' v0 v'
1549− BuildDyn (readV0, v') -> do
1550− v0 <- liftIO $ runEventM readV0
1551− hold' v0 v'
1552− where
1553− hold' v0 v' = do
15541381 h <- hold v0 v'
1555− liftIO $ writeIORef (unDyn d) $ HoldDyn h
1382+ liftIO $ writeIORef (unDyn d) $ Right h
15561383 return h
15571384
1558−
15591385-- Always refers to 0
15601386{-# NOINLINE zeroRef #-}
15611387zeroRef :: IORef Height
15621388zeroRef = unsafePerformIO $ newIORef zeroHeight
15631389
1564−getRootSubscribed :: forall k x a. (GCompare k, HasSpiderTimeline x) => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)
1390+getRootSubscribed :: GCompare k => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)
15651391getRootSubscribed k r sub = do
15661392 mSubscribed <- readIORef $ rootSubscribed r
15671393 let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r
@@ -1575,14 +1401,9 @@ getRootSubscribed k r sub = do
15751401 let !cached = rootSubscribed r
15761402 uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"
15771403 (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed
1578−
1579− tracePropagate (Proxy::Proxy x) $ "getRootSubscribed: calling rootInit"
1580−
1404+ when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"
15811405 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
15821406 writeIORef uninitRef $! uninit
1583−#ifdef DEBUG_NODEIDS
1584− nid <- newNodeId
1585−#endif
15861407 let !subscribed = RootSubscribed
15871408 { rootSubscribedKey = k
15881409 , rootSubscribedCachedSubscribed = cached
@@ -1591,7 +1412,7 @@ getRootSubscribed k r sub = do
15911412 , rootSubscribedUninit = uninit
15921413 , rootSubscribedWeakSelf = weakSelf
15931414#ifdef DEBUG_NODEIDS
1594− , rootSubscribedNodeId = nid
1415+ , rootSubscribedNodeId = unsafeNodeId (k, r, subs)
15951416#endif
15961417 }
15971418 -- If we die at the same moment that all our children die, they will
@@ -1627,9 +1448,6 @@ data FanInt x a = FanInt
16271448 { _fanInt_subscribers :: {-# UNPACK #-} !(FastMutableIntMap (FastWeakBag (Subscriber x a))) --TODO: Clean up the keys in here when their child weak bags get empty --TODO: Remove our own subscription when the subscribers list is completely empty
16281449 , _fanInt_subscriptionRef :: {-# UNPACK #-} !(IORef (EventSubscription x)) -- This should have a valid subscription iff subscribers is non-empty
16291450 , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a))
1630−#ifdef DEBUG_NODEIDS
1631− , _fanInt_nodeId :: {-# UNPACK #-} !Int
1632−#endif
16331451 }
16341452
16351453newFanInt :: IO (FanInt x a)
@@ -1637,39 +1455,38 @@ newFanInt = do
16371455 subscribers <- FastMutableIntMap.newEmpty --TODO: Clean up the keys in here when their child weak bags get empty --TODO: Remove our own subscription when the subscribers list is completely empty
16381456 subscriptionRef <- newIORef $ error "fanInt: no subscription"
16391457 occRef <- newIORef $ error "fanInt: no occurrence"
1640−#ifdef DEBUG_NODEIDS
1641− nodeId <- newNodeId
1642−#endif
16431458 return $ FanInt
16441459 { _fanInt_subscribers = subscribers
16451460 , _fanInt_subscriptionRef = subscriptionRef
16461461 , _fanInt_occRef = occRef
1647−#ifdef DEBUG_NODEIDS
1648− , _fanInt_nodeId = nodeId
1649−#endif
16501462 }
16511463
1464+{-# NOINLINE unsafeNewFanInt #-}
1465+unsafeNewFanInt :: b -> FanInt x a
1466+unsafeNewFanInt b = unsafePerformIO $ do
1467+ touch b
1468+ newFanInt
1469+
16521470fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a
1653−fanInt p = unsafePerformIO $ do
1654− self <- newFanInt
1655− pure $ EventSelectorInt $ \k -> Event $ \sub -> do
1471+fanInt p =
1472+ let self = unsafeNewFanInt p
1473+ in EventSelectorInt $ \k -> Event $ \sub -> do
16561474 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)
16571475 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input
1658− let desc = "fanInt" <> showNodeId self <> ", k = " <> show k
1659− (subscription, parentOcc) <- subscribeAndRead p $ debugSubscriber' desc $ Subscriber
1476+ (subscription, parentOcc) <- subscribeAndRead p $ Subscriber
16601477 { subscriberPropagate = \m -> do
16611478 liftIO $ writeIORef (_fanInt_occRef self) m
16621479 scheduleIntClear $ _fanInt_occRef self
1663− FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> --TODO: Do we need to know that no subscribers are being added as we traverse?
1664− FastWeakBag.traverse_ b $ \s ->
1480+ FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> do --TODO: Do we need to know that no subscribers are being added as we traverse?
1481+ FastWeakBag.traverse b $ \s -> do
16651482 subscriberPropagate s v
1666− , subscriberInvalidateHeight = \old ->
1667− FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->
1668− FastWeakBag.traverse_ b $ \s ->
1483+ , subscriberInvalidateHeight = \old -> do
1484+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1485+ FastWeakBag.traverse b $ \s -> do
16691486 subscriberInvalidateHeight s old
1670− , subscriberRecalculateHeight = \new ->
1671− FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->
1672− FastWeakBag.traverse_ b $ \s ->
1487+ , subscriberRecalculateHeight = \new -> do
1488+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1489+ FastWeakBag.traverse b $ \s -> do
16731490 subscriberRecalculateHeight s new
16741491 }
16751492 liftIO $ do
@@ -1683,28 +1500,13 @@ fanInt p = unsafePerformIO $ do
16831500 FastMutableIntMap.insert (_fanInt_subscribers self) k b
16841501 return b
16851502 Just b -> return b
1686− ticket <- liftIO $ FastWeakBag.insert sub b
1503+ t <- liftIO $ FastWeakBag.insert sub b
16871504 currentOcc <- readIORef (_fanInt_occRef self)
1688−
1689− subscribed <- fanIntSubscribed ticket self
1690− return (EventSubscription (FastWeakBag.remove ticket) subscribed, IntMap.lookup k currentOcc)
1691−
1692−fanIntSubscribed :: FastWeakBagTicket k -> FanInt x a -> IO (EventSubscribed x)
1693−fanIntSubscribed ticket self = do
1694− subscribedParent <- _eventSubscription_subscribed <$> readIORef (_fanInt_subscriptionRef self)
1695− return $ EventSubscribed
1696− { eventSubscribedHeightRef = eventSubscribedHeightRef subscribedParent
1697− , eventSubscribedRetained = toAny (_fanInt_subscriptionRef self, ticket)
1698−#ifdef DEBUG_CYCLES
1699− , eventSubscribedGetParents = return [subscribedParent]
1700− , eventSubscribedHasOwnHeightRef = False
1701− , eventSubscribedWhoCreated = whoCreatedIORef $ _fanInt_subscriptionRef self
1702−#endif
1703− }
1704−
1505+ (EventSubscription _ (EventSubscribed !heightRef _)) <- readIORef (_fanInt_subscriptionRef self)
1506+ return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)
17051507
17061508{-# INLINABLE getFanSubscribed #-}
1707−getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k v -> Subscriber x (v a) -> EventM x (WeakBagTicket, FanSubscribed x k v, Maybe (v a))
1509+getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket, FanSubscribed x k, Maybe a)
17081510getFanSubscribed k f sub = do
17091511 mSubscribed <- liftIO $ readIORef $ fanSubscribed f
17101512 case mSubscribed of
@@ -1722,16 +1524,13 @@ getFanSubscribed k f sub = do
17221524 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
17231525 occRef <- liftIO $ newIORef parentOcc
17241526 when (isJust parentOcc) $ scheduleClear occRef
1725−#ifdef DEBUG_NODEIDS
1726− nid <- liftIO newNodeId
1727−#endif
17281527 let subscribed = FanSubscribed
17291528 { fanSubscribedCachedSubscribed = fanSubscribed f
17301529 , fanSubscribedOccurrence = occRef
17311530 , fanSubscribedParent = subscription
17321531 , fanSubscribedSubscribers = subscribersRef
17331532#ifdef DEBUG_NODEIDS
1734− , fanSubscribedNodeId = nid
1533+ , fanSubscribedNodeId = unsafeNodeId f
17351534#endif
17361535 }
17371536 let !self = (k, subscribed)
@@ -1741,7 +1540,7 @@ getFanSubscribed k f sub = do
17411540 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
17421541 return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)
17431542
1744−cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k v) -> IO ()
1543+cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO ()
17451544cleanupFanSubscribed (k, subscribed) = do
17461545 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
17471546 let reducedSubscribers = DMap.delete k subscribers
@@ -1753,7 +1552,7 @@ cleanupFanSubscribed (k, subscribed) = do
17531552 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
17541553
17551554{-# INLINE subscribeFanSubscribed #-}
1756−subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k v -> Subscriber x (v a) -> IO WeakBagTicket
1555+subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO WeakBagTicket
17571556subscribeFanSubscribed k subscribed sub = do
17581557 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
17591558 case DMap.lookup k subscribers of
@@ -1791,9 +1590,6 @@ getSwitchSubscribed s sub = do
17911590 when (isJust parentOcc) $ scheduleClear occRef
17921591 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
17931592 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1794−#ifdef DEBUG_NODEIDS
1795− nid <- liftIO newNodeId
1796−#endif
17971593 let !subscribed = SwitchSubscribed
17981594 { switchSubscribedCachedSubscribed = switchSubscribed s
17991595 , switchSubscribedOccurrence = occRef
@@ -1806,7 +1602,7 @@ getSwitchSubscribed s sub = do
18061602 , switchSubscribedCurrentParent = subscriptionRef
18071603 , switchSubscribedWeakSelf = weakSelf
18081604#ifdef DEBUG_NODEIDS
1809− , switchSubscribedNodeId = nid
1605+ , switchSubscribedNodeId = unsafeNodeId s
18101606#endif
18111607 }
18121608 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
@@ -1851,9 +1647,6 @@ getCoincidenceSubscribed c sub = do
18511647 scheduleClear innerSubdRef
18521648 weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
18531649 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
1854−#ifdef DEBUG_NODEIDS
1855− nid <- liftIO newNodeId
1856−#endif
18571650 let subscribed = CoincidenceSubscribed
18581651 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
18591652 , coincidenceSubscribedOccurrence = occRef
@@ -1864,7 +1657,7 @@ getCoincidenceSubscribed c sub = do
18641657 , coincidenceSubscribedInnerParent = innerSubdRef
18651658 , coincidenceSubscribedWeakSelf = weakSelf
18661659#ifdef DEBUG_NODEIDS
1867− , coincidenceSubscribedNodeId = nid
1660+ , coincidenceSubscribedNodeId = unsafeNodeId c
18681661#endif
18691662 }
18701663 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
@@ -1881,72 +1674,57 @@ cleanupCoincidenceSubscribed subscribed = do
18811674subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket
18821675subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
18831676
1884−{-# INLINE mergeG #-}
1885−mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k)
1886− => (forall a. q a -> Event x (v a))
1887− -> DynamicS x (PatchDMap k q) -> Event x (DMap k v)
1888−mergeG nt d = cacheEvent (mergeCheap nt d)
1677+{-# INLINE merge #-}
1678+merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1679+merge d = cacheEvent (mergeCheap d)
18891680
18901681{-# INLINE mergeWithMove #-}
1891−mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k)
1892− => (forall a. q a -> Event x (v a))
1893− -> DynamicS x (PatchDMapWithMove k q) -> Event x (DMap k v)
1894−mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)
1682+mergeWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1683+mergeWithMove d = cacheEvent (mergeCheapWithMove d)
18951684
18961685{-# INLINE [1] mergeCheap #-}
1897−mergeCheap
1898− :: forall k x q v. (HasSpiderTimeline x, GCompare k)
1899− => (forall a. q a -> Event x (v a))
1900− -> DynamicS x (PatchDMap k q)
1901− -> Event x (DMap k v)
1902−mergeCheap nt = mergeGCheap' unMergeSubscribedParent getInitialSubscribers updateMe destroy
1686+mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1687+mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy
19031688 where
1904− updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)
1689+ updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)
19051690 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
19061691 let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do
19071692 (mOldSubd, newPs) <- case me of
19081693 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
19091694 Just e -> do
19101695 let s = subscriber $ return k
1911− subscription@(EventSubscription _ subd) <- subscribe (nt e) s
1696+ subscription@(EventSubscription _ subd) <- subscribe e s
19121697 newParentHeight <- liftIO $ getEventSubscribedHeight subd
19131698 let newParent = MergeSubscribedParent subscription
19141699 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
19151700 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
19161701 forM_ mOldSubd $ \oldSubd -> do
1917− oldHeight <- liftIO $ getEventSubscribedHeight $
1918− _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd
1919−
1702+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd
19201703 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
19211704 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
19221705 foldM f ([], oldParents) $ DMap.toList p
1923−
1924− getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParent x)
1706+ getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParent x)
19251707 getInitialSubscribers initialParents subscriber = do
19261708 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
19271709 let s = subscriber $ return k
1928− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s
1710+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
19291711 height <- liftIO $ getEventSubscribedHeight parentSubd
1930− return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParent subscription)
1712+ return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription)
19311713 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
19321714 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
19331715 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
19341716 )
1935−
19361717 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)
19371718 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub
19381719
19391720{-# INLINE [1] mergeCheapWithMove #-}
1940−mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)
1941− => (forall a. q a -> Event x (v a))
1942− -> DynamicS x (PatchDMapWithMove k q)
1943− -> Event x (DMap k v)
1944−mergeCheapWithMove nt = mergeGCheap' _mergeSubscribedParentWithMove_subscription getInitialSubscribers updateMe destroy
1721+mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1722+mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
19451723 where
1946− updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)
1724+ updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)
19471725 updateMe subscriber heightBagRef oldParents p = do
19481726 -- Prepare new parents for insertion
1949− let subscribeParent :: forall a. k a -> Event x (v a) -> EventM x (MergeSubscribedParentWithMove x k a)
1727+ let subscribeParent :: forall a. k a -> Event x a -> EventM x (MergeSubscribedParentWithMove x k a)
19501728 subscribeParent k e = do
19511729 keyRef <- liftIO $ newIORef k
19521730 let s = subscriber $ liftIO $ readIORef keyRef
@@ -1955,82 +1733,73 @@ mergeCheapWithMove nt = mergeGCheap' _mergeSubscribedParentWithMove_subscription
19551733 newParentHeight <- getEventSubscribedHeight subd
19561734 modifyIORef' heightBagRef $ heightBagAdd newParentHeight
19571735 return $ MergeSubscribedParentWithMove subscription keyRef
1958− p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey (\k q -> subscribeParent k (nt q)) p
1736+ p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey subscribeParent p
19591737 -- Collect old parents for deletion and update the keys of moved parents
1960− let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
1738+ let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Event x) a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
19611739 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
19621740 Nothing -> do
1963− oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $
1964− _mergeSubscribedParentWithMove_subscription parent
1965−
1741+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent
19661742 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
19671743 return $ Just $ _mergeSubscribedParentWithMove_subscription parent
19681744 Just toKey -> do
19691745 liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey
19701746 return Nothing
1971− toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $
1972− DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
1973−
1747+ toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
19741748 return (toDelete, applyAlways p' oldParents)
1975− getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)
1749+ getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k)
19761750 getInitialSubscribers initialParents subscriber = do
19771751 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
19781752 keyRef <- liftIO $ newIORef k
19791753 let s = subscriber $ liftIO $ readIORef keyRef
1980− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s
1754+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
19811755 height <- liftIO $ getEventSubscribedHeight parentSubd
1982− return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
1756+ return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
19831757 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
19841758 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
19851759 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
19861760 )
1987−
19881761 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)
19891762 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub
19901763
1991−type MergeUpdateFunc k v x p s
1992− = (forall a. EventM x (k a) -> Subscriber x (v a))
1764+type MergeUpdateFunc k x p s
1765+ = (forall a. EventM x (k a) -> Subscriber x a)
19931766 -> IORef HeightBag
19941767 -> DMap k s
19951768 -> p
19961769 -> EventM x ([EventSubscription x], DMap k s)
19971770
1998−type MergeGetSubscription x s = forall a. s a -> EventSubscription x
1999−
2000−type MergeInitFunc k v q x s
2001− = DMap k q
2002− -> (forall a. EventM x (k a) -> Subscriber x (v a))
2003− -> EventM x (DMap k v, [Height], DMap k s)
1771+type MergeInitFunc k x s
1772+ = DMap k (Event x)
1773+ -> (forall a. EventM x (k a) -> Subscriber x a)
1774+ -> EventM x (DMap k Identity, [Height], DMap k s)
20041775
20051776type MergeDestroyFunc k s
20061777 = DMap k s
20071778 -> IO ()
20081779
2009−data Merge x k v s = Merge
1780+data Merge x k s = Merge
20101781 { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))
20111782 , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)
20121783 , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)
2013− , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k v))
2014− , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k v))
1784+ , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k Identity))
1785+ , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k Identity))
20151786 }
20161787
2017−invalidateMergeHeight :: Merge x k v s -> IO ()
1788+invalidateMergeHeight :: Merge x k s -> IO ()
20181789invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)
20191790
20201791invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
20211792invalidateMergeHeight' heightRef sub = do
20221793 oldHeight <- readIORef heightRef
2023− -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents
2024− when (oldHeight /= invalidHeight) $ do
1794+ when (oldHeight /= invalidHeight) $ do -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents
20251795 writeIORef heightRef $! invalidHeight
20261796 subscriberInvalidateHeight sub oldHeight
20271797
2028−revalidateMergeHeight :: Merge x k v s -> IO ()
1798+
1799+revalidateMergeHeight :: Merge x k s -> IO ()
20291800revalidateMergeHeight m = do
20301801 currentHeight <- readIORef $ _merge_heightRef m
2031−
2032− -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
2033− when (currentHeight == invalidHeight) $ do
1802+ when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
20341803 heights <- readIORef $ _merge_heightBagRef m
20351804 parents <- readIORef $ _merge_parentsRef m
20361805 -- When the number of heights in the bag reaches the number of parents, we should have a valid height
@@ -2038,53 +1807,44 @@ revalidateMergeHeight m = do
20381807 LT -> return ()
20391808 EQ -> do
20401809 let height = succHeight $ heightBagMax heights
2041− traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height
1810+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
20421811 writeIORef (_merge_heightRef m) $! height
20431812 subscriberRecalculateHeight (_merge_sub m) height
20441813 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
20451814
2046−scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()
1815+scheduleMergeSelf :: HasSpiderTimeline x => Merge x k s -> Height -> EventM x ()
20471816scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
20481817 vals <- liftIO $ readIORef $ _merge_accumRef m
2049− -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us,
2050− -- it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers
2051− liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty
1818+ liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us, it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers
20521819 --TODO: Assert that m is not empty
20531820 subscriberPropagate (_merge_sub m) vals
20541821
2055−checkCycle :: HasSpiderTimeline x => EventSubscribed x -> EventM x ()
2056−checkCycle subscribed = liftIO $ do
2057− height <- readIORef (eventSubscribedHeightRef subscribed)
2058−
2059− -- currentHeight <- getCurrentHeight
2060− -- when (height <= currentHeight) $ if height /= invalidHeight
2061− -- then do
2062− -- myStack <- liftIO $ whoCreatedIORef undefined --TODO
2063− -- error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
2064− -- else liftIO $
2065− when (height == invalidHeight) $
2066−#ifdef DEBUG_CYCLES
2067− do
2068− nodesInvolvedInCycle <- walkInvalidHeightParents subscribed
2069− stacks <- forM nodesInvolvedInCycle whoCreatedEventSubscribed
2070− throwIO (EventLoopException stacks)
2071−#else
2072− throwIO EventLoopException
2073−#endif
2074−
2075−
2076−mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => EventSubscribed x -> Merge x k v s -> EventM x (k a) -> Subscriber x (v a)
2077−mergeSubscriber subscribed m getKey = Subscriber
1822+mergeSubscriber :: forall x k s a. (HasSpiderTimeline x, GCompare k) => Merge x k s -> EventM x (k a) -> Subscriber x a
1823+mergeSubscriber m getKey = Subscriber
20781824 { subscriberPropagate = \a -> do
20791825 oldM <- liftIO $ readIORef $ _merge_accumRef m
20801826 k <- getKey
2081− let newM = DMap.insertWith (error "Same key fired multiple times for Merge") k a oldM
1827+ let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM
20821828 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
20831829 liftIO $ writeIORef (_merge_accumRef m) $! newM
20841830 when (DMap.null oldM) $ do -- Only schedule the firing once
20851831 height <- liftIO $ readIORef $ _merge_heightRef m
2086− checkCycle subscribed
2087−
1832+ --TODO: assertions about height
1833+ currentHeight <- getCurrentHeight
1834+ when (height <= currentHeight) $ do
1835+ if height /= invalidHeight
1836+ then do
1837+ myStack <- liftIO $ whoCreatedIORef undefined --TODO
1838+ error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
1839+ else liftIO $ do
1840+#ifdef DEBUG_CYCLES
1841+ nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
1842+ stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es
1843+ let cycleInfo = ":\n" <> drawForest (listsToForest stacks)
1844+#else
1845+ let cycleInfo = ""
1846+#endif
1847+ error $ "Causality loop found" <> cycleInfo
20881848 scheduleMergeSelf m height
20891849 , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating
20901850 modifyIORef' (_merge_heightBagRef m) $ heightBagRemove old
@@ -2095,45 +1855,30 @@ mergeSubscriber subscribed m getKey = Subscriber
20951855 }
20961856
20971857--TODO: Be able to run as much of this as possible promptly
2098−updateMerge :: (HasSpiderTimeline x, GCompare k) => EventSubscribed x -> Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x
2099−updateMerge subscribed m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)
1858+updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k s -> MergeUpdateFunc k x p s -> p -> SomeMergeUpdate x
1859+updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)
21001860 where updateMe = do
21011861 oldParents <- liftIO $ readIORef $ _merge_parentsRef m
2102− (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber subscribed m) (_merge_heightBagRef m) oldParents p
1862+ (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber m) (_merge_heightBagRef m) oldParents p
21031863 liftIO $ writeIORef (_merge_parentsRef m) $! newParents
21041864 return subscriptionsToKill
21051865
2106−{-# INLINE mergeGCheap' #-}
2107−mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)
2108− => 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)
2109−mergeGCheap' getParent getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1866+{-# INLINE mergeCheap' #-}
1867+mergeCheap' :: forall k x p s. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k (Event x)) => MergeInitFunc k x s -> MergeUpdateFunc k x p s -> MergeDestroyFunc k s -> Dynamic x p -> Event x (DMap k Identity)
1868+mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
21101869 initialParents <- readBehaviorUntracked $ dynamicCurrent d
21111870 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
21121871 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
21131872 heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"
21141873 parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"
2115− changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
2116−
2117− let subscribed = EventSubscribed
2118− { eventSubscribedHeightRef = heightRef
2119− , eventSubscribedRetained = toAny (parentsRef, changeSubdRef)
2120−#ifdef DEBUG_CYCLES
2121− , eventSubscribedGetParents = do
2122− let getParent' (_ :=> v) = _eventSubscription_subscribed (getParent v)
2123− fmap getParent' . DMap.toList <$> readIORef parentsRef
2124− , eventSubscribedHasOwnHeightRef = False
2125− , eventSubscribedWhoCreated = whoCreatedIORef heightRef
2126−#endif
2127− }
2128−
2129− m = Merge
1874+ let m = Merge
21301875 { _merge_parentsRef = parentsRef
21311876 , _merge_heightBagRef = heightBagRef
21321877 , _merge_heightRef = heightRef
21331878 , _merge_sub = sub
21341879 , _merge_accumRef = accumRef
21351880 }
2136− (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber subscribed m
1881+ (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber m
21371882 let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights
21381883 myHeight = if invalidHeight `elem` heights
21391884 then invalidHeight
@@ -2142,57 +1887,50 @@ mergeGCheap' getParent getInitialSubscribers updateFunc destroy d = Event $ \sub
21421887 let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now
21431888 then (if DMap.null dm then Nothing else Just dm, DMap.empty)
21441889 else (Nothing, dm)
2145− unless (DMap.null accum) $ scheduleMergeSelf m myHeight
1890+ unless (DMap.null accum) $ do
1891+ scheduleMergeSelf m myHeight
21461892 liftIO $ writeIORef accumRef $! accum
21471893 liftIO $ writeIORef heightRef $! myHeight
21481894 liftIO $ writeIORef heightBagRef $! myHeightBag
1895+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
21491896 liftIO $ writeIORef parentsRef $! initialParentState
21501897 defer $ SomeMergeInit $ do
2151− let changeSubscriber = Subscriber
1898+ let s = Subscriber
21521899 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
2153− tracePropagate (Proxy :: Proxy x) "SubscriberMerge/Change"
2154− defer $ updateMerge subscribed m updateFunc a
1900+ tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change"
1901+ defer $ updateMerge m updateFunc a
21551902 , subscriberInvalidateHeight = \_ -> return ()
21561903 , subscriberRecalculateHeight = \_ -> return ()
21571904 }
2158− (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) changeSubscriber
2159− forM_ change $ \c -> defer $ updateMerge subscribed m updateFunc c
1905+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s
1906+ forM_ change $ \c -> defer $ updateMerge m updateFunc c
21601907 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
21611908 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
21621909 -- its subscription.
2163− liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)
1910+ liftIO $ writeIORef changeSubdRef (s, changeSubscription)
21641911 let unsubscribeAll = destroy =<< readIORef parentsRef
1912+ return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parentsRef, changeSubdRef)
1913+ , occ
1914+ )
21651915
2166− return (EventSubscription unsubscribeAll subscribed, occ)
2167−
2168−
2169−mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1916+mergeInt :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)
21701917mergeInt = cacheEvent . mergeIntCheap
21711918
21721919{-# INLINABLE mergeIntCheap #-}
2173−mergeIntCheap :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1920+mergeIntCheap :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)
21741921mergeIntCheap d = Event $ \sub -> do
21751922 initialParents <- readBehaviorUntracked $ dynamicCurrent d
21761923 accum <- liftIO $ FastMutableIntMap.newEmpty
21771924 heightRef <- liftIO $ newIORef zeroHeight
21781925 heightBagRef <- liftIO $ newIORef heightBagEmpty
21791926 parents <- liftIO $ FastMutableIntMap.newEmpty
2180− changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
2181− let subscribed = EventSubscribed
2182− { eventSubscribedHeightRef = heightRef
2183− , eventSubscribedRetained = toAny (parents, changeSubdRef)
2184−#ifdef DEBUG_CYCLES
2185− , eventSubscribedGetParents = fmap (_eventSubscription_subscribed . snd) <$> FastMutableIntMap.toList parents
2186− , eventSubscribedHasOwnHeightRef = False
2187− , eventSubscribedWhoCreated = whoCreatedIORef heightRef
2188−#endif
2189− }
21901927 let scheduleSelf = do
21911928 height <- liftIO $ readIORef $ heightRef
21921929 scheduleMerge' height heightRef $ do
21931930 vals <- liftIO $ FastMutableIntMap.getFrozenAndClear accum
21941931 subscriberPropagate sub vals
2195− invalidateMyHeight = invalidateMergeHeight' heightRef sub
1932+ invalidateMyHeight = do
1933+ invalidateMergeHeight' heightRef sub
21961934 recalculateMyHeight = do
21971935 currentHeight <- readIORef heightRef
21981936 when (currentHeight == invalidHeight) $ do --TODO: This will almost always be true; can we get rid of this check and just proceed to the next one always?
@@ -2202,14 +1940,12 @@ mergeIntCheap d = Event $ \sub -> do
22021940 LT -> return ()
22031941 EQ -> do
22041942 let height = succHeight $ heightBagMax heights
2205− traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height
1943+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
22061944 writeIORef heightRef $! height
22071945 subscriberRecalculateHeight sub height
22081946 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"
22091947 mySubscriber k = Subscriber
22101948 { subscriberPropagate = \a -> do
2211− checkCycle subscribed
2212−
22131949 wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum
22141950 liftIO $ FastMutableIntMap.insert accum k a
22151951 when wasEmpty scheduleSelf
@@ -2243,6 +1979,7 @@ mergeIntCheap d = Event $ \sub -> do
22431979 else liftIO $ Just <$> FastMutableIntMap.getFrozenAndClear accum
22441980 else do when (not isEmpty) scheduleSelf -- We have things accumulated, but we shouldn't have fired them yet
22451981 return Nothing
1982+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
22461983 defer $ SomeMergeInit $ do
22471984 let updateMe a = SomeMergeUpdate u invalidateMyHeight recalculateMyHeight
22481985 where
@@ -2256,39 +1993,35 @@ mergeIntCheap d = Event $ \sub -> do
22561993 oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions
22571994 liftIO $ for_ oldParents $ \oldParent -> do
22581995 oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent
2259−
2260− print ("updateMe", oldParentHeight)
22611996 modifyIORef' heightBagRef $ heightBagRemove oldParentHeight
22621997 return $ IntMap.elems oldParents
2263− let changeSubscriber = Subscriber
1998+ let s = Subscriber
22641999 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
22652000 tracePropagate (Proxy :: Proxy x) $ "SubscriberMergeInt/Change"
22662001 defer $ updateMe a
22672002 , subscriberInvalidateHeight = \_ -> return ()
22682003 , subscriberRecalculateHeight = \_ -> return ()
22692004 }
2270− (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) changeSubscriber
2005+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s
22712006 forM_ change $ \c -> defer $ updateMe c
22722007 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
22732008 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
22742009 -- its subscription.
2275− liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)
2010+ liftIO $ writeIORef changeSubdRef (s, changeSubscription)
22762011 let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents
2277−
2278−
2279− return (EventSubscription unsubscribeAll subscribed, occ)
2012+ return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parents, changeSubdRef)
2013+ , occ
2014+ )
22802015
22812016newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
2282−newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) }
22832017
2284−fanG :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k v) -> EventSelectorG x k v
2285−fanG e = unsafePerformIO $ do
2286− ref <- newIORef Nothing
2018+fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k
2019+fan e =
22872020 let f = Fan
22882021 { fanParent = e
2289− , fanSubscribed = ref
2022+ , fanSubscribed = unsafeNewIORef e Nothing
22902023 }
2291− pure $ EventSelectorG $ \k -> eventFan k f
2024+ in EventSelector $ \k -> eventFan k f
22922025
22932026runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()
22942027runHoldInits holdInitRef dynInitRef mergeInitRef = do
@@ -2341,37 +2074,37 @@ clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeI
23412074
23422075-- | Run an event action outside of a frame
23432076runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
2344−runFrame a = SpiderHost $ do
2345− let env = _spiderTimeline_eventEnv $ unSTE (spiderTimeline :: SpiderTimelineEnv x)
2077+runFrame a = SpiderHost $ ask >>= \_ -> lift $ do
2078+ let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
23462079 let go = do
23472080 result <- a
23482081 runHoldInits (eventEnvHoldInits env) (eventEnvDynInits env) (eventEnvMergeInits env) -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events
23492082 return result
23502083 result <- runEventM go
23512084 toClear <- readIORef $ eventEnvClears env
2352− forM_ toClear $ \(Some (Clear ref)) -> {-# SCC "clear" #-} writeIORef ref Nothing
2085+ forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing
23532086 toClearInt <- readIORef $ eventEnvIntClears env
2354− forM_ toClearInt $ \(Some (IntClear ref)) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty
2087+ forM_ toClearInt $ \(SomeIntClear ref) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty
23552088 toClearRoot <- readIORef $ eventEnvRootClears env
2356− forM_ toClearRoot $ \(Some (RootClear ref)) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty
2089+ forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty
23572090 toAssign <- readIORef $ eventEnvAssignments env
23582091 toReconnectRef <- newIORef []
23592092 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env
23602093 forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do
23612094 writeIORef vRef v
2362− traceInvalidate $ "Invalidating Hold"
2095+ when debugInvalidate $ putStrLn $ "Invalidating Hold"
23632096 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef
23642097 mergeUpdates <- readIORef $ eventEnvMergeUpdates env
23652098 writeIORef (eventEnvMergeUpdates env) []
2366− tracePropagate (Proxy::Proxy x) $ "Updating merges"
2099+ when debugPropagate $ putStrLn "Updating merges"
23672100 mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates
2368− tracePropagate (Proxy::Proxy x) $ "Updating merges done"
2101+ when debugPropagate $ putStrLn "Updating merges done"
23692102 toReconnect <- readIORef toReconnectRef
23702103 clearEventEnv env
23712104 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
23722105 oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed
23732106 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed
2374− traceInvalidate $ "Finalizing invalidator for Switch" <> showNodeId subscribed
2107+ when debugInvalidate $ putStrLn $ "Finalizing invalidator for Switch" <> showNodeId subscribed
23752108 finalize wi
23762109 i <- evaluate $ switchSubscribedOwnInvalidator subscribed
23772110 wi' <- mkWeakPtrWithDebug i "wi'"
@@ -2382,10 +2115,10 @@ runFrame a = SpiderHost $ do
23822115 runEventM $ runHoldInits (eventEnvHoldInits env) (eventEnvDynInits env) (eventEnvMergeInits env) --TODO: Is this actually OK? It seems like it should be, since we know that no events are firing at this point, but it still seems inelegant
23832116 --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times
23842117 sub <- newSubscriberSwitch subscribed
2385− subscription <- unSpiderHost $ runFrame $ {-# SCC "subscribeSwitch" #-} subscribe e sub --TODO: Assert that the event isn't firing --TODO: This should not loop because none of the events should be firing, but still, it is inefficient
2118+ subscription <- runReaderT (unSpiderHost (runFrame ({-# SCC "subscribeSwitch" #-} subscribe e sub))) spiderTimeline --TODO: Assert that the event isn't firing --TODO: This should not loop because none of the events should be firing, but still, it is inefficient
23862119 {-
23872120 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
2388− liftIO $ debugStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
2121+ liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
23892122 EventRoot _ -> "EventRoot"
23902123 EventNever -> "EventNever"
23912124 _ -> "something else"
@@ -2400,7 +2133,7 @@ runFrame a = SpiderHost $ do
24002133 myHeight <- readIORef $ switchSubscribedHeight subscribed
24012134 when (parentHeight /= myHeight) $ do
24022135 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
2403− WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight
2136+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight
24042137 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
24052138 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
24062139 unsubscribe subscription
@@ -2441,7 +2174,7 @@ invalidateCoincidenceHeight subscribed = do
24412174 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
24422175 when (oldHeight /= invalidHeight) $ do
24432176 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight
2444− WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
2177+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
24452178
24462179updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()
24472180updateSwitchHeight new subscribed = do
@@ -2449,7 +2182,7 @@ updateSwitchHeight new subscribed = do
24492182 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
24502183 when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion
24512184 writeIORef (switchSubscribedHeight subscribed) $! new
2452− WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new
2185+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new
24532186
24542187recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
24552188recalculateCoincidenceHeight subscribed = do
@@ -2458,7 +2191,7 @@ recalculateCoincidenceHeight subscribed = do
24582191 height <- calculateCoincidenceHeight subscribed
24592192 when (height /= invalidHeight) $ do
24602193 writeIORef (coincidenceSubscribedHeight subscribed) $! height
2461− WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
2194+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
24622195
24632196calculateSwitchHeight :: SwitchSubscribed x a -> IO Height
24642197calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)
@@ -2497,6 +2230,9 @@ invalidate toReconnectRef wis = do
24972230-- Reflex integration
24982231--------------------------------------------------------------------------------
24992232
2233+-- When we're specializing, we include this from Reflex.Class instead, because
2234+-- it needs access to these types; when we're not, we want them here, so our
2235+-- instance isn't an orphan instance.
25002236-- | Designates the default, global Spider timeline
25012237data SpiderTimeline x
25022238type role SpiderTimeline nominal
@@ -2520,8 +2256,6 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Event
25202256 {-# INLINABLE headE #-}
25212257 headE = R.slowHeadE
25222258-- headE (SpiderEvent e) = SpiderEvent <$> Reflex.Spider.Internal.headE e
2523− {-# INLINABLE now #-}
2524− now = nowSpiderEventM
25252259
25262260instance Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where
25272261 {-# INLINABLE sample #-}
@@ -2543,9 +2277,6 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide
25432277 {-# INLINABLE headE #-}
25442278 headE = R.slowHeadE
25452279-- headE (SpiderEvent e) = SpiderPushM $ SpiderEvent <$> Reflex.Spider.Internal.headE e
2546− {-# INLINABLE now #-}
2547− now = SpiderPushM nowSpiderEventM
2548−
25492280
25502281instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where
25512282 {-# INLINE return #-}
@@ -2554,13 +2285,11 @@ instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x))
25542285 x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x
25552286 {-# INLINE (>>) #-}
25562287 (>>) = (*>)
2557−#if !MIN_VERSION_base(4,13,0)
25582288 {-# INLINE fail #-}
25592289 fail _ = error "Dynamic does not support 'fail'"
2560−#endif
25612290
25622291{-# INLINABLE newJoinDyn #-}
2563−newJoinDyn :: HasSpiderTimeline x => DynamicS x (Identity (DynamicS x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)
2292+newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)
25642293newJoinDyn d =
25652294 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)
25662295 eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d
@@ -2570,13 +2299,9 @@ newJoinDyn d =
25702299 in Reflex.Spider.Internal.unsafeBuildDynamic readV0 v'
25712300
25722301instance HasSpiderTimeline x => Functor (Reflex.Class.Dynamic (SpiderTimeline x)) where
2573− fmap = mapDynamicSpider
2302+ fmap f = SpiderDynamic . newMapDyn f . unSpiderDynamic
25742303 x <$ d = R.unsafeBuildDynamic (return x) $ x <$ R.updated d
25752304
2576−mapDynamicSpider :: HasSpiderTimeline x => (a -> b) -> Reflex.Class.Dynamic (SpiderTimeline x) a -> Reflex.Class.Dynamic (SpiderTimeline x) b
2577−mapDynamicSpider f = SpiderDynamic . newMapDyn f . unSpiderDynamic
2578−{-# INLINE [1] mapDynamicSpider #-}
2579−
25802305instance HasSpiderTimeline x => Applicative (Reflex.Class.Dynamic (SpiderTimeline x)) where
25812306 pure = SpiderDynamic . dynamicConst
25822307#if MIN_VERSION_base(4,10,0)
@@ -2595,7 +2320,7 @@ holdDynSpiderEventM v0 e = fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.S
25952320holdIncrementalSpiderEventM :: (HasSpiderTimeline x, Patch p) => PatchTarget p -> Reflex.Class.Event (SpiderTimeline x) p -> EventM x (Reflex.Class.Incremental (SpiderTimeline x) p)
25962321holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e
25972322
2598−buildDynamicSpiderEventM :: HasSpiderTimeline x => SpiderPushM x a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)
2323+buildDynamicSpiderEventM :: HasSpiderTimeline x => SpiderPullM x a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)
25992324buildDynamicSpiderEventM getV0 e = fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e
26002325
26012326instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHost x) where
@@ -2609,9 +2334,6 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide
26092334 buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e
26102335 {-# INLINABLE headE #-}
26112336 headE e = runFrame . runSpiderHostFrame $ Reflex.Class.headE e
2612− {-# INLINABLE now #-}
2613− now = runFrame . runSpiderHostFrame $ Reflex.Class.now
2614−
26152337
26162338instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where
26172339 sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can
@@ -2628,8 +2350,6 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide
26282350 {-# INLINABLE headE #-}
26292351 headE = R.slowHeadE
26302352-- headE (SpiderEvent e) = SpiderHostFrame $ SpiderEvent <$> Reflex.Spider.Internal.headE e
2631− {-# INLINABLE now #-}
2632− now = SpiderHostFrame Reflex.Class.now
26332353
26342354instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where
26352355 {-# INLINABLE sample #-}
@@ -2650,8 +2370,6 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Refle
26502370 buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e
26512371 {-# INLINABLE headE #-}
26522372 headE e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.headE e
2653− {-# INLINABLE now #-}
2654− now = Reflex.Spider.Internal.ReadPhase Reflex.Class.now
26552373
26562374--------------------------------------------------------------------------------
26572375-- Deprecated items
@@ -2689,13 +2407,13 @@ instance HasSpiderTimeline x => Reflex.Host.Class.MonadReadEvent (SpiderTimeline
26892407 touch h
26902408 return result
26912409
2692−instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where
2693− newEventWithTrigger = SpiderHost . fmap SpiderEvent . newEventWithTriggerIO
2694− newFanEventWithTrigger f = SpiderHost $ do
2410+instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where
2411+ newEventWithTrigger = SpiderHost . lift . fmap SpiderEvent . newEventWithTriggerIO
2412+ newFanEventWithTrigger f = SpiderHost $ lift $ do
26952413 es <- newFanEventWithTriggerIO f
26962414 return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es
26972415
2698−instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where
2416+instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where
26992417 newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO
27002418 newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do
27012419 es <- newFanEventWithTriggerIO f
@@ -2717,7 +2435,7 @@ unsafeNewSpiderTimelineEnv = do
27172435#ifdef DEBUG
27182436 depthRef <- newIORef 0
27192437#endif
2720− return $ STE $ SpiderTimelineEnv
2438+ return $ SpiderTimelineEnv
27212439 { _spiderTimeline_lock = lock
27222440 , _spiderTimeline_eventEnv = env
27232441#ifdef DEBUG
@@ -2727,19 +2445,19 @@ unsafeNewSpiderTimelineEnv = do
27272445
27282446-- | Create a new SpiderTimelineEnv
27292447newSpiderTimeline :: IO (Some SpiderTimelineEnv)
2730−newSpiderTimeline = withSpiderTimeline (pure . Some)
2448+newSpiderTimeline = withSpiderTimeline (pure . Some.This)
27312449
2732−data LocalSpiderTimeline (x :: Type) s
2450+data LocalSpiderTimeline x s
27332451
27342452instance Reifies s (SpiderTimelineEnv x) =>
27352453 HasSpiderTimeline (LocalSpiderTimeline x s) where
2736− spiderTimeline = localSpiderTimeline Proxy $ reflect (Proxy :: Proxy s)
2454+ spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s)
27372455
27382456localSpiderTimeline
2739− :: proxy s
2457+ :: Proxy s
27402458 -> SpiderTimelineEnv x
27412459 -> SpiderTimelineEnv (LocalSpiderTimeline x s)
2742−localSpiderTimeline _ = coerce
2460+localSpiderTimeline _ = unsafeCoerce
27432461
27442462-- | Pass a new timeline to the given function.
27452463withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r
@@ -2747,18 +2465,18 @@ withSpiderTimeline k = do
27472465 env <- unsafeNewSpiderTimelineEnv
27482466 reify env $ \s -> k $ localSpiderTimeline s env
27492467
2750−newtype SpiderPullM (x :: Type) a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2468+newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
27512469
27522470type ComputeM = EventM
27532471
2754−newtype SpiderPushM (x :: Type) a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2472+newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
27552473
27562474instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
27572475 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
27582476 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
27592477 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }
2760− newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: DynamicS x (Identity a) } -- deriving (Functor, Applicative, Monad)
2761− newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: DynamicS x p }
2478+ newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad)
2479+ newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }
27622480 type PullM (SpiderTimeline x) = SpiderPullM x
27632481 type PushM (SpiderTimeline x) = SpiderPushM x
27642482 {-# INLINABLE never #-}
@@ -2771,15 +2489,10 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
27712489 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
27722490 {-# INLINABLE pull #-}
27732491 pull = SpiderBehavior . pull . coerce
2774− {-# INLINABLE fanG #-}
2775− fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))
2776− {-# INLINABLE mergeG #-}
2777− mergeG
2778− :: forall k2 (k :: k2 -> *) q (v :: k2 -> *). GCompare k
2779− => (forall a. q a -> R.Event (SpiderTimeline x) (v a))
2780− -> DMap k q
2781− -> R.Event (SpiderTimeline x) (DMap k v)
2782− mergeG nt = SpiderEvent . mergeG (unSpiderEvent #. nt) . dynamicConst
2492+ {-# INLINABLE merge #-}
2493+ merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x))
2494+ {-# INLINABLE fan #-}
2495+ fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
27832496 {-# INLINABLE switch #-}
27842497 switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior
27852498 {-# INLINABLE coincidence #-}
@@ -2787,15 +2500,15 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
27872500 {-# INLINABLE current #-}
27882501 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
27892502 {-# INLINABLE updated #-}
2790− updated = SpiderEvent #. dynamicUpdated .# fmap coerce . unSpiderDynamic
2503+ updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic
27912504 {-# INLINABLE unsafeBuildDynamic #-}
27922505 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
27932506 {-# INLINABLE unsafeBuildIncremental #-}
27942507 unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv
2795− {-# INLINABLE mergeIncrementalG #-}
2796− mergeIncrementalG nt = SpiderEvent #. mergeG (coerce #. nt) .# unSpiderIncremental
2797− {-# INLINABLE mergeIncrementalWithMoveG #-}
2798− mergeIncrementalWithMoveG nt = SpiderEvent #. mergeWithMove (coerce #. nt) .# unSpiderIncremental
2508+ {-# INLINABLE mergeIncremental #-}
2509+ mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental
2510+ {-# INLINABLE mergeIncrementalWithMove #-}
2511+ mergeIncrementalWithMove = SpiderEvent . mergeWithMove . (unsafeCoerce :: Dynamic x (PatchDMapWithMove k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMapWithMove k (Event x))) . unSpiderIncremental
27992512 {-# INLINABLE currentIncremental #-}
28002513 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
28012514 {-# INLINABLE updatedIncremental #-}
@@ -2806,10 +2519,9 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
28062519 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'
28072520 eventCoercion Coercion = Coercion
28082521 behaviorCoercion Coercion = Coercion
2809− dynamicCoercion Coercion = Coercion
2810− incrementalCoercion Coercion Coercion = Coercion
2522+ dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance
28112523 {-# INLINABLE mergeIntIncremental #-}
2812− mergeIntIncremental = SpiderEvent . mergeInt . coerce
2524+ mergeIntIncremental = SpiderEvent . mergeInt . (unsafeCoerce :: Dynamic x (PatchIntMap (R.Event (SpiderTimeline x) a)) -> Dynamic x (PatchIntMap (Event x a))) . unSpiderIncremental
28132525 {-# INLINABLE fanInt #-}
28142526 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))
28152527
@@ -2834,7 +2546,7 @@ instance MonadAtomicRef (EventM x) where
28342546 atomicModifyRef r f = liftIO $ atomicModifyRef r f
28352547
28362548-- | The monad for actions that manipulate a Spider timeline identified by @x@
2837−newtype SpiderHost (x :: Type) a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2549+newtype SpiderHost x a = SpiderHost { unSpiderHost :: ReaderT (SpiderTimelineEnv x) IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
28382550
28392551instance Monad (SpiderHost x) where
28402552 {-# INLINABLE (>>=) #-}
@@ -2843,27 +2555,20 @@ instance Monad (SpiderHost x) where
28432555 SpiderHost x >> SpiderHost y = SpiderHost $ x >> y
28442556 {-# INLINABLE return #-}
28452557 return x = SpiderHost $ return x
2846−#if !MIN_VERSION_base(4,13,0)
28472558 {-# INLINABLE fail #-}
2848− fail = MonadFail.fail
2849−#endif
2850−
2851−instance MonadFail (SpiderHost x) where
2852− {-# INLINABLE fail #-}
2853− fail s = SpiderHost $ MonadFail.fail s
2559+ fail s = SpiderHost $ fail s
28542560
28552561-- | Run an action affecting the global Spider timeline; this will be guarded by
28562562-- a mutex for that timeline
28572563runSpiderHost :: SpiderHost Global a -> IO a
2858−runSpiderHost (SpiderHost a) = a
2564+runSpiderHost (SpiderHost a) = runReaderT a globalSpiderTimelineEnv
28592565
28602566-- | Run an action affecting a given Spider timeline; this will be guarded by a
28612567-- mutex for that timeline
28622568runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
2863−runSpiderHostForTimeline (SpiderHost a) _ = a
2569+runSpiderHostForTimeline (SpiderHost a) = runReaderT a
28642570
2865−newtype SpiderHostFrame (x :: Type) a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }
2866− deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2571+newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
28672572
28682573instance Monad (SpiderHostFrame x) where
28692574 {-# INLINABLE (>>=) #-}
@@ -2872,21 +2577,19 @@ instance Monad (SpiderHostFrame x) where
28722577 SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y
28732578 {-# INLINABLE return #-}
28742579 return x = SpiderHostFrame $ return x
2875−#if !MIN_VERSION_base(4,13,0)
28762580 {-# INLINABLE fail #-}
28772581 fail s = SpiderHostFrame $ fail s
2878−#endif
28792582
28802583instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where
28812584 notReadyUntil _ = pure ()
28822585 notReady = pure ()
28832586
2884−newEventWithTriggerIO :: forall x a. HasSpiderTimeline x => (RootTrigger x a -> IO (IO ())) -> IO (Event x a)
2587+newEventWithTriggerIO :: (RootTrigger x a -> IO (IO ())) -> IO (Event x a)
28852588newEventWithTriggerIO f = do
28862589 es <- newFanEventWithTriggerIO $ \Refl -> f
28872590 return $ select es Refl
28882591
2889−newFanEventWithTriggerIO :: (HasSpiderTimeline x, GCompare k) => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)
2592+newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)
28902593newFanEventWithTriggerIO f = do
28912594 occRef <- newIORef DMap.empty
28922595 subscribedRef <- newIORef DMap.empty
@@ -2920,11 +2623,3 @@ instance MonadAtomicRef (SpiderHostFrame x) where
29202623instance PrimMonad (SpiderHostFrame x) where
29212624 type PrimState (SpiderHostFrame x) = PrimState IO
29222625 primitive = SpiderHostFrame . EventM . primitive
2923−
2924−instance NotReady (SpiderTimeline x) (SpiderHost x) where
2925− notReadyUntil _ = return ()
2926− notReady = return ()
2927−
2928−instance HasSpiderTimeline x => NotReady (SpiderTimeline x) (PerformEventT (SpiderTimeline x) (SpiderHost x)) where
2929− notReadyUntil _ = return ()
2930− notReady = return ()
src/Reflex/Time.hs+15−115
@@ -1,7 +1,5 @@
11{-# LANGUAGE CPP #-}
22{-# LANGUAGE DeriveDataTypeable #-}
3−{-# LANGUAGE DeriveGeneric #-}
4−{-# LANGUAGE DeriveTraversable #-}
53{-# LANGUAGE FlexibleContexts #-}
64{-# LANGUAGE MultiParamTypeClasses #-}
75{-# LANGUAGE RecursiveDo #-}
@@ -11,11 +9,6 @@
119#ifdef USE_TEMPLATE_HASKELL
1210{-# LANGUAGE TemplateHaskell #-}
1311#endif
14−-- |
15−-- Module:
16−-- Reflex.Time
17−-- Description:
18−-- Clocks, timers, and other time-related functions.
1912module Reflex.Time where
2013
2114import Reflex.Class
@@ -31,50 +24,46 @@ import Control.Monad
3124import Control.Monad.Fix
3225import Control.Monad.IO.Class
3326import Data.Align
34−import Data.Data (Data)
3527import Data.Fixed
36−import Data.Semigroup (Semigroup(..))
3728import Data.Sequence (Seq, (|>))
3829import qualified Data.Sequence as Seq
3930import Data.These
4031import Data.Time.Clock
4132import Data.Typeable
42−import GHC.Generics (Generic)
4333import System.Random
4434
45−-- | Metadata associated with a timer "tick"
4635data TickInfo
4736 = TickInfo { _tickInfo_lastUTC :: UTCTime
4837 -- ^ UTC time immediately after the last tick.
4938 , _tickInfo_n :: Integer
50− -- ^ Number of time periods or ticks since the start of the timer
39+ -- ^ Number of time periods since t0
5140 , _tickInfo_alreadyElapsed :: NominalDiffTime
52− -- ^ Amount of time that has elapsed in the current tick period.
41+ -- ^ Amount of time already elapsed in the current tick period.
5342 }
5443 deriving (Eq, Ord, Show, Typeable)
5544
56−-- | Fires an 'Event' once every time provided interval elapses, approximately.
57−-- The provided 'UTCTime' is used bootstrap the determination of how much time has elapsed with each tick.
58−-- This is a special case of 'tickLossyFrom' that uses the post-build event to start the tick thread.
45+-- | Special case of 'tickLossyFrom' that uses the post-build event to start the
46+-- tick thread.
5947tickLossy :: (PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m) => NominalDiffTime -> UTCTime -> m (Event t TickInfo)
6048tickLossy dt t0 = tickLossyFrom dt t0 =<< getPostBuild
6149
62−-- | Fires an 'Event' once every time provided interval elapses, approximately.
63−-- This is a special case of 'tickLossyFrom' that uses the post-build event to start the tick thread and the time of the post-build as the tick basis time.
50+-- | Special case of 'tickLossyFrom' that uses the post-build event to start the
51+-- tick thread and the time of the post-build as the tick basis time.
6452tickLossyFromPostBuildTime :: (PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m) => NominalDiffTime -> m (Event t TickInfo)
6553tickLossyFromPostBuildTime dt = do
6654 postBuild <- getPostBuild
6755 postBuildTime <- performEvent $ liftIO getCurrentTime <$ postBuild
6856 tickLossyFrom' $ (dt,) <$> postBuildTime
6957
70−-- | Fires an 'Event' approximately each time the provided interval elapses. If the system starts running behind, occurrences will be dropped rather than buffered.
71−-- Each occurrence of the resulting event will contain the index of the current interval, with 0 representing the provided initial time.
58+-- | Send events over time with the given basis time and interval
59+-- If the system starts running behind, occurrences will be dropped rather than buffered
60+-- Each occurrence of the resulting event will contain the index of the current interval, with 0 representing the basis time
7261tickLossyFrom
7362 :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m)
7463 => NominalDiffTime
7564 -- ^ The length of a tick interval
7665 -> UTCTime
77− -- ^ The basis time from which intervals count and with which the initial calculation of elapsed time will be made.
66+ -- ^ The basis time from which intervals count
7867 -> Event t a
7968 -- ^ Event that starts a tick generation thread. Usually you want this to
8069 -- be something like the result of getPostBuild that only fires once. But
@@ -82,12 +71,12 @@ tickLossyFrom
8271 -> m (Event t TickInfo)
8372tickLossyFrom dt t0 e = tickLossyFrom' $ (dt, t0) <$ e
8473
85−-- | Generalization of tickLossyFrom that takes the delay and initial time as an 'Event'.
74+-- | Generalization of tickLossyFrom that takes dt and t0 in the event.
8675tickLossyFrom'
8776 :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m)
8877 => Event t (NominalDiffTime, UTCTime)
8978 -- ^ Event that starts a tick generation thread. Usually you want this to
90− -- be something like the result of 'getPostBuild' that only fires once. But
79+ -- be something like the result of getPostBuild that only fires once. But
9180 -- there could be uses for starting multiple timer threads.
9281 -> m (Event t TickInfo)
9382tickLossyFrom' e = do
@@ -98,16 +87,12 @@ tickLossyFrom' e = do
9887 Concurrent.delay $ ceiling $ (fst pair - _tickInfo_alreadyElapsed tick) * 1000000
9988 cb (tick, pair)
10089
101−-- | Like 'tickLossy', but immediately calculates the first tick and provides a 'Dynamic' that is updated as ticks fire.
10290clockLossy :: (MonadIO m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), PostBuild t m, MonadHold t m, MonadFix m) => NominalDiffTime -> UTCTime -> m (Dynamic t TickInfo)
10391clockLossy dt t0 = do
10492 initial <- liftIO $ getCurrentTick dt t0
10593 e <- tickLossy dt t0
10694 holdDyn initial e
10795
108−-- | Generates a 'TickInfo', given the specified interval and timestamp. The 'TickInfo' will include the
109−-- current time, the number of ticks that have elapsed since the timestamp, and the amount of time that
110−-- has elapsed since the start time of this tick.
11196getCurrentTick :: NominalDiffTime -> UTCTime -> IO TickInfo
11297getCurrentTick dt t0 = do
11398 t <- getCurrentTime
@@ -122,7 +107,7 @@ delay dt e = performEventAsync $ ffor e $ \a cb -> liftIO $ void $ forkIO $ do
122107 cb a
123108
124109-- | Send events with Poisson timing with the given basis and rate
125−-- Each occurrence of the resulting event will contain the index of
110+-- Each occurence of the resulting event will contain the index of
126111-- the current interval, with 0 representing the basis time
127112poissonLossyFrom
128113 :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m)
@@ -141,7 +126,7 @@ poissonLossyFrom rnd rate = inhomogeneousPoissonFrom rnd (constant rate) rate
141126
142127
143128-- | Send events with Poisson timing with the given basis and rate
144−-- Each occurrence of the resulting event will contain the index of
129+-- Each occurence of the resulting event will contain the index of
145130-- the current interval, with 0 representing the basis time.
146131-- Automatically begin sending events when the DOM is built
147132poissonLossy
@@ -281,92 +266,6 @@ throttle t e = do
281266 delayed <- delay t outE
282267 return outE
283268
284−data ThrottleState b
285− = ThrottleState_Immediate
286− | ThrottleState_Buffered (ThrottleBuffer b)
287− deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic, Data, Typeable)
288−
289−data ThrottleBuffer b
290− = ThrottleBuffer_Empty -- Empty conflicts with lens, and hiding it would require turning
291− -- on PatternSynonyms
292− | ThrottleBuffer_Full b
293− deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic, Data, Typeable)
294−
295−instance Semigroup b => Semigroup (ThrottleBuffer b) where
296− x <> y = case x of
297− ThrottleBuffer_Empty -> y
298− ThrottleBuffer_Full b1 -> case y of
299− ThrottleBuffer_Empty -> x
300− ThrottleBuffer_Full b2 -> ThrottleBuffer_Full $ b1 <> b2
301− {-# INLINE (<>) #-}
302−
303−instance Semigroup b => Monoid (ThrottleBuffer b) where
304− mempty = ThrottleBuffer_Empty
305− {-# INLINE mempty #-}
306− mappend = (<>)
307− {-# INLINE mappend #-}
308−
309−-- | Throttle an input event, ensuring that the output event doesn't occur more often than you are ready for it. If the input event occurs too
310−-- frequently, the output event will contain semigroup-based summaries of the input firings that happened since the last output firing.
311−-- If the output event has not occurred recently, occurrences of the input event will cause the output event to fire immediately.
312−-- The first parameter is a function that receives access to the output event, and should construct an event that fires when the receiver is
313−-- ready for more input. For example, using @delay 20@ would give a simple time-based throttle.
314−--
315−-- NB: The provided lag function must *actually* delay the event.
316−throttleBatchWithLag :: (MonadFix m, MonadHold t m, PerformEvent t m, Semigroup a) => (Event t () -> m (Event t ())) -> Event t a -> m (Event t a)
317−-- Invariants:
318−-- * Immediate mode must turn off whenever output is produced.
319−-- * Output must be produced whenever immediate mode turns from on to off.
320−-- * Immediate mode can only go from off to on when the delayed event fires.
321−-- * Every input firing must go into either an immediate output firing or the
322−-- buffer, but not both.
323−-- * An existing full buffer must either stay in the buffer or go to output,
324−-- but not both.
325−throttleBatchWithLag lag e = do
326− let f state x = case x of -- (Just $ newState, out)
327− This a -> -- If only the input event fires
328− case state of
329− ThrottleState_Immediate -> -- and we're in immediate mode
330− -- Immediate mode turns off, and the buffer is empty.
331− -- We fire the output event with the input event value immediately.
332− (Just $ ThrottleState_Buffered $ ThrottleBuffer_Empty, Just a)
333− ThrottleState_Buffered b -> -- and we're not in immediate mode
334− -- Immediate mode remains off, and we accumulate the input value.
335− -- We don't fire the output event.
336− (Just $ ThrottleState_Buffered $ b <> ThrottleBuffer_Full a, Nothing)
337− That _ -> -- If only the delayed output event fires,
338− case state of
339− ThrottleState_Immediate -> -- and we're in immediate mode
340− -- Nothing happens.
341− (Nothing, Nothing)
342− ThrottleState_Buffered ThrottleBuffer_Empty -> -- and the buffer is empty:
343− -- Immediate mode turns back on, and the buffer remains empty.
344− -- We don't fire.
345− (Just ThrottleState_Immediate, Nothing)
346− ThrottleState_Buffered (ThrottleBuffer_Full b) -> -- and the buffer is full:
347− -- Immediate mode remains off, and the buffer is cleared.
348− -- We fire with the buffered value.
349− (Just $ ThrottleState_Buffered ThrottleBuffer_Empty, Just b)
350− These a _ -> -- If both the input and delayed output event fire simultaneously:
351− case state of
352− ThrottleState_Immediate -> -- and we're in immediate mode
353− -- Immediate mode turns off, and the buffer is empty.
354− -- We fire with the input event's value, as it is the most recent we have seen at this moment.
355− (Just $ ThrottleState_Buffered ThrottleBuffer_Empty, Just a)
356− ThrottleState_Buffered ThrottleBuffer_Empty -> -- and the buffer is empty:
357− -- Immediate mode stays off, and the buffer remains empty.
358− -- We fire with the input event's value.
359− (Just $ ThrottleState_Buffered ThrottleBuffer_Empty, Just a)
360− ThrottleState_Buffered (ThrottleBuffer_Full b) -> -- and the buffer is full:
361− -- Immediate mode remains off, and the buffer is cleared.
362− -- We fire with everything including the buffered value.
363− (Just $ ThrottleState_Buffered ThrottleBuffer_Empty, Just (b <> a))
364− rec (_stateDyn, outE) <- mapAccumMaybeDyn f
365− ThrottleState_Immediate -- We start in immediate mode with an empty buffer.
366− (align e delayed)
367− delayed <- lag (void outE)
368− return outE
369−
370269#ifdef USE_TEMPLATE_HASKELL
371270makeLensesWith (lensRules & simpleLenses .~ True) ''TickInfo
372271#else
@@ -382,3 +281,4 @@ tickInfo_alreadyElapsed :: Lens' TickInfo NominalDiffTime
382281tickInfo_alreadyElapsed f (TickInfo x1 x2 x3) = (\y -> TickInfo x1 x2 y) <$> f x3
383282{-# INLINE tickInfo_alreadyElapsed #-}
384283#endif
284+
src/Reflex/TriggerEvent/Base.hs−3
@@ -25,7 +25,6 @@ import Data.IORef
2525import Data.Monoid ((<>))
2626import qualified Data.Semigroup as S
2727import Reflex.Class
28−import Reflex.Adjustable.Class
2928import Reflex.Host.Class
3029import Reflex.PerformEvent.Class
3130import Reflex.PostBuild.Class
@@ -122,8 +121,6 @@ instance MonadHold t m => MonadHold t (TriggerEventT t m) where
122121 buildDynamic a0 = lift . buildDynamic a0
123122 {-# INLINABLE headE #-}
124123 headE = lift . headE
125− {-# INLINABLE now #-}
126− now = lift now
127124
128125instance Adjustable t m => Adjustable t (TriggerEventT t m) where
129126 {-# INLINABLE runWithReplace #-}
src/Reflex/TriggerEvent/Class.hs+1−6
@@ -2,6 +2,7 @@
22-- new 'Event's that can be triggered from 'IO'.
33{-# LANGUAGE FlexibleInstances #-}
44{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
56{-# LANGUAGE UndecidableInstances #-}
67module Reflex.TriggerEvent.Class
78 ( TriggerEvent (..)
@@ -12,7 +13,6 @@ import Reflex.Class
1213import Control.Monad.Reader
1314import Control.Monad.State
1415import qualified Control.Monad.State.Strict as Strict
15−import Control.Monad.Trans.Maybe (MaybeT)
1616
1717--TODO: Shouldn't have IO hard-coded
1818-- | 'TriggerEvent' represents actions that can create 'Event's that can be
@@ -48,8 +48,3 @@ instance TriggerEvent t m => TriggerEvent t (Strict.StateT s m) where
4848 newTriggerEvent = lift newTriggerEvent
4949 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
5050 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
51−
52−instance TriggerEvent t m => TriggerEvent t (MaybeT m) where
53− newTriggerEvent = lift newTriggerEvent
54− newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
55− newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
src/Reflex/Widget/Basic.hs+1−3
@@ -10,10 +10,8 @@ module Reflex.Widget.Basic where
1010
1111import Control.Monad.Fix (MonadFix)
1212import Data.Map (Map)
13−
1413import Reflex.Class
15−import Reflex.Adjustable.Class
16−import Data.Patch.MapWithMove
14+import Reflex.Patch.MapWithMove
1715
1816
1917-- | Build sortable content in such a way that re-sorting it can cause minimal
src/Reflex/Workflow.hs+1−14
@@ -1,13 +1,7 @@
11{-# LANGUAGE RecursiveDo #-}
22{-# LANGUAGE ScopedTypeVariables #-}
3−-- |
4−-- Module:
5−-- Reflex.Workflow
6−-- Description:
7−-- Provides a convenient way to describe a series of interrelated widgets that
8−-- can send data to, invoke, and replace one another. Useful for modeling user interface
9−-- "workflows."
103module Reflex.Workflow (
4+ -- * Workflows
115 Workflow (..)
126 , workflow
137 , workflowView
@@ -19,32 +13,25 @@ import Control.Arrow ((***))
1913import Control.Monad.Fix (MonadFix)
2014
2115import Reflex.Class
22−import Reflex.Adjustable.Class
2316import Reflex.Network
2417import Reflex.NotReady.Class
2518import Reflex.PostBuild.Class
2619
27−-- | A widget in a workflow
28−-- 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.
2920newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }
3021
31−-- | 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).
3222workflow :: forall t m a. (Reflex t, Adjustable t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a)
3323workflow w0 = do
3424 rec eResult <- networkHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult
3525 return $ fmap fst eResult
3626
37−-- | Similar to 'workflow', but outputs an 'Event' that fires at post-build time and whenever the current 'Workflow' is replaced by the next 'Workflow'.
3827workflowView :: 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)
3928workflowView w0 = do
4029 rec eResult <- networkView . fmap unWorkflow =<< holdDyn w0 eReplace
4130 eReplace <- fmap switch $ hold never $ fmap snd eResult
4231 return $ fmap fst eResult
4332
44−-- | Map a function over a 'Workflow', possibly changing the return type.
4533mapWorkflow :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b
4634mapWorkflow f (Workflow x) = Workflow (fmap (f *** fmap (mapWorkflow f)) x)
4735
48−-- | Map a "cheap" function over a 'Workflow'. Refer to the documentation for 'pushCheap' for more information and performance considerations.
4936mapWorkflowCheap :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b
5037mapWorkflowCheap f (Workflow x) = Workflow (fmap (f *** fmapCheap (mapWorkflowCheap f)) x)
test/Adjustable.hsdeleted−62
@@ -1,62 +0,0 @@
1−{-# LANGUAGE BangPatterns #-}
2−{-# LANGUAGE LambdaCase #-}
3−{-# LANGUAGE RankNTypes #-}
4−{-# LANGUAGE RecursiveDo #-}
5−
6−module Main where
7−
8−import Control.Monad.Fix
9−import Data.Maybe
10−import qualified Data.Map as Map
11−
12−import Reflex
13−import Reflex.EventWriter.Base
14−import Reflex.Network
15−import Reflex.Patch.MapWithMove
16−import Test.Run
17−
18−main :: IO ()
19−main = do
20− let actions = [ Increment, Update0th, Increment, Swap, Increment, Increment ]
21− os <- runAppB testPatchMapWithMove $ map Just actions
22− -- If the final counter value in the adjusted widgets corresponds to the number of times it has
23− -- been incremented, we know that the networks haven't broken.
24− let expectedCount = length $ ffilter (== Increment) actions
25− -- let !True = last (last os) == [expectedCount,expectedCount] -- TODO re-enable this test after issue #369 has been resolved
26− return ()
27−
28−data PatchMapTestAction
29− = Increment
30− | Swap
31− | Update0th
32− deriving Eq
33−
34−-- See https://github.com/reflex-frp/reflex/issues/369 for the bug that this is testing.
35−testPatchMapWithMove
36− :: forall t m
37− . ( Reflex t
38− , Adjustable t m
39− , MonadHold t m
40− , MonadFix m
41− )
42− => Event t PatchMapTestAction
43− -> m (Behavior t [Int])
44−testPatchMapWithMove pulse = do
45− let pulseAction = ffor pulse $ \case
46− Increment -> Nothing
47− Swap -> patchMapWithMove $ Map.fromList
48− [ (0, NodeInfo (From_Move 1) (Just 1))
49− , (1, NodeInfo (From_Move 0) (Just 0))
50− ]
51− Update0th -> patchMapWithMove $ Map.fromList
52− [ (0, NodeInfo (From_Insert 'z') Nothing) ]
53− (_, result) <- runBehaviorWriterT $ mdo
54− counter <- foldDyn (+) 1 $ fmapMaybe (\e -> if isNothing e then Just 1 else Nothing) pulseAction
55− _ <- mapMapWithAdjustWithMove
56− (\_ _ -> networkHold
57− (tellBehavior $ constant [])
58− ((\t -> tellBehavior $ constant [t]) <$> updated counter))
59− (Map.fromList $ zip [0..] "ab")
60− (fmapMaybe id pulseAction)
61− return ()
62− return result
test/DebugCycles.hsdeleted−171
@@ -1,171 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ConstraintKinds #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE GADTs #-}
5−{-# LANGUAGE RecursiveDo #-}
6−{-# LANGUAGE ScopedTypeVariables #-}
7−{-# LANGUAGE PatternSynonyms #-}
8−{-# LANGUAGE RankNTypes #-}
9−
10−module Main where
11−
12−import Data.Foldable
13−import Control.Lens
14−import Control.Applicative
15−import Control.Monad
16−import Control.Monad.Fix
17−import Control.Exception
18−import System.Timeout
19−import Data.Maybe (isJust)
20−import Data.Functor.Misc
21−import qualified Data.Map as Map
22−import Data.Map (Map)
23−import qualified Data.IntMap as IntMap
24−import Data.IntMap (IntMap)
25−import Data.These
26−import Data.Align
27−import Reflex
28−import Reflex.EventWriter.Base
29−import Test.Run
30−import Test.Hspec
31−import Reflex.Spider.Internal (EventLoopException)
32−import Data.Witherable (Filterable)
33−
34−#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))
35−import Data.These.Lens
36−#endif
37−
38−type Widget t m = (MonadHold t m, Reflex t, MonadFix m)
39−
40−connectDyn :: Widget t m => Event t () -> (Dynamic t a, Dynamic t a) -> m (Dynamic t a)
41−connectDyn e (d, d') = do
42− dd <- holdDyn d (d' <$ e)
43− return $ join dd
44−
45−dynLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
46−dynLoop (e1, e2) = do
47− -- "heightBagRemove: Height 2 not present in bag HeightBag {_heightBag_size = 2, _heightBag_contents = fromList [(0,1)]}"
48− rec
49− d <- count e1
50− d' <- connectDyn e2 (d, liftA2 (+) d d')
51− return $ updated d'
52−
53−connectOnCoincidence :: Widget t m => Event t () -> Event t a -> m (Event t a)
54−connectOnCoincidence click e = do
55− d <- holdDyn never (e <$ click)
56− return $ coincidence (updated d)
57−
58−coincidenceLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
59−coincidenceLoop (e1, e2) = do
60−-- "heightBagRemove: Height 1 not present in bag HeightBag {_heightBag_size = 1, _heightBag_contents = fromList [(0,0)]}"
61−-- (simpler version of dynLoop)
62− rec
63− e' <- connectOnCoincidence e2 (updated d)
64− d <- count (align e' e1)
65− return $ updated d
66−
67−addHeight :: Reflex t => Event t a -> Event t a
68−addHeight e = leftmost [e4, e4] where
69− e1 = leftmost [e, e]
70− e2 = leftmost [e1, e1]
71− e3 = leftmost [e2, e2]
72− e4 = leftmost [e3, e3]
73−
74−-- Take an existing test and build it inside a
75−buildLoop :: Widget t m => (forall t m. Widget t m => (Event t Int, Event t ()) -> m (Event t Int)) -> (Event t Int, Event t ()) -> m (Event t Int)
76−buildLoop test (e1, e2) = switchHold never buildLoop
77− where buildLoop = pushAlways (const $ test (e1, e2)) e2
78−
79−connectButtonPromptly :: Widget t m => Event t () -> Event t a -> m (Event t a)
80−connectButtonPromptly click e = do
81− d <- holdDyn never (e <$ click)
82− return (switchDyn d)
83−
84−connectButton :: Widget t m => Event t () -> Event t a -> m (Event t a)
85−connectButton click e = do
86− d <- hold never (e <$ click)
87− return (switch d)
88−
89−switchLoop01 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
90−switchLoop01 (e1, e2) = do
91− rec
92− e' <- connectButton e2 (updated d)
93− d <- count (align e' e1)
94− return $ updated d
95−
96−mergeLoop :: forall t m. (Adjustable t m, Widget t m) => (Event t Int, Event t ()) -> m (Event t Int)
97−mergeLoop (e1, e2) = do
98− rec
99− (_, e) <- runEventWriterT $
100− runWithReplace w (leftmost [w <$ e1])
101− return (sum <$> e)
102− where
103− w = do
104− c <- count e1
105− tellEvent (updated ((pure <$> c) :: Dynamic t [Int]))
106−
107−switchLoop02 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
108−switchLoop02 (e1, e2) = do
109− rec
110− e' <- connectButton e2 (updated d)
111− d <- count (leftmost [e', e1])
112− return $ updated d
113−
114−switchLoop03 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
115−switchLoop03 (e1, e2) = do
116− rec
117− e' <- connectButton e2 (addHeight $ updated d)
118− d <- count (align e' e1)
119− return $ updated d
120−
121−staticLoop01 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
122−staticLoop01 (e1, e2) = do
123− rec
124− d <- foldDyn (+) (0 :: Int) (1 <$ align e1 (updated d))
125− return $ updated d
126−
127−staticLoop02 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
128−staticLoop02 (e1, e2) = do
129− rec
130− d <- foldDyn (+) (0 :: Int) (leftmost [e1, updated d])
131− return $ updated d
132−
133−buildStaticLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
134−buildStaticLoop (e1, e2) = switchHold never buildLoop
135− where buildLoop = pushAlways (const $ staticLoop01 (e1, e2)) e2
136−
137−splitThese :: Filterable f => f (These a b) -> (f a, f b)
138−splitThese f = (mapMaybe (preview here) f, mapMaybe (preview there) f)
139−
140−main :: IO ()
141−main = hspec $ do
142− describe "DebugCycles" $ do
143− it "throws EventLoopException on switchLoop01" $ do
144− check switchLoop01
145− it "throws EventLoopException on switchLoop02" $ do
146− check switchLoop02
147− it "throws EventLoopException on switchLoop03" $ do
148− check switchLoop03
149− it "throws EventLoopException on buildSwitchLoop" $ do
150− check $ buildLoop switchLoop01
151− xit "throws EventLoopException on mergeLoop" $ do
152− check mergeLoop
153− xit "throws EventLoopException on staticLoop01" $ do
154− check staticLoop01
155− xit "throws EventLoopException on staticLoop02" $ do
156− check staticLoop02
157− xit "throws EventLoopException on buildStaticLoop" $ do
158− check buildStaticLoop
159− xit "throws EventLoopException on coincidenceLoop" $ do
160− check coincidenceLoop
161− xit "throws EventLoopException on dynLoop" $ do
162− check dynLoop
163− xit "throws EventLoopException on buildCoincidenceLoop" $ do
164− check $ buildLoop coincidenceLoop
165− where
166− milliseconds = (*1000)
167− occs = [ This 1, This 2, That (), This 3, That (), This 1 ]
168− check test = do
169− let action = timeout (milliseconds 50) $ do
170− runApp' (test . splitThese) (Just <$> occs)
171− action `shouldThrow` (const True :: Selector EventLoopException)
test/EventWriterT.hs+3−92
@@ -1,23 +1,11 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE BangPatterns #-}
31{-# LANGUAGE FlexibleContexts #-}
42{-# LANGUAGE GADTs #-}
5−{-# LANGUAGE RecursiveDo #-}
6−{-# LANGUAGE ScopedTypeVariables #-}
73module Main where
84
95import Control.Lens
106import Control.Monad
11−import Control.Monad.Fix
12−import qualified Data.Dependent.Map as DMap
13−import Data.Functor.Misc
14−import qualified Data.Map as M
157import Data.These
168
17−#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))
18−import Data.These.Lens
19−#endif
20−
219import Reflex
2210import Reflex.EventWriter.Base
2311import Test.Run
@@ -36,15 +24,6 @@ main = do
3624 , These () ()
3725 ]
3826 print os2
39− os3@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEvent) [Just ()]
40− print os3
41− os4@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEventDMap) [Just ()]
42− print os4
43− os5@[[Nothing, Just [1, 2]]] <- runApp' (unwrapApp testLiveTellEventDMap) [Just ()]
44− print os5
45− os6 <- runApp' (unwrapApp delayedPulse) [Just ()]
46− print os6
47− let ![[Nothing, Nothing]] = os6
4827 return ()
4928
5029unwrapApp :: (Reflex t, Monad m) => (a -> EventWriterT t [Int] m ()) -> a -> m (Event t [Int])
@@ -53,82 +32,14 @@ unwrapApp x appIn = do
5332 return e
5433
5534testOrdering :: (Reflex t, Monad m) => Event t () -> EventWriterT t [Int] m ()
56−testOrdering pulse = forM_ [10,9..1] $ \i -> tellEvent ([i] <$ pulse)
35+testOrdering pulse = do
36+ forM_ [10,9..1] $ \i -> tellEvent ([i] <$ pulse)
37+ return ()
5738
5839testSimultaneous :: (Reflex t, Adjustable t m, MonadHold t m) => Event t (These () ()) -> EventWriterT t [Int] m ()
5940testSimultaneous pulse = do
6041 let e0 = fmapMaybe (^? here) pulse
6142 e1 = fmapMaybe (^? there) pulse
6243 forM_ [1,3..9] $ \i -> runWithReplace (tellEvent ([i] <$ e0)) $ ffor e1 $ \_ -> tellEvent ([i+1] <$ e0)
63−
64−-- | Test that a widget telling and event which fires at the same time it has been replaced
65−-- doesn't count along with the new widget.
66−testMoribundTellEvent
67− :: forall t m
68− . ( Reflex t
69− , Adjustable t m
70− , MonadHold t m
71− , MonadFix m
72− )
73− => Event t ()
74− -> EventWriterT t [Int] m ()
75−testMoribundTellEvent pulse = do
76− rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m ()
77− tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished
78− (_, rwrFinished) <- runWithReplace (tellIntOnReplace 1) $ tellIntOnReplace 2 <$ pulse
79− return ()
80−
81−-- | The equivalent of 'testMoribundTellEvent' for 'traverseDMapWithKeyWithAdjust'.
82−testMoribundTellEventDMap
83− :: forall t m
84− . ( Reflex t
85− , Adjustable t m
86− , MonadHold t m
87− , MonadFix m
88− )
89− => Event t ()
90− -> EventWriterT t [Int] m ()
91−testMoribundTellEventDMap pulse = do
92− rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m ()
93− tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished
94− (_, rwrFinished :: Event t (PatchDMap (Const2 () Int) Identity)) <-
95− traverseDMapWithKeyWithAdjust
96− (\(Const2 ()) (Identity v) -> Identity . const v <$> tellIntOnReplace v)
97− (mapToDMap $ M.singleton () 1)
98− ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton () 2) <$ pulse)
99− return ()
100−
101−-- | Ensures that elements which are _not_ removed can still fire 'tellEvent's
102−-- during the same frame as other elements are updated.
103−testLiveTellEventDMap
104− :: forall t m
105− . ( Reflex t
106− , Adjustable t m
107− , MonadHold t m
108− , MonadFix m
109− )
110− => Event t ()
111− -> EventWriterT t [Int] m ()
112−testLiveTellEventDMap pulse = do
113− rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m ()
114− tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished
115− (_, rwrFinished :: Event t (PatchDMap (Const2 Int ()) Identity)) <-
116− traverseDMapWithKeyWithAdjust
117− (\(Const2 k) (Identity ()) -> Identity <$> tellIntOnReplace k)
118− (mapToDMap $ M.singleton 1 ())
119− ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton 2 ()) <$ pulse)
12044 return ()
12145
122−delayedPulse
123− :: forall t m
124− . ( Reflex t
125− , Adjustable t m
126− , MonadHold t m
127− , MonadFix m
128− )
129− => Event t ()
130− -> EventWriterT t [Int] m ()
131−delayedPulse pulse = void $ flip runWithReplace (pure () <$ pulse) $ do
132− -- This has the effect of delaying pulse' from pulse
133− (_, pulse') <- runWithReplace (pure ()) $ pure [1] <$ pulse
134− tellEvent pulse'
test/GC.hs+5−6
@@ -18,17 +18,15 @@ import Data.GADT.Compare
1818import Data.IORef
1919import Data.Semigroup
2020import Data.These
21−import Data.Type.Equality ((:~:)(Refl))
2221
2322import Data.Functor.Misc
24−import Data.Patch
23+import Reflex.Patch
2524
2625import qualified Reflex.Host.Class as Host
2726import qualified Reflex.Spider.Internal as S
2827
2928import System.Exit
3029import System.Mem
31−import Data.Coerce
3230
3331main :: IO ()
3432main = do
@@ -48,7 +46,7 @@ hostPerf ref = S.runSpiderHost $ do
4846 eventToPerform <- Host.runHostFrame $ do
4947 (reqMap :: S.Event S.Global (DMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) Identity))
5048 <- S.SpiderHostFrame
51− $ fmap ( S.mergeG coerce
49+ $ fmap ( S.merge
5250 . S.dynamicHold)
5351 $ S.hold DMap.empty
5452 -- Construct a new heap object for the subscriber, invalidating any weak references to the subscriber if they are not retained
@@ -57,8 +55,8 @@ hostPerf ref = S.runSpiderHost $ do
5755 { S.subscriberPropagate = S.subscriberPropagate sub
5856 }
5957 return (s, o))
60− $ runIdentity . runIdentity <$> S.selectG
61− (S.fanG $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response)
58+ $ runIdentity <$> S.select
59+ (S.fan $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response)
6260 (WrapArg Request)
6361 return $ alignWith (mergeThese (<>))
6462 (flip S.pushCheap eadd $ \_ -> return $ Just $ DMap.singleton Request $ do
@@ -84,6 +82,7 @@ hostPerf ref = S.runSpiderHost $ do
8482 Nothing -> []
8583 Host.fireEventsAndRead followupEventTriggers $ return ()
8684 return ()
85+ return ()
8786
8887data Tell a where
8988 Action :: Tell ()
test/Headless.hsdeleted−10
@@ -1,10 +0,0 @@
1−module Main where
2−
3−import Reflex
4−import Reflex.Host.Headless (runHeadlessApp)
5−
6−main :: IO ()
7−main = do
8− runHeadlessApp $ do
9− pb <- getPostBuild
10− performEvent (pure <$> pb)
test/QueryT.hs+8−19
@@ -1,30 +1,23 @@
1−{-# LANGUAGE CPP #-}
21{-# LANGUAGE DeriveFunctor #-}
32{-# LANGUAGE FlexibleContexts #-}
43{-# LANGUAGE GeneralizedNewtypeDeriving #-}
54{-# LANGUAGE LambdaCase #-}
65{-# LANGUAGE RankNTypes #-}
7−{-# LANGUAGE StandaloneDeriving #-}
86{-# LANGUAGE TypeFamilies #-}
9−{-# LANGUAGE UndecidableInstances #-}
107
118import Control.Lens
129import Control.Monad.Fix
1310import Data.Align
11+import Data.AppendMap (AppendMap)
1412import qualified Data.AppendMap as AMap
1513import Data.Functor.Misc
1614import Data.Map (Map)
1715import qualified Data.Map as Map
18−import Data.Map.Monoidal (MonoidalMap)
1916import Data.Semigroup
2017import Data.These
2118
22−#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))
23−import Data.These.Lens
24−#endif
25−
2619import Reflex
27−import Data.Patch.MapWithMove
20+import Reflex.Patch.MapWithMove
2821import Test.Run
2922
3023newtype MyQuery = MyQuery SelectedCount
@@ -34,18 +27,14 @@ instance Query MyQuery where
3427 type QueryResult MyQuery = ()
3528 crop _ _ = ()
3629
37−instance (Ord k, Query a, Eq (QueryResult a), Align (MonoidalMap k)) => Query (Selector k a) where
30+instance (Ord k, Query a, Eq (QueryResult a)) => Query (Selector k a) where
3831 type QueryResult (Selector k a) = Selector k (QueryResult a)
3932 crop q r = undefined
4033
41−newtype Selector k a = Selector { unSelector :: MonoidalMap k a }
34+newtype Selector k a = Selector { unSelector :: AppendMap k a }
4235 deriving (Show, Read, Eq, Ord, Functor)
4336
44−#if !(MIN_VERSION_monoidal_containers(0,4,1))
45−deriving instance Ord k => Align (MonoidalMap k)
46−#endif
47−
48−instance (Ord k, Eq a, Monoid a, Align (MonoidalMap k)) => Semigroup (Selector k a) where
37+instance (Ord k, Eq a, Monoid a) => Semigroup (Selector k a) where
4938 (Selector a) <> (Selector b) = Selector $ fmapMaybe id $ f a b
5039 where
5140 f = alignWith $ \case
@@ -55,14 +44,14 @@ instance (Ord k, Eq a, Monoid a, Align (MonoidalMap k)) => Semigroup (Selector k
5544 let z = x `mappend` y
5645 in if z == mempty then Nothing else Just z
5746
58−instance (Ord k, Eq a, Monoid a, Align (MonoidalMap k)) => Monoid (Selector k a) where
47+instance (Ord k, Eq a, Monoid a) => Monoid (Selector k a) where
5948 mempty = Selector AMap.empty
6049 mappend = (<>)
6150
62−instance (Eq a, Ord k, Group a, Align (MonoidalMap k)) => Group (Selector k a) where
51+instance (Eq a, Ord k, Group a) => Group (Selector k a) where
6352 negateG = fmap negateG
6453
65−instance (Eq a, Ord k, Group a, Align (MonoidalMap k)) => Additive (Selector k a)
54+instance (Eq a, Ord k, Group a) => Additive (Selector k a)
6655
6756main :: IO ()
6857main = do
test/Reflex/Bench/Focused.hs+1−13
@@ -130,16 +130,6 @@ mapDynChain = iterM (return . fmap (+1))
130130joinDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
131131joinDynChain = iterM (\d -> return $ join $ fmap (const d) d)
132132
133−holdDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
134−holdDynChain = iterM (\d -> sample (current d) >>= flip holdDyn (updated d))
135−
136−buildDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
137−buildDynChain = iterM (\d -> do
138− let b = fmap (+1) (current d)
139− e = fmap (*2) (updated d)
140− buildDynamic (sample b) e)
141−
142−
143133combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
144134combineDynChain = iterM (\d -> return $ zipDynWith (+) d d)
145135
@@ -194,7 +184,7 @@ switchMergeBehaviors mapChanges = pull . joinMap <$> holdMap mapChanges
194184
195185-- | Turn an UpdatedMap into a Dynamic by applying the differences to the initial value
196186holdMapDyn :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => UpdatedMap t k a -> m (Dynamic t (Map k a))
197−holdMapDyn (UpdatedMap initial changes) = foldDyn (flip (Map.foldrWithKey modify)) initial changes
187+holdMapDyn (UpdatedMap initial changes) = foldDyn (flip (Map.foldWithKey modify)) initial changes
198188
199189 where
200190 modify k Nothing items = Map.delete k items
@@ -318,8 +308,6 @@ dynamics :: Word -> [(String, TestCase)]
318308dynamics n =
319309 [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d
320310 , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d
321− , testE "holdDynChain" $ fmap updated $ holdDynChain n =<< d
322− , testE "buildDynChain" $ fmap updated $ buildDynChain n =<< d
323311 , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d
324312 , testE "dense mergeTree" $ fmap (updated . mergeTreeDyn 8) dense
325313 , testE "sparse mergeTree" $ fmap (updated . mergeTreeDyn 8) sparse
test/Reflex/Plan/Pure.hs+4−5
@@ -41,7 +41,6 @@ instance MonadHold (Pure Int) PurePlan where
4141 holdIncremental initial = liftPlan . holdIncremental initial
4242 buildDynamic getInitial = liftPlan . buildDynamic getInitial
4343 headE = liftPlan . headE
44− now = liftPlan now
4544
4645instance MonadSample (Pure Int) PurePlan where
4746 sample = liftPlan . sample
@@ -56,15 +55,15 @@ instance TestPlan (Pure Int) PurePlan where
5655runPure :: PurePlan a -> (a, IntSet)
5756runPure (PurePlan p) = runStateT p mempty $ 0
5857
59−relevantTimes :: IntSet -> IntSet
60−relevantTimes occs = IntSet.fromList [0..l + 1]
58+relavantTimes :: IntSet -> IntSet
59+relavantTimes occs = IntSet.fromList [0..l + 1]
6160 where l = fromMaybe 0 (fst <$> IntSet.maxView occs)
6261
6362testBehavior :: (Behavior (Pure Int) a, IntSet) -> IntMap a
64−testBehavior (b, occs) = IntMap.fromSet (sample b) (relevantTimes occs)
63+testBehavior (b, occs) = IntMap.fromSet (sample b) (relavantTimes occs)
6564
6665testEvent :: (Event (Pure Int) a, IntSet) -> IntMap (Maybe a)
67−testEvent (Event readEvent, occs) = IntMap.fromSet readEvent (relevantTimes occs)
66+testEvent (Event readEvent, occs) = IntMap.fromSet readEvent (relavantTimes occs)
6867
6968
7069
test/Reflex/Plan/Reflex.hs+2−2
@@ -74,13 +74,13 @@ deriving instance ReflexHost t => MonadFix (Plan t)
7474
7575
7676instance (ReflexHost t, MonadRef (HostFrame t), Ref (HostFrame t) ~ Ref IO) => TestPlan t (Plan t) where
77− plan occurrences = Plan $ do
77+ plan occurances = Plan $ do
7878 (e, ref) <- newEventWithTriggerRef
7979 modify (IntMap.unionWith mappend (firings ref))
8080 return e
8181
8282 where
83− firings ref = IntMap.fromList (makeFiring ref <$> occurrences)
83+ firings ref = IntMap.fromList (makeFiring ref <$> occurances)
8484 makeFiring ref (t, a) = (fromIntegral t, [Firing ref a])
8585
8686
test/Reflex/Test/CrossImpl.hs+12−24
@@ -12,6 +12,7 @@
1212{-# LANGUAGE TypeFamilies #-}
1313{-# LANGUAGE TypeOperators #-}
1414{-# LANGUAGE UndecidableInstances #-}
15+module Reflex.Test.CrossImpl (test) where
1516
1617import Prelude hiding (and, foldl, mapM, mapM_, sequence, sequence_)
1718
@@ -21,21 +22,22 @@ import Reflex.Dynamic
2122import Reflex.Host.Class
2223import qualified Reflex.Pure as P
2324import qualified Reflex.Spider.Internal as S
24−import qualified Reflex.Profiled as Prof
2525
2626import Control.Arrow (second, (&&&))
2727import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
2828import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
29−import Data.Dependent.Sum (DSum (..))
29+import Control.Monad.Writer hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
30+import Data.Dependent.Map (DSum (..))
3031import Data.Foldable
3132import Data.Map.Strict (Map)
3233import qualified Data.Map.Strict as Map
3334import qualified Data.Set as Set
34−import Data.Monoid
3535import Data.Traversable
3636import System.Exit
3737import System.Mem
3838
39+import System.IO.Unsafe
40+
3941mapToPureBehavior :: Map Int a -> Behavior PureReflexDomain a
4042mapToPureBehavior m = P.Behavior $ \t -> case Map.lookupLE t m of
4143 Nothing -> error $ "mapToPureBehavior: no value for time " <> show t
@@ -72,14 +74,11 @@ instance MapMSignals (Event t a) (Event t' a) t t' where
7274instance (MapMSignals a a' t t', MapMSignals b b' t t') => MapMSignals (a, b) (a', b') t t' where
7375 mapMSignals fb fe (a, b) = liftM2 (,) (mapMSignals fb fe a) (mapMSignals fb fe b)
7476
75−testTimeline
76− :: (forall m t. TestCaseConstraint t m => (Behavior t a, Event t b) -> m (Behavior t c, Event t d))
77− -> (Map Int a, Map Int b)
78− -> (forall m t. (MonadReflexHost t m, MonadIO m, MonadRef m, Ref m ~ Ref IO, MonadSample t m) => m (Map Int c, Map Int d))
79−testTimeline builder (bMap, eMap) = do
77+testSpider :: (forall m t. TestCaseConstraint t m => (Behavior t a, Event t b) -> m (Behavior t c, Event t d)) -> (Map Int a, Map Int b) -> (Map Int c, Map Int d)
78+testSpider builder (bMap, eMap) = unsafePerformIO $ S.runSpiderHost $ do
8079 (re, reTrigger) <- newEventWithTriggerRef
8180 (rb, rbTrigger) <- newEventWithTriggerRef
82− b <- runHostFrame $ hold (error "testTimeline: No value for input behavior yet") rb
81+ b <- runHostFrame $ hold (error "testSpider: No value for input behavior yet") rb
8382 (b', e') <- runHostFrame $ builder (b, re)
8483 e'Handle <- subscribeEvent e' --TODO: This should be unnecessary
8584 let times = relevantTestingTimes (bMap, eMap)
@@ -104,11 +103,9 @@ testAgreement :: (Eq c, Eq d, Show c, Show d) => (forall m t. TestCaseConstraint
104103testAgreement builder inputs = do
105104 let identityResult = testPure builder inputs
106105 tracePerf "---------" $ return ()
107− spiderResult <- S.runSpiderHost $ testTimeline builder inputs
108− tracePerf "---------" $ return ()
109− profiledResult <- S.runSpiderHost $ Prof.runProfiledM $ testTimeline builder inputs
106+ let spiderResult = testSpider builder inputs
110107 tracePerf "---------" $ return ()
111− let resultsAgree = identityResult == spiderResult && identityResult == profiledResult
108+ let resultsAgree = identityResult == spiderResult
112109 if resultsAgree
113110 then do --putStrLn "Success:"
114111 --print identityResult
@@ -116,7 +113,6 @@ testAgreement builder inputs = do
116113 else do putStrLn "Failure:"
117114 putStrLn $ "Pure result: " <> show identityResult
118115 putStrLn $ "Spider result: " <> show spiderResult
119− putStrLn $ "Profiled result: " <> show profiledResult
120116 return resultsAgree
121117
122118type TestCaseConstraint t m = (Reflex t, MonadSample t m, MonadHold t m, MonadFix m, MonadFix (PushM t))
@@ -223,11 +219,6 @@ testCases =
223219 bb <- hold b $ pushAlways (const $ hold "asdf" eo) eo
224220 let b' = pull $ sample =<< sample bb
225221 return (b', e)
226− , (,) "foldDynWhileFiring" $ TestCase (Map.singleton 0 "zxc", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(_, e) -> do
227− d <- foldDyn (:) [] $
228− pushAlways (\a -> foldDyn (:) [a] e) e
229− let b = current (join (fmap distributeListOverDynPure d))
230− return (b, e)
231222 , (,) "joinDyn" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
232223 bb <- hold "b" e
233224 bd <- hold never . fmap (const e) =<< headE e
@@ -239,9 +230,6 @@ testCases =
239230 rec result <- holdUniqDyn d
240231 d <- holdDyn (0 :: Int) e
241232 return (current result, updated result)
242−
243−
244−
245233 {-
246234 , (,) "mergeIncrementalWithMove" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, PatchDMapWithMove.moveDMapKey LeftTag RightTag), (2, mempty)]) $ \(b, e :: Event t (PatchDMapWithMove (EitherTag () ()) (Const2 () ()))) -> do
247235 x <- holdIncremental (DMap.singleton LeftTag $ void e) $ PatchDMapWithMove.mapPatchDMapWithMove (\(Const2 _) -> void e) <$> e
@@ -257,8 +245,8 @@ splitRecombineEvent e =
257245 in leftmost [ea, eb]
258246
259247
260−main :: IO ()
261−main = do
248+test :: IO ()
249+test = do
262250 results <- forM testCases $ \(name, TestCase inputs builder) -> do
263251 putStrLn $ "Test: " <> name
264252 testAgreement builder inputs
test/Reflex/Test/Micro.hs+4−71
@@ -3,7 +3,6 @@
33{-# LANGUAGE FlexibleContexts #-}
44{-# LANGUAGE FlexibleInstances #-}
55{-# LANGUAGE GADTs #-}
6−{-# LANGUAGE ScopedTypeVariables #-}
76{-# LANGUAGE MultiParamTypeClasses #-}
87{-# LANGUAGE RankNTypes #-}
98{-# LANGUAGE RecursiveDo #-}
@@ -24,24 +23,6 @@ import Data.Monoid
2423
2524import Prelude
2625
27−pushDyn :: (Reflex t, MonadHold t m) => (a -> PushM t b) -> Dynamic t a -> m (Dynamic t b)
28−pushDyn f d = buildDynamic (sample (current d) >>= f) (pushAlways f (updated d))
29−
30−foldedDyn :: (Reflex t, MonadHold t m) => (a -> a -> a) -> Dynamic t a -> m (Dynamic t a)
31−foldedDyn f d = fmap join $ flip buildDynamic never $ do
32− a <- sample (current d)
33− foldDyn f a (updated d)
34−
35−scannedDyn :: (Reflex t, MonadHold t m) => Dynamic t a -> m (Dynamic t [a])
36−scannedDyn = fmap (fmap reverse) . foldedDyn (<>) . fmap pure
37−
38−scanInnerDyns :: (Reflex t, MonadHold t m) => Dynamic t (Dynamic t a) -> m (Dynamic t [a])
39−scanInnerDyns d = do
40− scans <- scannedDyn d
41− return (join (fmap distributeListOverDynPure scans))
42−
43−
44−
4526{-# ANN testCases "HLint: ignore Functor law" #-}
4627testCases :: [(String, TestCase)]
4728testCases =
@@ -220,14 +201,6 @@ testCases =
220201 bb <- hold (constant "x") $ pushAlways (const $ hold "a" eo) eo
221202 return $ pull $ sample =<< sample bb
222203
223−
224− , testB "foldDynWhileFiring" $ do
225− e <- events1
226− d <- foldDyn (:) [] $
227− pushAlways (\a -> foldDyn (:) [a] e) e
228−
229− return $ current (join (fmap distributeListOverDynPure d))
230−
231204 , testE "joinDyn" $ do
232205 e <- events1
233206 bb <- hold "b" e
@@ -250,38 +223,6 @@ testCases =
250223 d2 <- fmap (fmap (map toUpper)) $ foldDyn (++) "0" =<< events2
251224
252225 return $ current $ zipDynWith (<>) d1 d2
253−
254− , testB "buildDynamicStrictness" $ do
255− rec
256− d'' <- pushDyn return d'
257− d' <- pushDyn return d
258− d <- holdDyn "0" =<< events1
259−
260− _ <- sample (current d'')
261− return (current d'')
262−
263− , testB "factorDyn" $ do
264− d <- holdDyn (Left "a") =<< eithers
265−
266− eithers' <- eitherDyn d
267− let unFactor = either id id
268− return $ current (join (fmap unFactor eithers'))
269−
270− , testB "pushDynDeep" $ do
271− _ <- events1
272− _ <- events2
273−
274− d1 <- holdDyn "d1" =<< events1
275− d2 <- holdDyn "d2" =<< events2
276−
277− d <- flip pushDyn d1 $ \a ->
278− flip pushDyn d2 $ \b ->
279− flip pushDyn d1 $ \c ->
280− return (a <> b <> c)
281−
282− d' <- pushDyn scanInnerDyns d >>= scanInnerDyns
283− return $ current d'
284−
285226 , testE "fan-1" $ do
286227 e <- fmap toMap <$> events1
287228 let es = select (fanMap e) . Const2 <$> values
@@ -322,24 +263,14 @@ testCases =
322263 let e = never <$ switch b
323264 return $ void e
324265 lazyHold
325− , testE "now-1" $ do
326− e1 <- events1
327− switchHoldPromptly never . pushAlways (\a -> fmap (a <$) now) $ e1
328− , testE "now-2" $ do
329− e1 <- events1
330− let e = pushAlways (\a -> if a == "a" then now else return never) e1
331− x <- accumDyn (<>) never e
332− return . coincidence $ updated x
266+
333267 ] where
334268
335269 events1, events2, events3 :: TestPlan t m => m (Event t String)
336270 events1 = plan [(1, "a"), (2, "b"), (5, "c"), (7, "d"), (8, "e")]
337271 events2 = plan [(1, "e"), (3, "d"), (4, "c"), (6, "b"), (7, "a")]
338− events3 = liftA2 mappend events1 events2
339−
340− eithers :: TestPlan t m => m (Event t (Either String String))
341− eithers = plan [(1, Left "e"), (3, Left "d"), (4, Right "c"), (6, Right "b"), (7, Left "a")]
342272
273+ events3 = liftA2 mappend events1 events2
343274
344275 values = "abcde"
345276 toMap str = Map.fromList $ map (\c -> (c, c)) str
@@ -350,3 +281,5 @@ testCases =
350281
351282 deep e = leftmost [e, e]
352283 leftmost2 e1 e2 = leftmost [e1, e2]
284+
285+
test/Reflex/TestPlan.hs+2−2
@@ -26,8 +26,8 @@ import Reflex.Class
2626import Prelude
2727
2828class (Reflex t, MonadHold t m, MonadFix m) => TestPlan t m where
29− -- | Specify a plan of an input Event firing
30− -- Occurrences must be in the future (i.e. Time > 0)
29+ -- | Speicify a plan of an input Event firing
30+ -- Occurances must be in the future (i.e. Time > 0)
3131 -- Initial specification is
3232
3333 plan :: [(Word, a)] -> m (Event t a)
test/RequesterT.hs+11−179
@@ -1,40 +1,14 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE BangPatterns #-}
31{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
52{-# LANGUAGE GADTs #-}
6−{-# LANGUAGE LambdaCase #-}
7−{-# LANGUAGE MultiParamTypeClasses #-}
8−{-# LANGUAGE RecursiveDo #-}
3+{-# LANGUAGE RankNTypes #-}
94{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TemplateHaskell #-}
11−{-# LANGUAGE TypeApplications #-}
12−{-# LANGUAGE TypeFamilies #-}
135module Main where
146
15−import Control.Lens hiding (has)
7+import Control.Lens
168import Control.Monad
17−import Control.Monad.Fix
18−import Control.Monad.IO.Class (MonadIO)
19−import Data.Constraint.Extras
20−import Data.Constraint.Extras.TH
21−import Data.Constraint.Forall
229import qualified Data.Dependent.Map as DMap
2310import Data.Dependent.Sum
24−import Data.Functor.Misc
25−import Data.List (words)
26−import Data.Map (Map)
27−import qualified Data.Map as M
28−#if !MIN_VERSION_these(4,11,0)
29−import Data.Semigroup ((<>))
30−#endif
31−import Data.Text (Text)
3211import Data.These
33−import Text.Read (readMaybe)
34−
35−#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))
36−import Data.These.Lens
37−#endif
3812
3913import Reflex
4014import Reflex.Requester.Base
@@ -46,38 +20,18 @@ data RequestInt a where
4620
4721main :: IO ()
4822main = do
49− os1 <- runApp' (unwrapApp testOrdering) $
23+ os1@[[Just [10,9,8,7,6,5,4,3,2,1]]] <- runApp' (unwrapApp testOrdering) $
5024 [ Just ()
5125 ]
5226 print os1
53− os2 <- runApp' (unwrapApp testSimultaneous) $ map Just $
54− [ This ()
55− , That ()
56− , This ()
57− , These () ()
58− ]
27+ os2@[[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]]
28+ <- runApp' (unwrapApp testSimultaneous) $ map Just $
29+ [ This ()
30+ , That ()
31+ , This ()
32+ , These () ()
33+ ]
5934 print os2
60− os3 <- runApp' (unwrapApp testMoribundRequest) [Just ()]
61− print os3
62− os4 <- runApp' (unwrapApp testMoribundRequestDMap) [Just ()]
63− print os4
64− os5 <- runApp' (unwrapApp testLiveRequestDMap) [Just ()]
65− print os5
66− os6 <- runApp' (unwrapApp delayedPulse) [Just ()]
67− print os6
68− os7 <- runApp' testMatchRequestsWithResponses [ Just $ TestRequest_Increment 1 ]
69− print os7
70− os8 <- runApp' testMatchRequestsWithResponses [ Just $ TestRequest_Reverse "yoyo" ]
71− print os8
72− let ![[Just [1,2,3,4,5,6,7,8,9,10]]] = os1 -- The order is reversed here: see the documentation for 'runRequesterT'
73− let ![[Just [9,7,5,3,1]],[Nothing,Nothing],[Just [10,8,6,4,2]],[Just [10,8,6,4,2],Nothing]] = os2
74− let ![[Nothing, Just [2]]] = os3
75− let ![[Nothing, Just [2]]] = os4
76− let ![[Nothing, Just [1, 2]]] = os5
77− -- let ![[Nothing, Nothing]] = os6 -- TODO re-enable this test after issue #233 has been resolved
78− let !(Just [(1,"2")]) = M.toList <$> head (head os7)
79− let !(Just [(1,"oyoy")]) = M.toList <$> head (head os8)
80−
8135 return ()
8236
8337unwrapRequest :: DSum tag RequestInt -> Int
@@ -89,7 +43,7 @@ unwrapApp :: ( Reflex t, Monad m )
8943 -> m (Event t [Int])
9044unwrapApp x appIn = do
9145 ((), e) <- runRequesterT (x appIn) never
92− return $ fmap (map unwrapRequest . requesterDataToList) e
46+ return $ fmap (map unwrapRequest . DMap.toList) e
9347
9448testOrdering :: ( Response m ~ Identity
9549 , Request m ~ RequestInt
@@ -111,125 +65,3 @@ testSimultaneous pulse = do
11165 switchE = fmapMaybe (^? there) pulse
11266 forM_ [1,3..9] $ \i -> runWithReplace (requestingIdentity (RequestInt i <$ tellE)) $ ffor switchE $ \_ ->
11367 requestingIdentity (RequestInt (i+1) <$ tellE)
114−
115−-- | Test that a widget requesting and event which fires at the same time it has been replaced
116−-- doesn't count along with the new widget.
117−testMoribundRequest
118− :: forall t m
119− . ( Reflex t
120− , Adjustable t m
121− , MonadHold t m
122− , MonadFix m
123− , Response m ~ Identity
124− , Request m ~ RequestInt
125− , Requester t m
126− )
127− => Event t ()
128− -> m ()
129−testMoribundRequest pulse = do
130− rec let requestIntOnReplace x = requestingIdentity $ RequestInt x <$ rwrFinished
131− (_, rwrFinished) <- runWithReplace (requestIntOnReplace 1) $ requestIntOnReplace 2 <$ pulse
132− return ()
133−
134−-- | The equivalent of 'testMoribundRequest' for 'traverseDMapWithKeyWithAdjust'.
135−testMoribundRequestDMap
136− :: forall t m
137− . ( Reflex t
138− , Adjustable t m
139− , MonadHold t m
140− , MonadFix m
141− , Response m ~ Identity
142− , Request m ~ RequestInt
143− , Requester t m
144− )
145− => Event t ()
146− -> m ()
147−testMoribundRequestDMap pulse = do
148− rec let requestIntOnReplace :: Int -> m ()
149− requestIntOnReplace x = void $ requestingIdentity $ RequestInt x <$ rwrFinished
150− (_, rwrFinished :: Event t (PatchDMap (Const2 () Int) Identity)) <-
151− traverseDMapWithKeyWithAdjust
152− (\(Const2 ()) (Identity v) -> Identity . const v <$> requestIntOnReplace v)
153− (mapToDMap $ M.singleton () 1)
154− ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton () 2) <$ pulse)
155− return ()
156−
157−-- | Ensures that elements which are _not_ removed can still fire requests
158−-- during the same frame as other elements are updated.
159−testLiveRequestDMap
160− :: forall t m
161− . ( Reflex t
162− , Adjustable t m
163− , MonadHold t m
164− , MonadFix m
165− , Response m ~ Identity
166− , Request m ~ RequestInt
167− , Requester t m
168− )
169− => Event t ()
170− -> m ()
171−testLiveRequestDMap pulse = do
172− rec let requestIntOnReplace :: Int -> m ()
173− requestIntOnReplace x = void $ requestingIdentity $ RequestInt x <$ rwrFinished
174− (_, rwrFinished :: Event t (PatchDMap (Const2 Int ()) Identity)) <-
175− traverseDMapWithKeyWithAdjust
176− (\(Const2 k) (Identity ()) -> Identity <$> requestIntOnReplace k)
177− (mapToDMap $ M.singleton 1 ())
178− ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton 2 ()) <$ pulse)
179− return ()
180−
181−delayedPulse
182− :: forall t m
183− . ( Reflex t
184− , Adjustable t m
185− , MonadHold t m
186− , MonadFix m
187− , Response m ~ Identity
188− , Request m ~ RequestInt
189− , PerformEvent t m
190− , Requester t m
191− )
192− => Event t ()
193− -> m ()
194−delayedPulse pulse = void $ flip runWithReplace (pure () <$ pulse) $ do
195− -- This has the effect of delaying pulse' from pulse
196− (_, pulse') <- runWithReplace (pure ()) $ pure (RequestInt 1) <$ pulse
197− requestingIdentity pulse'
198−
199−data TestRequest a where
200− TestRequest_Reverse :: String -> TestRequest String
201− TestRequest_Increment :: Int -> TestRequest Int
202−
203−testMatchRequestsWithResponses
204− :: forall m t req a
205− . ( MonadFix m
206− , MonadHold t m
207− , Reflex t
208− , PerformEvent t m
209− , MonadIO (Performable m)
210− , ForallF Show req
211− , Has Read req
212− )
213− => Event t (req a) -> m (Event t (Map Int String))
214−testMatchRequestsWithResponses pulse = mdo
215− (_, requests) <- runRequesterT (requesting pulse) responses
216− let rawResponses = M.map (\v ->
217− case words v of
218− ["reverse", str] -> reverse str
219− ["increment", i] -> show $ succ $ (read i :: Int)
220− ) <$> rawRequestMap
221− (rawRequestMap, responses) <- matchResponsesWithRequests reqEncoder requests (head . M.toList <$> rawResponses)
222− pure rawResponses
223− where
224− reqEncoder :: forall a. req a -> (String, String -> Maybe a)
225− reqEncoder r =
226− ( whichever @Show @req @a $ show r
227− , \x -> has @Read r $ readMaybe x
228− )
229−
230−deriveArgDict ''TestRequest
231−
232−instance Show (TestRequest a) where
233− show = \case
234− TestRequest_Reverse str -> "reverse " <> str
235− TestRequest_Increment i -> "increment " <> show i
test/Test/Run.hs−8
@@ -64,11 +64,3 @@ runApp' :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global)
6464runApp' app input = do
6565 let app' = fmap (AppOut (pure ())) . app
6666 map (map snd) <$> runApp (app' . _appIn_event) () (map (fmap That) input)
67−
68−runAppB :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global)
69− => (Event t eIn -> PerformEventT t m (Behavior t bOut))
70− -> [Maybe eIn]
71− -> IO [[bOut]]
72−runAppB app input = do
73− let app' = fmap (flip AppOut never) . app
74− map (map fst) <$> runApp (app' . _appIn_event) () (map (fmap That) input)
test/hlint.hs+8−4
@@ -1,7 +1,7 @@
11module Main where
22
33import Control.Monad
4−import Language.Haskell.HLint (hlint)
4+import Language.Haskell.HLint3 (hlint)
55import System.Directory
66import System.Exit (exitFailure, exitSuccess)
77import System.FilePath
@@ -20,10 +20,7 @@ main = do
2020 , "--ignore=Use >=>"
2121 , "--ignore=Use ."
2222 , "--ignore=Use unless"
23− , "--ignore=Reduce duplication"
2423 , "--cpp-define=USE_TEMPLATE_HASKELL"
25− , "--cpp-define=DEBUG"
26− , "--ignore=Use tuple-section"
2724 ]
2825 recurseInto = and <$> sequence
2926 [ fileType ==? Directory
@@ -31,9 +28,16 @@ main = do
3128 ]
3229 matchFile = and <$> sequence
3330 [ extension ==? ".hs"
31+ , let notElem' = liftOp notElem
32+ in filePath `notElem'` filePathExceptions pwd
3433 ]
3534 files <- find recurseInto matchFile (pwd </> "src") --TODO: Someday fix all hints in tests, etc.
3635 ideas <- fmap concat $ forM files $ \f -> do
3736 putStr $ "linting file " ++ drop (length pwd + 1) f ++ "... "
3837 runHlint f
3938 if null ideas then exitSuccess else exitFailure
39+
40+filePathExceptions :: FilePath -> [FilePath]
41+filePathExceptions pwd = map (pwd </>) $
42+ [ "src/Data/AppendMap.hs" -- parse error when hlint runs
43+ ]
test/semantics.hs+2
@@ -45,3 +45,5 @@ main = do
4545 ]
4646
4747 makeGroup name tests = first (\test -> intercalate "/" [name, test]) <$> tests
48+
49+