git.iko.soy/reflex
on 6d57892 help sign in
90891e1
swap
0 ahead, 448 behind
73 files changed+2140−2778
since splitsnapshots
unifiedsplit
.github/workflows/haskell.yml−41 CONTRIBUTING.md−66 ChangeLog.md+6−147 Quickref.md+12−16 README.md+16−15 cabal.haskell-ci−23 cabal.project−1 default.nix+39 dep/reflex-platform/default.nix−7 dep/reflex-platform/github.json−7 hydra.json+29 jobsets.nix+70 reflex-platform.nix+8 reflex.cabal+56−188 release.nix+7−56 src/Control/Monad/ReaderIO.hs−60 src/Data/AppendMap.hs+11−24 src/Data/FastMutableIntMap.hs+2−23 src/Data/FastWeakBag.hs+5−10 src/Data/Functor/Misc.hs+244 src/Data/Map/Misc.hs+1−1 src/Data/WeakBag.hs+3−8 src/Reflex/Adjustable/Class.hs+6−33 src/Reflex/BehaviorWriter/Base.hs+7−16 src/Reflex/BehaviorWriter/Class.hs+6−11 src/Reflex/Class.hs+49−250 src/Reflex/Collection.hs+1−8 src/Reflex/Dynamic.hs+13−26 src/Reflex/Dynamic/TH.hs+1−1 src/Reflex/DynamicWriter/Base.hs+5−14 src/Reflex/DynamicWriter/Class.hs+2−1 src/Reflex/EventWriter/Base.hs+6−17 src/Reflex/EventWriter/Class.hs+1 src/Reflex/FastWeak.hs−10 src/Reflex/FunctorMaybe.hs−2 src/Reflex/Host/Class.hs+1 src/Reflex/Host/Headless.hs−128 src/Reflex/Network.hs+1−1 src/Reflex/NotReady/Class.hs+1 src/Reflex/Patch.hs+46 src/Reflex/Patch/Class.hs+34 src/Reflex/Patch/DMap.hs+82 src/Reflex/Patch/DMapWithMove.hs+364 src/Reflex/Patch/IntMap.hs+67 src/Reflex/Patch/Map.hs+63 src/Reflex/Patch/MapWithMove.hs+270 src/Reflex/PerformEvent/Base.hs+1−3 src/Reflex/PerformEvent/Class.hs+2−6 src/Reflex/PostBuild/Base.hs+1−2 src/Reflex/PostBuild/Class.hs+2 src/Reflex/Profiled.hs+18−80 src/Reflex/Pure.hs+18−27 src/Reflex/Query/Base.hs+41−43 src/Reflex/Query/Class.hs+8−67 src/Reflex/Requester/Base.hs+30−99 src/Reflex/Requester/Class.hs+1 src/Reflex/Spider/Internal.hs+447−739 src/Reflex/TriggerEvent/Base.hs−2 src/Reflex/TriggerEvent/Class.hs+1−6 src/Reflex/Widget/Basic.hs+1−1 src/Reflex/Workflow.hs+2−2 test/Adjustable.hs−62 test/DebugCycles.hs−171 test/EventWriterT.hs+4−24 test/GC.hs+5−6 test/Headless.hs−10 test/QueryT.hs+1−5 test/Reflex/Bench/Focused.hs−12 test/Reflex/Plan/Pure.hs−1 test/Reflex/Test/CrossImpl.hs+8−18 test/Reflex/Test/Micro.hs+2−8 test/RequesterT.hs+4−170 test/hlint.hs+8−3
.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
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.md+6−147
@@ -1,151 +1,10 @@
11# Revision history for reflex
22
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−
1353## 0.6.0.0 -- 2019-03-20
1364
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.
5+* Deprecate FunctorMaybe in favor of Data.Witherable.Filterable. We still export fmapMaybe, ffilter, etc., but they all rely on Filterable now.
6+* Rename MonadDynamicWriter to DynamicWriter and add a deprecation for the old name.
7+* Remove many deprecated functions
8+* Add a Num instance for Dynamic
9+* Add matchRequestsWithResponses to make it easier to use Requester with protocols that don't do this matching for you
10+* Add withRequesterT to map functions over the request and response of a RequesterT
Quickref.md+12−16
@@ -54,7 +54,6 @@ 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)
@@ -167,7 +166,7 @@ For Events, the returned Event fires whenever the latest Event supplied by the w
167166-- Flatten Behavior-of-Event to Event. Old Event is used during switchover.
168167[ ] switch :: Behavior (Event a) -> Event a
169168
170−-- Flatten Dynamic-of-Event to Event. New Event is used immediately.
169+-- Flatten Dyanmic-of-Event to Event. New Event is used immediately.
171170[ ] switchDyn :: Dynamic (Event a) -> Event a
172171
173172-- Flatten Event-of-Event to Event that fires when both wrapper AND new Event fire.
@@ -199,7 +198,7 @@ For Events, the returned Event fires whenever the latest Event supplied by the w
199198The functions mentioned above are used to create a static FRP network.
200199There 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.
201200
202−The typeclasses and their associated annotations include:
201+Th typeclasses and their associated annotations include:
203202
204203- `PostBuild`
205204 Fire an Event when an FRP network has been set up.
@@ -207,7 +206,7 @@ The typeclasses and their associated annotations include:
207206 [B] -- Function runs in any monad supporting PostBuild
208207 ```
209208
210−- `Adjustable`
209+- `Adjustable`
211210 Use Events to add or remove pieces of an FRP network.
212211 ```haskell
213212 [A] -- Function runs in any monad supporting Adjustable
@@ -272,7 +271,7 @@ The typeclasses and their associated annotations include:
272271```haskell
273272-- Run side-effecting actions in Event when it occurs; returned Event contains
274273-- results. Side effects run in the (Performable m) monad which is associated with
275−-- the (PerformEvent t m) typeclass constraint.
274+-- the (PerformEvent t m) typeclass constraint.
276275-- This allows for working with IO when a ((MonadIO (Performable m)) constraint is available.
277276[P] performEvent :: Event (Performable m a ) -> m (Event a)
278277
@@ -296,20 +295,17 @@ The typeclasses and their associated annotations include:
296295## Networks
297296
298297```haskell
299−-- Functions from Reflex.Adjustable / Reflex.Network used to deal with Dynamics/Events carrying (m a)
298+-- Functions from Reflex.Network used to deal with Dynamics/Events carrying (m a)
300299
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,
300+-- Given a Dynamic of network-creating actions, create a network that is recreated whenever the Dynamic updates.
301+-- The returned Event of network results occurs when the Dynamic does. Note: Often, the type a is an Event,
305302-- 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)
303+[P,A] networkView :: Dynamic (m a) -> m (Event a)
307304
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
305+-- Given an initial network and an Event of network-creating actions, create a network that is recreated whenever the
306+-- Event fires. The returned Dynamic of network results occurs when the Event does. Note: Often, the type a is an
310307-- 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)
308+[H,A] networkHold :: m a -> Event (m a) -> m (Dynamic a)
312309
313310-- 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−```
311+[P,A] untilReady :: m a -> m b -> m (a, Event b)
README.md+16−15
@@ -1,23 +1,24 @@
1−# [Reflex](https://reflex-frp.org/)
1+## [Reflex](https://reflex-frp.org/)
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 a 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+A summary of Reflex functions is available in the [quick reference](Quickref.md).
89
9−**Visit https://reflex-frp.org for more information, tutorials, documentation and [examples](https://examples.reflex-frp.org/).**
10+**Visit https://reflex-frp.org/ for more information, tutorials, documentation and [examples](https://examples.reflex-frp.org/).**
1011
11−## Resources
12+### 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)
20+
21+### Hacking
22+
23+Use the `./scripts/hack-on reflex` script in [Reflex Platform](https://github.com/reflex-frp/reflex-platform) to checkout the source code of `reflex` locally in `reflex-platform/reflex` directory.
24+Then do modifications to the source in place, and use the `./try-reflex` or `./scripts/work-on` scripts to create the shell to test your changes.
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+39
@@ -0,0 +1,39 @@
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+, monoidal-containers, witherable
10+, useTemplateHaskell ? true
11+}:
12+mkDerivation {
13+ pname = "reflex";
14+ version = "0.5.0.1";
15+ src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.;
16+ libraryHaskellDepends = [
17+ base bifunctors containers dependent-map dependent-sum
18+ exception-transformers lens
19+ MemoTrie monad-control mtl primitive ref-tf semigroupoids
20+ semigroups stm syb template-haskell these transformers
21+ transformers-compat prim-uniq
22+ base bifunctors containers deepseq dependent-map dependent-sum
23+ mtl ref-tf split transformers data-default
24+ random time unbounded-delays monoidal-containers witherable
25+ ] ++ (if ghc.isGhcjs or false then [
26+ ghcjs-base
27+ ] else []) ++ (if !useTemplateHaskell then [] else [
28+ haskell-src-exts haskell-src-meta
29+ ]);
30+ testHaskellDepends = if ghc.isGhcjs or false then [] else [
31+ hlint filepath directory filemanip
32+ ];
33+ configureFlags = if useTemplateHaskell then [] else [
34+ "-f-use-template-haskell"
35+ ];
36+ homepage = "https://github.com/reflex-frp/reflex";
37+ description = "Higher-order Functional Reactive Programming";
38+ license = stdenv.lib.licenses.bsd3;
39+}
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−}
hydra.jsonnew file+29
@@ -0,0 +1,29 @@
1+{
2+ "enabled": 1,
3+ "hidden": true,
4+ "description": "Jobsets",
5+ "nixexprinput": "src",
6+ "nixexprpath": "jobsets.nix",
7+ "checkinterval": 300,
8+ "schedulingshares": 100,
9+ "enableemail": false,
10+ "emailoverride": "",
11+ "keepnr": 10,
12+ "inputs": {
13+ "src": {
14+ "type": "git",
15+ "value": "https://github.com/reflex-frp/reflex.git develop",
16+ "emailresponsible": false
17+ },
18+ "nixpkgs": {
19+ "type": "git",
20+ "value": "https://github.com/NixOS/nixpkgs-channels nixos-unstable",
21+ "emailresponsible": false
22+ },
23+ "prs": {
24+ "type": "githubpulls",
25+ "value": "reflex-frp reflex",
26+ "emailresponsible": false
27+ }
28+ }
29+}
jobsets.nixnew file+70
@@ -0,0 +1,70 @@
1+{ prs }:
2+
3+let
4+ pkgs = (import ./reflex-platform.nix {}).nixpkgs;
5+ mkFetchGithub = value: {
6+ inherit value;
7+ type = "git";
8+ emailresponsible = false;
9+ };
10+in
11+with pkgs.lib;
12+let
13+ defaults = jobs: {
14+ inherit (jobs) description;
15+ enabled = 1;
16+ hidden = false;
17+ keepnr = 10;
18+ schedulingshares = 100;
19+ checkinterval = 120;
20+ enableemail = false;
21+ emailoverride = "";
22+ nixexprinput = "reflex";
23+ nixexprpath = "release.nix";
24+ inputs = jobs.inputs // {
25+ nixpkgs = {
26+ type = "git";
27+ value = "https://github.com/NixOS/nixpkgs-channels nixos-unstable";
28+ emailresponsible = false;
29+ };
30+ config = {
31+ type = "nix";
32+ value = "{ android_sdk.accept_license = true; }";
33+ emailresponsible = false;
34+ };
35+ };
36+ };
37+ branchJobset = branch: defaults {
38+ description = "reflex-${branch}";
39+ inputs = {
40+ reflex = {
41+ value = "https://github.com/reflex-frp/reflex ${branch}";
42+ type = "git";
43+ emailresponsible = false;
44+ };
45+ };
46+ };
47+ makePr = num: info: {
48+ name = "reflex-pr-${num}";
49+ value = defaults {
50+ description = "#${num}: ${info.title}";
51+ inputs = {
52+ reflex = {
53+ #NOTE: This should really use "pull/${num}/merge"; however, GitHub's
54+ #status checks only operate on PR heads. This creates a race
55+ #condition, which can currently only be solved by requiring PRs to be
56+ #up to date before they're merged. See
57+ #https://github.com/isaacs/github/issues/1002
58+ value = "https://github.com/reflex-frp/reflex pull/${num}/head";
59+ type = "git";
60+ emailresponsible = false;
61+ };
62+ };
63+ };
64+ };
65+ processedPrs = mapAttrs' makePr (builtins.fromJSON (builtins.readFile prs));
66+ jobsetsAttrs = processedPrs //
67+ genAttrs ["develop"] branchJobset;
68+in {
69+ jobsets = pkgs.writeText "spec.json" (builtins.toJSON jobsetsAttrs);
70+}
reflex-platform.nixnew file+8
@@ -0,0 +1,8 @@
1+let
2+ reflex-platform-src = (import <nixpkgs> {}).fetchFromGitHub {
3+ owner = "reflex-frp";
4+ repo = "reflex-platform";
5+ rev = "384cd850f3adf1d404bced2424b5f6efb0f415f2";
6+ sha256 = "1ws77prqx8khmp8j6br1ij4k2v4dlgv170r9fmg0p1jivfbn8y9d";
7+ };
8+in import reflex-platform-src
reflex.cabal+56−188
@@ -1,17 +1,7 @@
11Name: reflex
2−Version: 0.8.2.0
2+Version: 0.6
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,7 +9,7 @@ Maintainer: ryan.trinkle@gmail.com
199Stability: Experimental
2010Category: FRP
2111Build-type: Simple
22−Cabal-version: 1.22
12+Cabal-version: >=1.9.2
2313homepage: https://reflex-frp.org
2414bug-reports: https://github.com/reflex-frp/reflex/issues
2515extra-source-files:
@@ -27,10 +17,6 @@ extra-source-files:
2717 Quickref.md
2818 ChangeLog.md
2919
30−tested-with:
31− GHC ==8.4.4 || ==8.6.5 || ==8.8.1 || ==8.10.2,
32− GHCJS ==8.6
33−
3420flag use-reflex-optimizer
3521 description: Use the GHC plugin Reflex.Optimizer on some of the modules in the package. This is still experimental.
3622 default: False
@@ -51,67 +37,42 @@ flag fast-weak
5137 default: False
5238 manual: True
5339
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−
6940library
70− default-language: Haskell2010
7141 hs-source-dirs: src
7242 build-depends:
7343 MemoTrie == 0.6.*,
74− base >= 4.11 && < 4.15,
44+ base >= 4.9 && < 4.13,
7545 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,
46+ comonad,
47+ containers >= 0.5 && < 0.7,
8048 data-default >= 0.5 && < 0.8,
81− dependent-map >= 0.3 && < 0.5,
49+ dependent-map >= 0.2.4 && < 0.3,
8250 exception-transformers == 0.4.*,
8351 lens >= 4.7 && < 5,
84− mmorph >= 1.0 && < 1.2,
8552 monad-control >= 1.0.1 && < 1.1,
53+ monoidal-containers == 0.4.*,
8654 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,
55+ prim-uniq >= 0.1.0.1 && < 0.2,
56+ primitive >= 0.5 && < 0.7,
9157 random == 1.1.*,
9258 ref-tf == 0.4.*,
9359 reflection == 2.1.*,
9460 semigroupoids >= 4.0 && < 6,
61+ semigroups >= 0.16 && < 0.19,
9562 stm >= 2.4 && < 2.6,
9663 syb >= 0.5 && < 0.8,
97− time >= 1.4 && < 1.10,
98− transformers >= 0.5.6.0 && < 0.6,
64+ these >= 0.4 && < 0.7.7,
65+ time >= 1.4 && < 1.9,
66+ transformers >= 0.2,
67+ transformers-compat >= 0.3,
9968 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
69+ witherable >= 0.2 && < 0.4
10970
11071 exposed-modules:
111− Control.Monad.ReaderIO
11272 Data.AppendMap,
11373 Data.FastMutableIntMap,
11474 Data.FastWeakBag,
75+ Data.Functor.Misc,
11576 Data.Map.Misc,
11677 Data.WeakBag,
11778 Reflex,
@@ -131,9 +92,15 @@ library
13192 Reflex.FastWeak,
13293 Reflex.FunctorMaybe,
13394 Reflex.Host.Class,
134− Reflex.Host.Headless,
13595 Reflex.Network,
13696 Reflex.NotReady.Class,
97+ Reflex.Patch,
98+ Reflex.Patch.Class,
99+ Reflex.Patch.DMap,
100+ Reflex.Patch.DMapWithMove,
101+ Reflex.Patch.IntMap,
102+ Reflex.Patch.Map,
103+ Reflex.Patch.MapWithMove,
137104 Reflex.PerformEvent.Base,
138105 Reflex.PerformEvent.Class,
139106 Reflex.PostBuild.Base,
@@ -152,57 +119,38 @@ library
152119 Reflex.Widget.Basic,
153120 Reflex.Workflow
154121
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−
165122 ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively
166123
167124 if flag(debug-trace-events)
168125 cpp-options: -DDEBUG_TRACE_EVENTS
169− build-depends:
170− bytestring >= 0.10.8 && < 0.11
126+ build-depends: bytestring
171127
172128 if flag(use-reflex-optimizer)
173129 cpp-options: -DUSE_REFLEX_OPTIMIZER
174130 build-depends: ghc
175131 exposed-modules: Reflex.Optimizer
176132
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−
183133 if flag(use-template-haskell)
184134 cpp-options: -DUSE_TEMPLATE_HASKELL
185135 build-depends:
186− dependent-sum >= 0.6 && < 0.8,
187− haskell-src-exts >= 1.16 && < 1.24,
136+ dependent-sum >= 0.3 && < 0.5,
137+ haskell-src-exts >= 1.16 && < 1.21,
188138 haskell-src-meta >= 0.6 && < 0.9,
189− template-haskell >= 2.9 && < 2.17
139+ template-haskell >= 2.9 && < 2.15
190140 exposed-modules:
191141 Reflex.Dynamic.TH
192142 other-extensions: TemplateHaskell
193143 else
194144 build-depends:
195− dependent-sum >= 0.6 && < 0.8
145+ dependent-sum == 0.4.*
196146
197147 if flag(fast-weak) && impl(ghcjs)
198148 cpp-options: -DGHCJS_FAST_WEAK
199149
200150 if impl(ghcjs)
201− build-depends:
202− ghcjs-base == 0.2.*
151+ build-depends: ghcjs-base
203152
204153test-suite semantics
205− default-language: Haskell2010
206154 type: exitcode-stdio-1.0
207155 main-is: semantics.hs
208156 hs-source-dirs: test
@@ -211,14 +159,14 @@ test-suite semantics
211159 base,
212160 bifunctors,
213161 containers,
214− deepseq,
162+ deepseq >= 1.3 && < 1.5,
215163 dependent-map,
216164 dependent-sum,
217165 mtl,
218166 ref-tf,
219167 reflex,
220168 split,
221− transformers
169+ transformers >= 0.3
222170 other-modules:
223171 Reflex.Bench.Focused
224172 Reflex.Plan.Pure
@@ -228,7 +176,6 @@ test-suite semantics
228176 Reflex.TestPlan
229177
230178test-suite CrossImpl
231− default-language: Haskell2010
232179 type: exitcode-stdio-1.0
233180 main-is: Reflex/Test/CrossImpl.hs
234181 hs-source-dirs: test
@@ -238,7 +185,7 @@ test-suite CrossImpl
238185 containers,
239186 dependent-map,
240187 dependent-sum,
241− deepseq,
188+ deepseq >= 1.3 && < 1.5,
242189 mtl,
243190 transformers,
244191 ref-tf,
@@ -250,7 +197,6 @@ test-suite CrossImpl
250197 Reflex.Plan.Pure
251198
252199test-suite hlint
253− default-language: Haskell2010
254200 type: exitcode-stdio-1.0
255201 main-is: hlint.hs
256202 hs-source-dirs: test
@@ -258,21 +204,17 @@ test-suite hlint
258204 , directory
259205 , filepath
260206 , 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
207+ , hlint
265208 if impl(ghcjs)
266209 buildable: False
267210
268211test-suite EventWriterT
269− default-language: Haskell2010
270212 type: exitcode-stdio-1.0
271213 main-is: EventWriterT.hs
272214 hs-source-dirs: test
273215 build-depends: base
274216 , containers
275− , deepseq
217+ , deepseq >= 1.3 && < 1.5
276218 , dependent-map
277219 , dependent-sum
278220 , lens
@@ -281,96 +223,33 @@ test-suite EventWriterT
281223 , transformers
282224 , reflex
283225 , 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
302− , dependent-sum
303− , hspec
304− , lens
305− , mtl
306− , these
307− , transformers
308− , reflex
309− , ref-tf
310− , witherable
311− , proctest
312−
313−
314− if flag(split-these)
315− build-depends: these-lens, semialign
316−
317226 other-modules:
227+ Reflex.Test
228+ Reflex.TestPlan
229+ Reflex.Plan.Reflex
230+ Reflex.Plan.Pure
318231 Test.Run
319232
320−
321233test-suite RequesterT
322− default-language: Haskell2010
323234 type: exitcode-stdio-1.0
324235 main-is: RequesterT.hs
325236 hs-source-dirs: test
326237 build-depends: base
327− , constraints
328− , constraints-extras
329238 , containers
330− , deepseq
331− , dependent-map
239+ , deepseq >= 1.3 && < 1.5
332240 , dependent-sum
241+ , dependent-map
333242 , lens
334243 , mtl
335− , ref-tf
336− , reflex
337− , text
338244 , these
339245 , 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
365246 , reflex
366247 , ref-tf
367− , these
368−
369248 other-modules:
370− Test.Run
249+ Reflex.TestPlan
250+ Reflex.Plan.Pure
371251
372252test-suite QueryT
373− default-language: Haskell2010
374253 type: exitcode-stdio-1.0
375254 main-is: QueryT.hs
376255 hs-source-dirs: test
@@ -378,19 +257,15 @@ test-suite QueryT
378257 , containers
379258 , dependent-map
380259 , dependent-sum
381− , deepseq
260+ , deepseq >= 1.3 && < 1.5
382261 , lens
383262 , monoidal-containers
384263 , mtl
385− , patch
386264 , ref-tf
387265 , reflex
266+ , semigroups
388267 , these
389268 , transformers
390−
391− if flag(split-these)
392− build-depends: semialign, these-lens
393−
394269 other-modules:
395270 Test.Run
396271 Reflex.TestPlan
@@ -398,7 +273,6 @@ test-suite QueryT
398273 Reflex.Plan.Pure
399274
400275test-suite GC-Semantics
401− default-language: Haskell2010
402276 type: exitcode-stdio-1.0
403277 main-is: GC.hs
404278 hs-source-dirs: test
@@ -406,17 +280,14 @@ test-suite GC-Semantics
406280 , containers
407281 , dependent-sum
408282 , dependent-map
409− , deepseq
283+ , deepseq >= 1.3 && < 1.5
410284 , mtl
411− , patch
412285 , these
413286 , transformers
414287 , reflex
415288 , ref-tf
416−
417− if flag(split-these)
418− build-depends: semialign
419−
289+ if impl(ghc < 8)
290+ build-depends: semigroups
420291 other-modules:
421292 Reflex.Plan.Pure
422293 Reflex.Plan.Reflex
@@ -424,13 +295,12 @@ test-suite GC-Semantics
424295 Test.Run
425296
426297test-suite rootCleanup
427− default-language: Haskell2010
428298 type: exitcode-stdio-1.0
429299 main-is: rootCleanup.hs
430300 hs-source-dirs: test
431301 build-depends: base
432302 , containers
433− , deepseq
303+ , deepseq >= 1.3 && < 1.5
434304 , dependent-sum
435305 , mtl
436306 , reflex
@@ -442,7 +312,6 @@ test-suite rootCleanup
442312 Test.Run
443313
444314benchmark spider-bench
445− default-language: Haskell2010
446315 type: exitcode-stdio-1.0
447316 hs-source-dirs: bench test
448317 main-is: Main.hs
@@ -450,8 +319,8 @@ benchmark spider-bench
450319 build-depends:
451320 base,
452321 containers,
453− criterion,
454− deepseq,
322+ criterion >= 1.1 && < 1.6,
323+ deepseq >= 1.3 && < 1.5,
455324 dependent-map,
456325 dependent-sum,
457326 ref-tf,
@@ -460,14 +329,13 @@ benchmark spider-bench
460329 reflex,
461330 split,
462331 stm,
463− transformers
332+ transformers >= 0.3
464333 other-modules:
465334 Reflex.TestPlan
466335 Reflex.Plan.Reflex
467336 Reflex.Bench.Focused
468337
469338benchmark saulzar-bench
470− default-language: Haskell2010
471339 type: exitcode-stdio-1.0
472340 hs-source-dirs: bench test
473341 c-sources: bench-cbits/checkCapability.c
@@ -475,9 +343,9 @@ benchmark saulzar-bench
475343 ghc-options: -Wall -O2 -rtsopts -threaded
476344 build-depends:
477345 base,
478− containers,
479− criterion,
480− deepseq,
346+ containers >= 0.5 && < 0.7,
347+ criterion >= 1.1 && < 1.6,
348+ deepseq >= 1.3 && < 1.5,
481349 dependent-map,
482350 dependent-sum,
483351 loch-th,
@@ -489,7 +357,7 @@ benchmark saulzar-bench
489357 split,
490358 stm,
491359 time,
492− transformers
360+ transformers >= 0.3
493361 other-modules:
494362 Reflex.TestPlan
495363 Reflex.Plan.Reflex
release.nix+7−56
@@ -1,58 +1,9 @@
1−{ reflex-platform-fun ? import ./dep/reflex-platform
2−, supportedSystems ? ["x86_64-linux" "x86_64-darwin"]
1+{ rp ? import ./reflex-platform.nix {}
32}:
4−
53let
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; }
4+ inherit (rp.nixpkgs) lib;
5+ compilers = ["ghc8_4" "ghc8_0" "ghcjs8_4" "ghcjs8_0"];
6+in lib.genAttrs compilers (ghc: {
7+ reflex-useTemplateHaskell = rp.${ghc}.callPackage ./. { useTemplateHaskell = true; };
8+ reflex = rp.${ghc}.callPackage ./. { useTemplateHaskell = false; };
9+})
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+11−24
@@ -7,20 +7,16 @@
77{-# LANGUAGE ScopedTypeVariables #-}
88{-# LANGUAGE TypeFamilies #-}
99{-# 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.
10+-- | 'Data.Map' with a better 'Monoid' instance
11+--
12+-- 'Data.Map' has @mappend = union@, which is left-biased. AppendMap has
13+-- @mappend = unionWith mappend@ instead.
1814module Data.AppendMap
1915 ( module Data.AppendMap
2016 , module Data.Map.Monoidal
2117 ) where
2218
23−import Prelude hiding (null)
19+import Prelude hiding (map, null)
2420
2521import Data.Coerce
2622import Data.Default
@@ -30,28 +26,22 @@ import qualified Data.Map.Internal.Debug as Map (showTree, showTreeWith)
3026#else
3127import qualified Data.Map as Map (showTree, showTreeWith)
3228#endif
33−import qualified Data.Witherable as W
34−import Data.Map.Monoidal
35−import qualified Data.Map.Monoidal as MonoidalMap
36−
29+import Data.Witherable (Filterable(..))
30+import Data.Map.Monoidal (MonoidalMap(..), delete, null, empty)
31+import qualified Data.Map.Monoidal as M
3732
3833{-# DEPRECATED AppendMap "Use 'MonoidalMap' instead" #-}
39−-- | AppendMap is a synonym for 'Data.Map.Monoidal.MonoidalMap'
4034type AppendMap = MonoidalMap
4135
4236{-# DEPRECATED _unAppendMap "Use 'getMonoidalMap' instead" #-}
43−-- | A synonym for 'getMonoidalMap'
4437_unAppendMap :: MonoidalMap k v -> Map k v
4538_unAppendMap = getMonoidalMap
4639
47−-- | Pattern synonym for 'MonoidalMap'
4840pattern AppendMap :: Map k v -> MonoidalMap k v
4941pattern AppendMap m = MonoidalMap m
5042
51−#if !MIN_VERSION_witherable(0,3,2)
52−instance W.Filterable (MonoidalMap k) where
53− mapMaybe = MonoidalMap.mapMaybe
54−#endif
43+instance Filterable (MonoidalMap k) where
44+ mapMaybe = M.mapMaybe
5545
5646-- | Deletes a key, returning 'Nothing' if the result is empty.
5747nonEmptyDelete :: Ord k => k -> MonoidalMap k a -> Maybe (MonoidalMap k a)
@@ -61,7 +51,6 @@ nonEmptyDelete k vs =
6151 then Nothing
6252 else Just deleted
6353
64−-- | Like 'mapMaybe' but indicates whether the resulting container is empty
6554mapMaybeNoNull :: (a -> Maybe b)
6655 -> MonoidalMap token a
6756 -> Maybe (MonoidalMap token b)
@@ -71,12 +60,10 @@ mapMaybeNoNull f as =
7160 then Nothing
7261 else Just bs
7362
74−-- TODO: Move instances to `Data.Patch`
75−-- | Displays a 'MonoidalMap' as a tree. See 'Data.Map.Lazy.showTree' for details.
63+-- TODO: Move instances to `Reflex.Patch`
7664showTree :: forall k a. (Show k, Show a) => MonoidalMap k a -> String
7765showTree = coerce (Map.showTree :: Map k a -> String)
7866
79−-- | Displays a 'MonoidalMap' as a tree, using the supplied function to convert nodes to string.
8067showTreeWith :: forall k a. (k -> a -> String) -> Bool -> Bool -> MonoidalMap k a -> String
8168showTreeWith = coerce (Map.showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String)
8269
src/Data/FastMutableIntMap.hs+2−23
@@ -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,7 +16,6 @@ module Data.FastMutableIntMap
2116 , patchIntMapNewElements
2217 , patchIntMapNewElementsMap
2318 , getDeletions
24− , toList
2519 ) where
2620
2721--TODO: Pure JS version
@@ -35,46 +29,36 @@ import Data.Foldable (traverse_)
3529import Data.IntMap.Strict (IntMap)
3630import qualified Data.IntMap.Strict as IntMap
3731import Data.IORef
38−import Data.Patch.Class
39−import Data.Patch.IntMap
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+5−10
@@ -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.
@@ -51,7 +50,7 @@ newtype FastWeakBag a = FastWeakBag JSVal
5150#else
5251data FastWeakBag a = FastWeakBag
5352 { _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'
53+ , _weakBag_children :: {-# UNPACK #-} !(IORef (IntMap (Weak a)))
5554 }
5655#endif
5756
@@ -117,14 +116,14 @@ foreign import javascript unsafe "(function(){ for(var i = 0; i < $1.tickets.len
117116isEmpty bag = {-# SCC "isEmpty" #-} IntMap.null <$> readIORef (_weakBag_children bag)
118117#endif
119118
120−{-# INLINE traverse_ #-}
119+{-# INLINE traverse #-}
121120-- | Visit every node in the given list. If new nodes are appended during the
122121-- traversal, they will not be visited. Every live node that was in the list
123122-- when the traversal began will be visited exactly once; however, no guarantee
124123-- is made about the order of the traversal.
125−traverse_ :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m ()
124+traverse :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m ()
126125#ifdef GHCJS_FAST_WEAK
127−traverse_ wb f = do
126+traverse wb f = do
128127 let go cursor = when (not $ js_isNull cursor) $ do
129128 val <- liftIO $ js_getTicketValue cursor
130129 f $ unsafeFromRawJSVal val
@@ -135,17 +134,13 @@ foreign import javascript unsafe "$r = $1.val;" js_getTicketValue :: JSVal -> IO
135134--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
136135foreign 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
137136#else
138−traverse_ (FastWeakBag _ children) f = {-# SCC "traverse_" #-} do
137+traverse (FastWeakBag _ children) f = {-# SCC "traverse" #-} do
139138 cs <- liftIO $ readIORef children
140139 forM_ cs $ \c -> do
141140 ma <- liftIO $ deRefWeak c
142141 mapM_ f ma
143142#endif
144143
145−{-# DEPRECATED traverse "Use 'traverse_' instead" #-}
146−traverse :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m ()
147−traverse = traverse_
148−
149144-- | Remove an item from the 'FastWeakBag'; does nothing if invoked multiple times
150145-- on the same 'FastWeakBagTicket'.
151146{-# INLINE remove #-}
src/Data/Functor/Misc.hsnew file+244
@@ -0,0 +1,244 @@
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+ , ComposeMaybe (..)
42+ ) where
43+
44+import Control.Applicative ((<$>))
45+import Control.Monad.Identity
46+import Data.Dependent.Map (DMap)
47+import qualified Data.Dependent.Map as DMap
48+import Data.Dependent.Sum
49+import Data.GADT.Compare
50+import Data.GADT.Show
51+import Data.IntMap (IntMap)
52+import qualified Data.IntMap as IntMap
53+import Data.Map (Map)
54+import qualified Data.Map as Map
55+import Data.Some (Some)
56+import qualified Data.Some as Some
57+import Data.These
58+import Data.Typeable hiding (Refl)
59+
60+--------------------------------------------------------------------------------
61+-- Const2
62+--------------------------------------------------------------------------------
63+
64+-- | 'Const2' stores a value of a given type 'k' and ensures that a particular
65+-- type 'v' is always given for the last type parameter
66+data Const2 :: * -> x -> x -> * where
67+ Const2 :: k -> Const2 k v v
68+ deriving (Typeable)
69+
70+-- | Extract the value from a Const2
71+unConst2 :: Const2 k v v' -> k
72+unConst2 (Const2 k) = k
73+
74+deriving instance Eq k => Eq (Const2 k v v')
75+deriving instance Ord k => Ord (Const2 k v v')
76+deriving instance Show k => Show (Const2 k v v')
77+deriving instance Read k => Read (Const2 k v v)
78+
79+instance Show k => GShow (Const2 k v) where
80+ gshowsPrec n x@(Const2 _) = showsPrec n x
81+
82+instance (Show k, Show (f v)) => ShowTag (Const2 k v) f where
83+ showTaggedPrec (Const2 _) = showsPrec
84+
85+instance Eq k => GEq (Const2 k v) where
86+ geq (Const2 a) (Const2 b) =
87+ if a == b
88+ then Just Refl
89+ else Nothing
90+
91+instance Ord k => GCompare (Const2 k v) where
92+ gcompare (Const2 a) (Const2 b) = case compare a b of
93+ LT -> GLT
94+ EQ -> GEQ
95+ GT -> GGT
96+
97+-- | Convert a 'DMap' to a regular 'Map'
98+dmapToMap :: DMap (Const2 k v) Identity -> Map k v
99+dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList
100+
101+-- | Convert a 'DMap' to an 'IntMap'
102+dmapToIntMap :: DMap (Const2 IntMap.Key v) Identity -> IntMap v
103+dmapToIntMap = IntMap.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList
104+
105+-- | Convert a 'DMap' to a regular 'Map', applying the given function to remove
106+-- the wrapping 'Functor'
107+dmapToMapWith :: (f v -> v') -> DMap (Const2 k v) f -> Map k v'
108+dmapToMapWith f = Map.fromDistinctAscList . map (\(Const2 k :=> v) -> (k, f v)) . DMap.toAscList
109+
110+-- | Convert a regular 'Map' to a 'DMap'
111+mapToDMap :: Map k v -> DMap (Const2 k v) Identity
112+mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> Identity v) . Map.toAscList
113+
114+-- | Convert a regular 'Map', where the values are already wrapped in a functor,
115+-- to a 'DMap'
116+mapWithFunctorToDMap :: Map k (f v) -> DMap (Const2 k v) f
117+mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . Map.toAscList
118+
119+-- | Convert a regular 'IntMap', where the values are already wrapped in a
120+-- functor, to a 'DMap'
121+intMapWithFunctorToDMap :: IntMap (f v) -> DMap (Const2 IntMap.Key v) f
122+intMapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . IntMap.toAscList
123+
124+-- | Convert a 'DMap' to a regular 'Map' by forgetting the types associated with
125+-- the keys, using a function to remove the wrapping 'Functor'
126+weakenDMapWith :: (forall a. v a -> v') -> DMap k v -> Map (Some k) v'
127+weakenDMapWith f = Map.fromDistinctAscList . map (\(k :=> v) -> (Some.This k, f v)) . DMap.toAscList
128+
129+--------------------------------------------------------------------------------
130+-- WrapArg
131+--------------------------------------------------------------------------------
132+
133+-- | 'WrapArg' can be used to tag a value in one functor with a type
134+-- representing another functor. This was primarily used with dependent-map <
135+-- 0.2, in which the value type was not wrapped in a separate functor.
136+data WrapArg :: (k -> *) -> (k -> *) -> * -> * where
137+ WrapArg :: f a -> WrapArg g f (g a)
138+
139+deriving instance Eq (f a) => Eq (WrapArg g f (g' a))
140+deriving instance Ord (f a) => Ord (WrapArg g f (g' a))
141+deriving instance Show (f a) => Show (WrapArg g f (g' a))
142+deriving instance Read (f a) => Read (WrapArg g f (g a))
143+
144+instance GEq f => GEq (WrapArg g f) where
145+ geq (WrapArg a) (WrapArg b) = (\Refl -> Refl) <$> geq a b
146+
147+instance GCompare f => GCompare (WrapArg g f) where
148+ gcompare (WrapArg a) (WrapArg b) = case gcompare a b of
149+ GLT -> GLT
150+ GEQ -> GEQ
151+ GGT -> GGT
152+
153+--------------------------------------------------------------------------------
154+-- Convenience functions for DMap
155+--------------------------------------------------------------------------------
156+
157+-- | Map over all key/value pairs in a 'DMap', potentially altering the key as
158+-- well as the value. The provided function MUST preserve the ordering of the
159+-- keys, or the resulting 'DMap' will be malformed.
160+mapKeyValuePairsMonotonic :: (DSum k v -> DSum k' v') -> DMap k v -> DMap k' v'
161+mapKeyValuePairsMonotonic f = DMap.fromDistinctAscList . map f . DMap.toAscList
162+
163+{-# INLINE combineDMapsWithKey #-}
164+-- | Union two 'DMap's of different types, yielding another type. Each key that
165+-- is present in either input map will be present in the output.
166+combineDMapsWithKey :: forall f g h i.
167+ GCompare f
168+ => (forall a. f a -> These (g a) (h a) -> i a)
169+ -> DMap f g
170+ -> DMap f h
171+ -> DMap f i
172+combineDMapsWithKey f mg mh = DMap.fromList $ go (DMap.toList mg) (DMap.toList mh)
173+ where go :: [DSum f g] -> [DSum f h] -> [DSum f i]
174+ go [] hs = map (\(hk :=> hv) -> hk :=> f hk (That hv)) hs
175+ go gs [] = map (\(gk :=> gv) -> gk :=> f gk (This gv)) gs
176+ go gs@((gk :=> gv) : gs') hs@((hk :=> hv) : hs') = case gk `gcompare` hk of
177+ GLT -> (gk :=> f gk (This gv)) : go gs' hs
178+ GEQ -> (gk :=> f gk (These gv hv)) : go gs' hs'
179+ GGT -> (hk :=> f hk (That hv)) : go gs hs'
180+
181+-- | Extract the values of a 'DMap' of 'EitherTag's.
182+dmapToThese :: DMap (EitherTag a b) Identity -> Maybe (These a b)
183+dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of
184+ (Nothing, Nothing) -> Nothing
185+ (Just (Identity a), Nothing) -> Just $ This a
186+ (Nothing, Just (Identity b)) -> Just $ That b
187+ (Just (Identity a), Just (Identity b)) -> Just $ These a b
188+
189+-- | Tag type for 'Either' to use it as a 'DSum'.
190+data EitherTag l r a where
191+ LeftTag :: EitherTag l r l
192+ RightTag :: EitherTag l r r
193+ deriving (Typeable)
194+
195+deriving instance Show (EitherTag l r a)
196+deriving instance Eq (EitherTag l r a)
197+deriving instance Ord (EitherTag l r a)
198+
199+instance GEq (EitherTag l r) where
200+ geq a b = case (a, b) of
201+ (LeftTag, LeftTag) -> Just Refl
202+ (RightTag, RightTag) -> Just Refl
203+ _ -> Nothing
204+
205+instance GCompare (EitherTag l r) where
206+ gcompare a b = case (a, b) of
207+ (LeftTag, LeftTag) -> GEQ
208+ (LeftTag, RightTag) -> GLT
209+ (RightTag, LeftTag) -> GGT
210+ (RightTag, RightTag) -> GEQ
211+
212+instance GShow (EitherTag l r) where
213+ gshowsPrec _ a = case a of
214+ LeftTag -> showString "LeftTag"
215+ RightTag -> showString "RightTag"
216+
217+instance (Show l, Show r) => ShowTag (EitherTag l r) Identity where
218+ showTaggedPrec t n (Identity a) = case t of
219+ LeftTag -> showsPrec n a
220+ RightTag -> showsPrec n a
221+
222+-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.
223+eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity
224+eitherToDSum = \case
225+ Left a -> (LeftTag :=> Identity a)
226+ Right b -> (RightTag :=> Identity b)
227+
228+-- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'.
229+dsumToEither :: DSum (EitherTag a b) Identity -> Either a b
230+dsumToEither = \case
231+ (LeftTag :=> Identity a) -> Left a
232+ (RightTag :=> Identity b) -> Right b
233+
234+--------------------------------------------------------------------------------
235+-- ComposeMaybe
236+--------------------------------------------------------------------------------
237+
238+-- | We can't use @Compose Maybe@ instead of 'ComposeMaybe', because that would
239+-- make the 'f' parameter have a nominal type role. We need f to be
240+-- representational so that we can use safe 'coerce'.
241+newtype ComposeMaybe f a =
242+ ComposeMaybe { getComposeMaybe :: Maybe (f a) } deriving (Show, Eq, Ord)
243+
244+deriving instance Functor f => Functor (ComposeMaybe f)
src/Data/Map/Misc.hs+1−1
@@ -43,7 +43,7 @@ diffMap olds news = flip Map.mapMaybe (align olds news) $ \case
4343
4444-- |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@.
4545--
46−-- See also 'Data.Patch.Map' and 'Data.Patch.MapWithMove'.
46+-- See also 'Reflex.Patch.Map' and 'Reflex.Patch.MapWithMove'.
4747applyMap :: Ord k => Map k (Maybe v) -> Map k v -> Map k v
4848applyMap patch old = insertions `Map.union` (old `Map.difference` deletions)
4949 where (deletions, insertions) = Map.mapEither maybeToEither patch
src/Data/WeakBag.hs+3−8
@@ -15,7 +15,6 @@ module Data.WeakBag
1515 , singleton
1616 , insert
1717 , traverse
18− , traverse_
1918 , remove
2019 -- * Internal functions
2120 -- These will not always be available.
@@ -100,22 +99,18 @@ singleton a wbRef finalizer = {-# SCC "singleton" #-} do
10099 ticket <- insert a bag wbRef finalizer
101100 return (bag, ticket)
102101
103−{-# INLINE traverse_ #-}
102+{-# INLINE traverse #-}
104103-- | Visit every node in the given list. If new nodes are appended during the
105104-- traversal, they will not be visited. Every live node that was in the list
106105-- when the traversal began will be visited exactly once; however, no guarantee
107106-- 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
107+traverse :: MonadIO m => WeakBag a -> (a -> m ()) -> m ()
108+traverse (WeakBag _ children) f = {-# SCC "traverse" #-} do
110109 cs <- liftIO $ readIORef children
111110 forM_ cs $ \c -> do
112111 ma <- liftIO $ deRefWeak c
113112 mapM_ f ma
114113
115−{-# DEPRECATED traverse "Use 'traverse_' instead" #-}
116−traverse :: MonadIO m => WeakBag a -> (a -> m ()) -> m ()
117−traverse = traverse_
118−
119114-- | Remove an item from the 'WeakBag'; does nothing if invoked multiple times
120115-- on the same 'WeakBagTicket'.
121116{-# INLINE remove #-}
src/Reflex/Adjustable/Class.hs+6−33
@@ -3,6 +3,7 @@
33{-# LANGUAGE FlexibleInstances #-}
44{-# LANGUAGE FunctionalDependencies #-}
55{-# LANGUAGE LambdaCase #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
67{-# LANGUAGE RankNTypes #-}
78{-# LANGUAGE ScopedTypeVariables #-}
89{-# LANGUAGE TypeFamilies #-}
@@ -10,13 +11,6 @@
1011#ifdef USE_REFLEX_OPTIMIZER
1112{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
1213#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.
2014module Reflex.Adjustable.Class
2115 (
2216 -- * The Adjustable typeclass
@@ -30,8 +24,7 @@ module Reflex.Adjustable.Class
3024
3125import Control.Monad.Identity
3226import Control.Monad.Reader
33−import Data.Dependent.Map (DMap)
34−import Data.GADT.Compare (GCompare(..))
27+import Data.Dependent.Map (DMap, GCompare (..))
3528import qualified Data.Dependent.Map as DMap
3629import Data.Functor.Constant
3730import Data.Functor.Misc
@@ -40,7 +33,7 @@ import qualified Data.IntMap.Strict as IntMap
4033import Data.Map (Map)
4134
4235import Reflex.Class
43−import Data.Patch.DMapWithMove
36+import Reflex.Patch.DMapWithMove
4437
4538-- | A 'Monad' that supports adjustment over time. After an action has been
4639-- run, if the given events fire, it will adjust itself so that its net effect
@@ -101,32 +94,13 @@ instance Adjustable t m => Adjustable t (ReaderT r m) where
10194 r <- ask
10295 lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runReaderT (f k v) r) dm0 dm'
10396
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))
97+sequenceDMapWithAdjust :: (GCompare k, Adjustable t m) => DMap k m -> Event t (PatchDMap k m) -> m (DMap k Identity, Event t (PatchDMap k Identity))
11198sequenceDMapWithAdjust = traverseDMapWithKeyWithAdjust $ \_ -> fmap Identity
11299
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))
100+sequenceDMapWithAdjustWithMove :: (GCompare k, Adjustable t m) => DMap k m -> Event t (PatchDMapWithMove k m) -> m (DMap k Identity, Event t (PatchDMapWithMove k Identity))
120101sequenceDMapWithAdjustWithMove = traverseDMapWithKeyWithAdjustWithMove $ \_ -> fmap Identity
121102
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'))
103+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'))
130104mapMapWithAdjustWithMove f m0 m' = do
131105 (out0 :: DMap (Const2 k v) (Constant v'), out') <- traverseDMapWithKeyWithAdjustWithMove (\(Const2 k) (Identity v) -> Constant <$> f k v) (mapToDMap m0) (const2PatchDMapWithMoveWith Identity <$> m')
132106 return (dmapToMapWith (\(Constant v') -> v') out0, patchDMapWithMoveToPatchMapWithMoveWith (\(Constant v') -> v') <$> out')
@@ -136,5 +110,4 @@ mapMapWithAdjustWithMove f m0 m' = do
136110--------------------------------------------------------------------------------
137111
138112{-# DEPRECATED MonadAdjust "Use Adjustable instead" #-}
139−-- | Synonym for 'Adjustable'
140113type MonadAdjust = Adjustable
src/Reflex/BehaviorWriter/Base.hs+7−16
@@ -1,6 +1,6 @@
11{-|
22Module: Reflex.BehaviorWriter.Base
3−Description: Implementation of BehaviorWriter
3+Description: Implementation of MonadBehaviorWriter
44-}
55{-# LANGUAGE CPP #-}
66{-# LANGUAGE FlexibleInstances #-}
@@ -24,7 +24,6 @@ module Reflex.BehaviorWriter.Base
2424import Control.Monad.Exception
2525import Control.Monad.Identity
2626import Control.Monad.IO.Class
27−import Control.Monad.Morph
2827import Control.Monad.Reader
2928import Control.Monad.Ref
3029import Control.Monad.State.Strict
@@ -47,20 +46,9 @@ import Reflex.Query.Class
4746import Reflex.Requester.Class
4847import Reflex.TriggerEvent.Class
4948
50−-- | A basic implementation of 'BehaviorWriter'.
49+-- | A basic implementation of 'MonadBehaviorWriter'.
5150newtype 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− )
51+ deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadAsyncException, MonadException) -- The list is kept in reverse order
6452
6553-- | Run a 'BehaviorWriterT' action. The behavior writer output will be provided
6654-- along with the result of the action.
@@ -85,6 +73,9 @@ withBehaviorWriterT f dw = do
8573deriving instance MonadHold t m => MonadHold t (BehaviorWriterT t w m)
8674deriving instance MonadSample t m => MonadSample t (BehaviorWriterT t w m)
8775
76+instance MonadTrans (BehaviorWriterT t w) where
77+ lift = BehaviorWriterT . lift
78+
8879instance MonadRef m => MonadRef (BehaviorWriterT t w m) where
8980 type Ref (BehaviorWriterT t w m) = Ref m
9081 newRef = lift . newRef
@@ -98,7 +89,7 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (BehaviorWri
9889 newEventWithTrigger = lift . newEventWithTrigger
9990 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
10091
101−instance (Monad m, Monoid w, Reflex t) => BehaviorWriter t w (BehaviorWriterT t w m) where
92+instance (Monad m, Monoid w, Reflex t) => MonadBehaviorWriter t w (BehaviorWriterT t w m) where
10293 tellBehavior w = BehaviorWriterT $ modify (w :)
10394
10495instance MonadReader r m => MonadReader r (BehaviorWriterT t w m) where
src/Reflex/BehaviorWriter/Class.hs+6−11
@@ -1,31 +1,26 @@
11{-|
22Module: Reflex.BehaviorWriter.Class
3−Description: This module defines the 'BehaviorWriter' class
3+Description: This module defines the 'MonadBehaviorWriter' class
44-}
55{-# LANGUAGE CPP #-}
6−{-# LANGUAGE ConstraintKinds #-}
76{-# LANGUAGE FlexibleInstances #-}
87{-# LANGUAGE FunctionalDependencies #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
99{-# LANGUAGE UndecidableInstances #-}
1010#ifdef USE_REFLEX_OPTIMIZER
1111{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
1212#endif
1313module Reflex.BehaviorWriter.Class
14− ( MonadBehaviorWriter
15− , BehaviorWriter(..)
14+ ( MonadBehaviorWriter (..)
1615 ) where
1716
1817import Control.Monad.Reader (ReaderT, lift)
1918import Reflex.Class (Behavior)
2019
21−{-# DEPRECATED MonadBehaviorWriter "Use 'BehaviorWriter' instead" #-}
22−-- | Type synonym for 'BehaviorWriter'
23−type MonadBehaviorWriter = BehaviorWriter
24−
25−-- | 'BehaviorWriter' efficiently collects 'Behavior' values using 'tellBehavior'
20+-- | 'MonadBehaviorWriter' efficiently collects 'Behavior' values using 'tellBehavior'
2621-- and combines them monoidally to provide a 'Behavior' result.
27−class (Monad m, Monoid w) => BehaviorWriter t w m | m -> t w where
22+class (Monad m, Monoid w) => MonadBehaviorWriter t w m | m -> t w where
2823 tellBehavior :: Behavior t w -> m ()
2924
30−instance BehaviorWriter t w m => BehaviorWriter t w (ReaderT r m) where
25+instance MonadBehaviorWriter t w m => MonadBehaviorWriter t w (ReaderT r m) where
3126 tellBehavior = lift . tellBehavior
src/Reflex/Class.hs+49−250
@@ -7,6 +7,7 @@
77{-# LANGUAGE FunctionalDependencies #-}
88{-# LANGUAGE GADTs #-}
99{-# LANGUAGE LambdaCase #-}
10+{-# LANGUAGE MultiParamTypeClasses #-}
1011{-# LANGUAGE NoMonomorphismRestriction #-}
1112{-# LANGUAGE PolyKinds #-}
1213{-# LANGUAGE RankNTypes #-}
@@ -16,7 +17,6 @@
1617{-# LANGUAGE TypeFamilies #-}
1718{-# LANGUAGE TypeOperators #-}
1819{-# LANGUAGE UndecidableInstances #-}
19−{-# LANGUAGE Trustworthy #-}
2020#ifdef USE_REFLEX_OPTIMIZER
2121{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
2222#endif
@@ -29,28 +29,23 @@
2929-- convenience functions for working with 'Event's, 'Behavior's, and other
3030-- signals.
3131module Reflex.Class
32− ( module Data.Patch
32+ ( module Reflex.Patch
3333 -- * Primitives
3434 , Reflex (..)
3535 , mergeInt
3636 , coerceBehavior
3737 , coerceEvent
3838 , coerceDynamic
39− , coerceIncremental
4039 , MonadSample (..)
4140 , MonadHold (..)
4241 -- ** 'fan' related types
4342 , EventSelector (..)
44− , EventSelectorG (..)
4543 , EventSelectorInt (..)
4644 -- * Convenience functions
4745 , constDyn
4846 , pushAlways
4947 -- ** Combining 'Event's
5048 , leftmost
51− , merge
52− , mergeIncremental
53− , mergeIncrementalWithMove
5449 , mergeMap
5550 , mergeIntMap
5651 , mergeMapIncremental
@@ -65,7 +60,6 @@ module Reflex.Class
6560 , alignEventWithMaybe
6661 -- ** Breaking up 'Event's
6762 , splitE
68− , fan
6963 , fanEither
7064 , fanThese
7165 , fanMap
@@ -90,7 +84,6 @@ module Reflex.Class
9084 , gate
9185 -- ** Combining 'Dynamic's
9286 , distributeDMapOverDynPure
93− , distributeDMapOverDynPureG
9487 , distributeListOverDyn
9588 , distributeListOverDynWith
9689 , zipDyn
@@ -173,17 +166,6 @@ module Reflex.Class
173166 , slowHeadE
174167 ) where
175168
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−
187169import Control.Applicative
188170import Control.Monad.Identity
189171import Control.Monad.Reader
@@ -196,12 +178,11 @@ import Data.Align
196178import Data.Bifunctor
197179import Data.Coerce
198180import Data.Default
199−import Data.Dependent.Map (DMap)
200−import Data.Dependent.Sum (DSum (..))
181+import Data.Dependent.Map (DMap, DSum (..))
201182import qualified Data.Dependent.Map as DMap
202183import Data.Functor.Compose
203184import Data.Functor.Product
204−import Data.GADT.Compare (GEq (..), GCompare (..))
185+import Data.GADT.Compare (GEq (..), GCompare (..), (:~:) (..))
205186import Data.FastMutableIntMap (PatchIntMap)
206187import Data.Foldable
207188import Data.Functor.Bind
@@ -211,18 +192,18 @@ import Data.IntMap.Strict (IntMap)
211192import qualified Data.IntMap.Strict as IntMap
212193import Data.List.NonEmpty (NonEmpty (..))
213194import Data.Map (Map)
214−import Data.Semigroup (Semigroup (..))
215−import Data.Some (Some(Some))
195+import Data.Semigroup (Semigroup, sconcat, stimes, (<>))
196+import Data.Some (Some)
197+import qualified Data.Some as Some
216198import Data.String
217199import Data.These
218200import Data.Type.Coercion
219−import Data.Type.Equality ((:~:) (..))
220201import Data.Witherable (Filterable(..))
221202import qualified Data.Witherable as W
222203import Reflex.FunctorMaybe (FunctorMaybe)
223204import qualified Reflex.FunctorMaybe
224−import Data.Patch
225−import qualified Data.Patch.MapWithMove as PatchMapWithMove
205+import Reflex.Patch
206+import qualified Reflex.Patch.MapWithMove as PatchMapWithMove
226207
227208import Debug.Trace (trace)
228209
@@ -275,21 +256,15 @@ class ( MonadHold t (PushM t)
275256 -- | Merge a collection of events; the resulting 'Event' will only occur if at
276257 -- least one input event is occurring, and will contain all of the input keys
277258 -- 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−
259+ 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
260+ -- | Efficiently fan-out an event to many destinations. This function should
261+ -- be partially applied, and then the result applied repeatedly to create
262+ -- child events
263+ 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
288264 -- | Create an 'Event' that will occur whenever the currently-selected input
289265 -- 'Event' occurs
290266 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.
267+ -- | Create an 'Event' that will occur whenever the input event is occurring -- and its occurrence value, another 'Event', is also occurring
293268 coincidence :: Event t (Event t a) -> Event t a
294269 -- | Extract the 'Behavior' of a 'Dynamic'.
295270 current :: Dynamic t a -> Behavior t a
@@ -303,14 +278,9 @@ class ( MonadHold t (PushM t)
303278 -- that value.
304279 unsafeBuildIncremental :: Patch p => PullM t (PatchTarget p) -> Event t p -> Incremental t p
305280 -- | 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)
281+ mergeIncremental :: GCompare k => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)
310282 -- | 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)
283+ mergeIncrementalWithMove :: GCompare k => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)
314284 -- | Extract the 'Behavior' component of an 'Incremental'
315285 currentIncremental :: Patch p => Incremental t p -> Behavior t (PatchTarget p)
316286 -- | Extract the 'Event' component of an 'Incremental'
@@ -326,28 +296,10 @@ class ( MonadHold t (PushM t)
326296 -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its
327297 -- occurrence type
328298 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)
333299 mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)
334300 fanInt :: Event t (IntMap a) -> EventSelectorInt t a
335301
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−
348302--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.
351303mergeInt :: Reflex t => IntMap (Event t a) -> Event t (IntMap a)
352304mergeInt m = mergeIntIncremental $ unsafeBuildIncremental (return m) never
353305
@@ -363,12 +315,6 @@ coerceEvent = coerceWith $ eventCoercion Coercion
363315coerceDynamic :: (Reflex t, Coercible a b) => Dynamic t a -> Dynamic t b
364316coerceDynamic = coerceWith $ dynamicCoercion Coercion
365317
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−
372318-- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'. The 'Behavior'
373319-- __must__ change when and only when the 'Event' fires, such that the
374320-- 'Behavior''s value is always equal to the most recent firing of the 'Event';
@@ -421,99 +367,27 @@ class MonadSample t m => MonadHold t m where
421367 -- | Create a new 'Event' that only occurs only once, on the first occurrence of
422368 -- the supplied 'Event'.
423369 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
441370
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)
371+accumIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> p) -> PatchTarget p -> Event t b -> m (Incremental t p)
372+accumIncremental f = accumMaybeIncremental $ \v o -> Just $ f v o
373+accumMIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> PushM t p) -> PatchTarget p -> Event t b -> m (Incremental t p)
449374accumMIncremental 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)
375+accumMaybeIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> Maybe p) -> PatchTarget p -> Event t b -> m (Incremental t p)
459376accumMaybeIncremental 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)
377+accumMaybeMIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> PushM t (Maybe p)) -> PatchTarget p -> Event t b -> m (Incremental t p)
468378accumMaybeMIncremental f z e = do
469379 rec let e' = flip push e $ \o -> do
470380 v <- sample $ currentIncremental d'
471381 f v o
472382 d' <- holdIncremental z e'
473383 return d'
474−
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)
384+mapAccumIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> (p, c)) -> PatchTarget p -> Event t b -> m (Incremental t p, Event t c)
485385mapAccumIncremental 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)
386+mapAccumMIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> PushM t (p, c)) -> PatchTarget p -> Event t b -> m (Incremental t p, Event t c)
494387mapAccumMIncremental 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)
388+mapAccumMaybeIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> (Maybe p, Maybe c)) -> PatchTarget p -> Event t b -> m (Incremental t p, Event t c)
508389mapAccumMaybeIncremental 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)
390+mapAccumMaybeMIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> PushM t (Maybe p, Maybe c)) -> PatchTarget p -> Event t b -> m (Incremental t p, Event t c)
517391mapAccumMaybeMIncremental f z e = do
518392 rec let e' = flip push e $ \o -> do
519393 v <- sample $ currentIncremental d'
@@ -524,7 +398,6 @@ mapAccumMaybeMIncremental f z e = do
524398 d' <- holdIncremental z $ mapMaybe fst e'
525399 return (d', mapMaybe snd e')
526400
527−-- | A somewhat slow implementation of 'headE'
528401slowHeadE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
529402slowHeadE e = do
530403 rec be <- hold e $ fmapCheap (const never) e'
@@ -545,19 +418,6 @@ newtype EventSelector t k = EventSelector
545418 select :: forall a. k a -> Event t a
546419 }
547420
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.
561421newtype EventSelectorInt t a = EventSelectorInt { selectInt :: Int -> Event t a }
562422
563423--------------------------------------------------------------------------------
@@ -573,7 +433,6 @@ instance MonadHold t m => MonadHold t (ReaderT r m) where
573433 holdIncremental a0 = lift . holdIncremental a0
574434 buildDynamic a0 = lift . buildDynamic a0
575435 headE = lift . headE
576− now = lift now
577436
578437instance (MonadSample t m, Monoid r) => MonadSample t (WriterT r m) where
579438 sample = lift . sample
@@ -584,7 +443,6 @@ instance (MonadHold t m, Monoid r) => MonadHold t (WriterT r m) where
584443 holdIncremental a0 = lift . holdIncremental a0
585444 buildDynamic a0 = lift . buildDynamic a0
586445 headE = lift . headE
587− now = lift now
588446
589447instance MonadSample t m => MonadSample t (StateT s m) where
590448 sample = lift . sample
@@ -595,7 +453,6 @@ instance MonadHold t m => MonadHold t (StateT s m) where
595453 holdIncremental a0 = lift . holdIncremental a0
596454 buildDynamic a0 = lift . buildDynamic a0
597455 headE = lift . headE
598− now = lift now
599456
600457instance MonadSample t m => MonadSample t (ExceptT e m) where
601458 sample = lift . sample
@@ -606,7 +463,6 @@ instance MonadHold t m => MonadHold t (ExceptT e m) where
606463 holdIncremental a0 = lift . holdIncremental a0
607464 buildDynamic a0 = lift . buildDynamic a0
608465 headE = lift . headE
609− now = lift now
610466
611467instance (MonadSample t m, Monoid w) => MonadSample t (RWST r w s m) where
612468 sample = lift . sample
@@ -617,7 +473,6 @@ instance (MonadHold t m, Monoid w) => MonadHold t (RWST r w s m) where
617473 holdIncremental a0 = lift . holdIncremental a0
618474 buildDynamic a0 = lift . buildDynamic a0
619475 headE = lift . headE
620− now = lift now
621476
622477instance MonadSample t m => MonadSample t (ContT r m) where
623478 sample = lift . sample
@@ -628,7 +483,6 @@ instance MonadHold t m => MonadHold t (ContT r m) where
628483 holdIncremental a0 = lift . holdIncremental a0
629484 buildDynamic a0 = lift . buildDynamic a0
630485 headE = lift . headE
631− now = lift now
632486
633487--------------------------------------------------------------------------------
634488-- Convenience functions
@@ -678,9 +532,7 @@ instance Reflex t => Monad (Behavior t) where
678532 a >>= f = pull $ sample a >>= sample . f
679533 -- 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.
680534 return = constant
681−#if !MIN_VERSION_base(4,13,0)
682535 fail = error "Monad (Behavior t) does not support fail"
683−#endif
684536
685537instance (Reflex t, Monoid a) => Monoid (Behavior t a) where
686538 mempty = constant mempty
@@ -708,7 +560,11 @@ instance (Num a, Reflex t) => Num (Dynamic t a) where
708560instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where
709561 a <> b = pull $ liftM2 (<>) (sample a) (sample b)
710562 sconcat = pull . fmap sconcat . mapM sample
563+#if MIN_VERSION_semigroups(0,17,0)
711564 stimes n = fmap $ stimes n
565+#else
566+ times1p n = fmap $ times1p n
567+#endif
712568
713569-- | Alias for 'mapMaybe'
714570fmapMaybe :: Filterable f => (a -> Maybe b) -> f a -> f b
@@ -735,12 +591,9 @@ filterRight = mapMaybe (either (const Nothing) Just)
735591instance Reflex t => Alt (Event t) where
736592 ev1 <!> ev2 = leftmost [ev1, ev2]
737593
738−-- | 'Event' intersection. Only occurs when both events are co-incident.
594+-- | 'Event' intersection (convenient interface to 'coincidence').
739595instance 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−
596+ evf <.> evx = coincidence (fmap (<$> evx) evf)
744597
745598-- | 'Event' intersection (convenient interface to 'coincidence').
746599instance Reflex t => Bind (Event t) where
@@ -909,7 +762,11 @@ traceEventWith f = push $ \x -> trace (f x) $ return $ Just x
909762instance (Semigroup a, Reflex t) => Semigroup (Event t a) where
910763 (<>) = alignWith (mergeThese (<>))
911764 sconcat = fmap sconcat . mergeList . toList
765+#if MIN_VERSION_semigroups(0,17,0)
912766 stimes n = fmap $ stimes n
767+#else
768+ times1p n = fmap $ times1p n
769+#endif
913770
914771instance (Semigroup a, Reflex t) => Monoid (Event t a) where
915772 mempty = never
@@ -944,12 +801,7 @@ mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a)
944801mergeList [] = never
945802mergeList es = mergeWithFoldCheap' id es
946803
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'
804+unsafeMapIncremental :: (Reflex t, Patch p, Patch p') => (PatchTarget p -> PatchTarget p') -> (p -> p') -> Incremental t p -> Incremental t p'
953805unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ g <$> updatedIncremental a
954806
955807-- | Create a new 'Event' combining the map of 'Event's into an 'Event' that
@@ -1066,9 +918,6 @@ coincidencePatchMapWithMove e = fmapCheap unsafePatchMapWithMove $ coincidence $
1066918 ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Delete }
1067919 ]
1068920
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.
1072921switchHoldPromptOnlyIncremental
1073922 :: forall t m p pt w
1074923 . ( Reflex t
@@ -1093,25 +942,8 @@ switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch e0 e' = d
1093942
1094943instance Reflex t => Align (Event t) where
1095944 nil = never
1096−#if MIN_VERSION_these(0, 8, 0)
1097−instance Reflex t => Semialign (Event t) where
1098−#endif
1099945 align = alignEventWithMaybe Just
1100946
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−
1115947-- | Create a new 'Event' that only occurs if the supplied 'Event' occurs and
1116948-- the 'Behavior' is true at the time of occurrence.
1117949gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a
@@ -1151,7 +983,11 @@ zipDynWith f da db =
1151983
1152984instance (Reflex t, Semigroup a) => Semigroup (Dynamic t a) where
1153985 (<>) = zipDynWith (<>)
986+#if MIN_VERSION_semigroups(0,17,0)
1154987 stimes n = fmap $ stimes n
988+#else
989+ times1p n = fmap $ times1p n
990+#endif
1155991
1156992instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where
1157993 mconcat = distributeListOverDynWith mconcat
@@ -1162,21 +998,12 @@ instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where
1162998-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same
1163999-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators.
11641000distributeDMapOverDynPure :: 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
1001+distributeDMapOverDynPure dm = case DMap.toList dm of
11751002 [] -> constDyn DMap.empty
1176− [k :=> v] -> DMap.singleton k <$> nt v
1003+ [k :=> v] -> fmap (DMap.singleton k . Identity) v
11771004 _ ->
1178− let getInitial = DMap.traverseWithKey (\_ -> sample . current . nt) dm
1179− edmPre = mergeG getCompose $ DMap.map (Compose . updated . nt) dm
1005+ let getInitial = DMap.traverseWithKey (\_ -> fmap Identity . sample . current) dm
1006+ edmPre = merge $ DMap.map updated dm
11801007 result = unsafeBuildDynamic getInitial $ flip pushAlways edmPre $ \news -> do
11811008 olds <- sample $ current result
11821009 return $ DMap.unionWithKey (\_ _ new -> new) olds news
@@ -1188,16 +1015,7 @@ distributeListOverDyn = distributeListOverDynWith id
11881015
11891016-- | Create a new 'Dynamic' by applying a combining function to a list of 'Dynamic's
11901017distributeListOverDynWith :: 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
1018+distributeListOverDynWith f = fmap (f . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList) . distributeDMapOverDynPure . DMap.fromList . map (\(k, v) -> Const2 k :=> v) . zip [0 :: Int ..]
12011019
12021020-- | Create a new 'Event' that occurs when the first supplied 'Event' occurs
12031021-- unless the second supplied 'Event' occurs simultaneously.
@@ -1246,9 +1064,9 @@ factorEvent
12461064 -> Event t (DSum k v)
12471065 -> m (Event t (v a), Event t (DSum k (Product v (Compose (Event t) v))))
12481066factorEvent k0 kv' = do
1249− key :: Behavior t (Some k) <- hold (Some k0) $ fmapCheap (\(k :=> _) -> Some k) kv'
1067+ key :: Behavior t (Some k) <- hold (Some.This k0) $ fmapCheap (\(k :=> _) -> Some.This k) kv'
12501068 let update = flip push kv' $ \(newKey :=> newVal) -> sample key >>= \case
1251− Some oldKey -> case newKey `geq` oldKey of
1069+ Some.This oldKey -> case newKey `geq` oldKey of
12521070 Just Refl -> return Nothing
12531071 Nothing -> do
12541072 newInner <- filterEventKey newKey kv'
@@ -1458,7 +1276,7 @@ mapAccumMaybeB
14581276 -> m (Behavior t a, Event t c)
14591277mapAccumMaybeB f = mapAccumMaybeMB $ \v o -> return $ f v o
14601278
1461−-- | Like 'mapAccumMaybeB' except that the combining function is a 'PushM' action.
1279+-- | LIke 'mapAccumMaybeB' except that the combining function is a 'PushM' action.
14621280{-# INLINE mapAccumMaybeMB #-}
14631281mapAccumMaybeMB :: (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)
14641282mapAccumMaybeMB f z e = do
@@ -1649,23 +1467,6 @@ fmapCheap f = pushCheap $ return . Just . f
16491467tagCheap :: Reflex t => Behavior t b -> Event t a -> Event t b
16501468tagCheap b = pushAlwaysCheap $ \_ -> sample b
16511469
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−
16691470-- | A "cheap" version of 'mergeWithCheap'. See the performance note on 'pushCheap'.
16701471{-# INLINE mergeWithCheap #-}
16711472mergeWithCheap :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a
@@ -1690,10 +1491,8 @@ mergeWithFoldCheap' f es =
16901491--------------------------------------------------------------------------------
16911492
16921493{-# 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'
16941494switchPromptly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)
16951495switchPromptly = switchHoldPromptly
16961496{-# 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'
16981497switchPromptOnly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)
16991498switchPromptOnly = switchHoldPromptOnly
src/Reflex/Collection.hs+1−8
@@ -27,13 +27,6 @@ module Reflex.Collection
2727 , simpleList
2828 ) where
2929
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−
3730import Control.Monad.Identity
3831import Data.Align
3932import Data.Functor.Misc
@@ -130,7 +123,7 @@ listWithKeyShallowDiff initialVals valsChanged mkChild = do
130123 Nothing -> Just Nothing
131124
132125 -- We don't want to let spurious re-creations of items through
133− Just _ -> Nothing
126+ Just _ -> Nothing
134127 listHoldWithKey
135128 initialVals
136129 (attachWith (flip (Map.differenceWith relevantPatch))
src/Reflex/Dynamic.hs+13−26
@@ -53,12 +53,10 @@ module Reflex.Dynamic
5353 , foldDynMaybe
5454 , foldDynMaybeM
5555 , joinDynThroughMap
56− , joinDynThroughIntMap
5756 , traceDyn
5857 , traceDynWith
5958 , splitDynPure
6059 , distributeMapOverDynPure
61− , distributeIntMapOverDynPure
6260 , distributeDMapOverDynPure
6361 , distributeListOverDynPure
6462 , Demux
@@ -89,14 +87,11 @@ import Data.Align
8987import Data.Dependent.Map (DMap)
9088import qualified Data.Dependent.Map as DMap
9189import Data.Dependent.Sum (DSum (..))
92−import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))
93−import Data.IntMap (IntMap)
94−import qualified Data.IntMap as IntMap
90+import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), GOrdering (..))
9591import Data.Map (Map)
9692import Data.Maybe
9793import Data.Monoid ((<>))
9894import Data.These
99−import Data.Type.Equality ((:~:) (..))
10095
10196import Debug.Trace
10297
@@ -206,27 +201,25 @@ splitDynPure d = (fmap fst d, fmap snd d)
206201distributeMapOverDynPure :: (Reflex t, Ord k) => Map k (Dynamic t v) -> Dynamic t (Map k v)
207202distributeMapOverDynPure = fmap dmapToMap . distributeDMapOverDynPure . mapWithFunctorToDMap
208203
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−
214204-- | Convert a list with 'Dynamic' elements into a 'Dynamic' of a list with
215205-- non-'Dynamic' elements, preserving the order of the elements.
216−{-# DEPRECATED distributeListOverDynPure "Use 'distributeListOverDyn' instead" #-}
217206distributeListOverDynPure :: Reflex t => [Dynamic t v] -> Dynamic t [v]
218−distributeListOverDynPure = distributeListOverDyn
207+distributeListOverDynPure =
208+ fmap (map fromDSum . DMap.toAscList) .
209+ distributeDMapOverDynPure .
210+ DMap.fromDistinctAscList .
211+ zipWith toDSum [0..]
212+ where
213+ toDSum :: Int -> Dynamic t a -> DSum (Const2 Int a) (Dynamic t)
214+ toDSum k v = Const2 k :=> v
215+ fromDSum :: DSum (Const2 Int a) Identity -> a
216+ fromDSum (Const2 _ :=> Identity v) = v
219217
220218--TODO: Generalize this to functors other than Maps
221219-- | Combine a 'Dynamic' of a 'Map' of 'Dynamic's into a 'Dynamic'
222220-- with the current values of the 'Dynamic's in a map.
223221joinDynThroughMap :: 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 =<<)
222+joinDynThroughMap = join . fmap distributeMapOverDynPure
230223
231224-- | Print the value of the 'Dynamic' when it is first read and on each
232225-- subsequent change that is observed (as 'traceEvent'), prefixed with the
@@ -308,8 +301,6 @@ maybeDyn = fmap (fmap unpack) . eitherDyn . fmap pack
308301 Left _ -> Nothing
309302 Right a -> Just a
310303
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').
313304eitherDyn :: 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)))
314305eitherDyn = fmap (fmap unpack) . factorDyn . fmap eitherToDSum
315306 where unpack :: DSum (EitherTag a b) (Compose (Dynamic t) Identity) -> Either (Dynamic t a) (Dynamic t b)
@@ -317,9 +308,6 @@ eitherDyn = fmap (fmap unpack) . factorDyn . fmap eitherToDSum
317308 LeftTag :=> Compose a -> Left $ coerceDynamic a
318309 RightTag :=> Compose b -> Right $ coerceDynamic b
319310
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.
323311factorDyn :: forall t m k v. (Reflex t, MonadHold t m, GEq k)
324312 => Dynamic t (DSum k v) -> m (Dynamic t (DSum k (Compose (Dynamic t) v)))
325313factorDyn d = buildDynamic (sample (current d) >>= holdKey) update where
@@ -334,7 +322,6 @@ factorDyn d = buildDynamic (sample (current d) >>= holdKey) update where
334322 inner' <- filterEventKey k (updated d)
335323 inner <- holdDyn v inner'
336324 return $ k :=> Compose inner
337−
338325--------------------------------------------------------------------------------
339326-- Demux
340327--------------------------------------------------------------------------------
@@ -348,7 +335,7 @@ factorDyn d = buildDynamic (sample (current d) >>= holdKey) update where
348335--
349336-- > demuxed (demux d) k === fmap (== k) d
350337--
351−-- However, when 'demuxed' is used multiple times, the complexity is only
338+-- However, when getDemuxed is used multiple times, the complexity is only
352339-- /O(log(n))/, rather than /O(n)/ for fmap.
353340data Demux t k = Demux { demuxValue :: Behavior t k
354341 , demuxSelector :: EventSelector t (Const2 k Bool)
src/Reflex/Dynamic/TH.hs+1−1
@@ -81,7 +81,7 @@ mkDynPure = QuasiQuoter
8181 }
8282
8383mkDynExp :: String -> Q Exp
84−mkDynExp s = case Hs.parseExpWithMode Hs.defaultParseMode { Hs.extensions = [ Hs.EnableExtension Hs.TemplateHaskell ] } s of
84+mkDynExp s = case Hs.parseExpWithMode (Hs.defaultParseMode { Hs.extensions = [ Hs.EnableExtension Hs.TemplateHaskell ] }) s of
8585 Hs.ParseFailed (Hs.SrcLoc _ l c) err -> fail $ "mkDyn:" <> show l <> ":" <> show c <> ": " <> err
8686 Hs.ParseOk e -> qDynPure $ return $ everywhere (id `extT` reinstateUnqDyn) $ Hs.toExp $ everywhere (id `extT` antiE) e
8787 where TH.Name (TH.OccName occName) (TH.NameG _ _ (TH.ModName modName)) = 'unqMarker
src/Reflex/DynamicWriter/Base.hs+5−14
@@ -22,7 +22,6 @@ module Reflex.DynamicWriter.Base
2222import Control.Monad.Exception
2323import Control.Monad.Identity
2424import Control.Monad.IO.Class
25−import Control.Monad.Morph
2625import Control.Monad.Primitive
2726import Control.Monad.Reader
2827import Control.Monad.Ref
@@ -45,13 +44,16 @@ import Reflex.Class
4544import Reflex.DynamicWriter.Class
4645import Reflex.EventWriter.Class (EventWriter, tellEvent)
4746import Reflex.Host.Class
48−import qualified Data.Patch.MapWithMove as MapWithMove
47+import qualified Reflex.Patch.MapWithMove as MapWithMove
4948import Reflex.PerformEvent.Class
5049import Reflex.PostBuild.Class
5150import Reflex.Query.Class
5251import Reflex.Requester.Class
5352import Reflex.TriggerEvent.Class
5453
54+instance MonadTrans (DynamicWriterT t w) where
55+ lift = DynamicWriterT . lift
56+
5557mapIncrementalMapValues :: (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')
5658mapIncrementalMapValues f = unsafeMapIncremental (fmap f) (fmap f)
5759
@@ -88,18 +90,7 @@ mergeDynIncrementalWithMove a = unsafeBuildIncremental (mapM (sample . current)
8890
8991-- | A basic implementation of 'DynamicWriter'.
9092newtype 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− )
93+ deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadAsyncException, MonadException) -- The list is kept in reverse order
10394
10495deriving instance MonadHold t m => MonadHold t (DynamicWriterT t w m)
10596deriving instance MonadSample t m => MonadSample t (DynamicWriterT t w m)
src/Reflex/DynamicWriter/Class.hs+2−1
@@ -3,6 +3,7 @@
33{-# LANGUAGE CPP #-}
44{-# LANGUAGE FlexibleInstances #-}
55{-# LANGUAGE FunctionalDependencies #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
67{-# LANGUAGE UndecidableInstances #-}
78#ifdef USE_REFLEX_OPTIMIZER
89{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
@@ -16,7 +17,6 @@ import Control.Monad.Reader (ReaderT, lift)
1617import Reflex.Class (Dynamic)
1718
1819{-# DEPRECATED MonadDynamicWriter "Use 'DynamicWriter' instead" #-}
19−-- | Type synonym for 'DynamicWriter'
2020type MonadDynamicWriter = DynamicWriter
2121
2222-- | 'MonadDynamicWriter' efficiently collects 'Dynamic' values using 'tellDyn'
@@ -26,3 +26,4 @@ class (Monad m, Monoid w) => DynamicWriter t w m | m -> t w where
2626
2727instance DynamicWriter t w m => DynamicWriter t w (ReaderT r m) where
2828 tellDyn = lift . tellDyn
29+
src/Reflex/EventWriter/Base.hs+6−17
@@ -35,14 +35,12 @@ import Reflex.TriggerEvent.Class
3535
3636import Control.Monad.Exception
3737import Control.Monad.Identity
38−import Control.Monad.Morph
3938import Control.Monad.Primitive
4039import Control.Monad.Reader
4140import Control.Monad.Ref
4241import Control.Monad.State.Strict
43−import Data.Dependent.Map (DMap)
42+import Data.Dependent.Map (DMap, DSum (..))
4443import qualified Data.Dependent.Map as DMap
45−import Data.Dependent.Sum (DSum (..))
4644import Data.Functor.Compose
4745import Data.Functor.Misc
4846import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))
@@ -54,7 +52,7 @@ import qualified Data.Map as Map
5452import Data.Semigroup
5553import Data.Some (Some)
5654import Data.Tuple
57−import Data.Type.Equality
55+import Data.Type.Equality hiding (apply)
5856
5957import Unsafe.Coerce
6058
@@ -98,17 +96,7 @@ data EventWriterState t w = EventWriterState
9896
9997-- | A basic implementation of 'EventWriter'.
10098newtype 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− )
99+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
112100
113101-- | Run a 'EventWriterT' action.
114102runEventWriterT :: forall t m w a. (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)
@@ -128,6 +116,9 @@ instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m
128116 , _eventWriterState_told = (tellId myId :=> w) : _eventWriterState_told old
129117 }
130118
119+instance MonadTrans (EventWriterT t w) where
120+ lift = EventWriterT . lift
121+
131122instance MonadSample t m => MonadSample t (EventWriterT t w m) where
132123 sample = lift . sample
133124
@@ -142,8 +133,6 @@ instance MonadHold t m => MonadHold t (EventWriterT t w m) where
142133 buildDynamic a0 = lift . buildDynamic a0
143134 {-# INLINABLE headE #-}
144135 headE = lift . headE
145− {-# INLINABLE now #-}
146− now = lift now
147136
148137instance (Reflex t, Adjustable t m, MonadHold t m, Semigroup w) => Adjustable t (EventWriterT t w m) where
149138 runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
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−10
@@ -151,16 +151,6 @@ getFastWeakTicket w = do
151151
152152-- | Create a 'FastWeakTicket' directly from a value, creating a 'FastWeak' in the process
153153-- 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 #-}
164154mkFastWeakTicket :: a -> IO (FastWeakTicket a)
165155-- 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
166156-- associated FastWeak to actually be weak
src/Reflex/FunctorMaybe.hs−2
@@ -1,8 +1,6 @@
11{-# LANGUAGE CPP #-}
2−#if MIN_VERSION_base(4,9,0)
32{-# LANGUAGE GeneralizedNewtypeDeriving #-}
43{-# LANGUAGE StandaloneDeriving #-}
5−#endif
64
75-- |
86-- Module:
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+1−1
@@ -20,7 +20,7 @@ import Reflex.NotReady.Class
2020import Reflex.PostBuild.Class
2121
2222-- | 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.
23+-- The returned Event of network results fires when the 'Dynamic' updates.
2424-- Note: Often, the type 'a' is an Event, in which case the return value is an Event-of-Events, where the outer 'Event' fires
2525-- when switching networks. Such an 'Event' would typically be flattened (via 'switchPromptly').
2626networkView :: (NotReady t m, Adjustable t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)
src/Reflex/NotReady/Class.hs+1
@@ -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
src/Reflex/Patch.hsnew file+46
@@ -0,0 +1,46 @@
1+{-# LANGUAGE TypeFamilies #-}
2+-- |
3+-- Module:
4+-- Reflex.Patch
5+-- Description:
6+-- This module defines the 'Patch' class, which is used by Reflex to manage
7+-- changes to 'Reflex.Class.Incremental' values.
8+module Reflex.Patch
9+ ( module Reflex.Patch
10+ , module X
11+ ) where
12+
13+import Reflex.Patch.Class as X
14+import Reflex.Patch.DMap as X hiding (getDeletions)
15+import Reflex.Patch.DMapWithMove as X (PatchDMapWithMove, const2PatchDMapWithMoveWith, mapPatchDMapWithMove,
16+ patchDMapWithMoveToPatchMapWithMoveWith,
17+ traversePatchDMapWithMoveWithKey, unPatchDMapWithMove,
18+ unsafePatchDMapWithMove, weakenPatchDMapWithMoveWith)
19+import Reflex.Patch.IntMap as X hiding (getDeletions)
20+import Reflex.Patch.Map as X
21+import Reflex.Patch.MapWithMove as X (PatchMapWithMove, patchMapWithMoveNewElements,
22+ patchMapWithMoveNewElementsMap, unPatchMapWithMove,
23+ unsafePatchMapWithMove)
24+import Data.Map.Monoidal (MonoidalMap)
25+import Data.Semigroup (Semigroup (..), (<>))
26+
27+-- | A 'Group' is a 'Monoid' where every element has an inverse.
28+class (Semigroup q, Monoid q) => Group q where
29+ negateG :: q -> q
30+ (~~) :: q -> q -> q
31+ r ~~ s = r <> negateG s
32+
33+-- | An 'Additive' 'Semigroup' is one where (<>) is commutative
34+class Semigroup q => Additive q where
35+
36+-- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type.
37+newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }
38+
39+instance Additive p => Patch (AdditivePatch p) where
40+ type PatchTarget (AdditivePatch p) = p
41+ apply (AdditivePatch p) q = Just $ p <> q
42+
43+instance (Ord k, Group q) => Group (MonoidalMap k q) where
44+ negateG = fmap negateG
45+
46+instance (Ord k, Additive q) => Additive (MonoidalMap k q)
src/Reflex/Patch/Class.hsnew file+34
@@ -0,0 +1,34 @@
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+import Data.Semigroup (Semigroup(..))
8+
9+-- | A 'Patch' type represents a kind of change made to a datastructure.
10+--
11+-- If an instance of 'Patch' is also an instance of 'Semigroup', it should obey
12+-- the law that @applyAlways (f <> g) == applyAlways f . applyAlways g@.
13+class Patch p where
14+ type PatchTarget p :: *
15+ -- | Apply the patch @p a@ to the value @a@. If no change is needed, return
16+ -- 'Nothing'.
17+ apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
18+
19+-- | Apply a 'Patch'; if it does nothing, return the original value
20+applyAlways :: Patch p => p -> PatchTarget p -> PatchTarget p
21+applyAlways p t = fromMaybe t $ apply p t
22+
23+-- | 'Identity' can be used as a 'Patch' that always fully replaces the value
24+instance Patch (Identity a) where
25+ type PatchTarget (Identity a) = a
26+ apply (Identity a) _ = Just a
27+
28+-- | Like '(.)', but composes functions that return patches rather than
29+-- functions that return new values. The Semigroup instance for patches must
30+-- apply patches right-to-left, like '(.)'.
31+composePatchFunctions :: (Patch p, Semigroup p) => (PatchTarget p -> p) -> (PatchTarget p -> p) -> PatchTarget p -> p
32+composePatchFunctions g f a =
33+ let fp = f a
34+ in g (applyAlways fp a) <> fp
src/Reflex/Patch/DMap.hsnew file+82
@@ -0,0 +1,82 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE LambdaCase #-}
3+{-# LANGUAGE PolyKinds #-}
4+{-# LANGUAGE Rank2Types #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE StandaloneDeriving #-}
7+{-# LANGUAGE TypeFamilies #-}
8+-- | 'Patch'es on 'DMap' that consist only of insertions (or overwrites) and deletions.
9+module Reflex.Patch.DMap where
10+
11+import Reflex.Patch.Class
12+import Reflex.Patch.IntMap
13+import Reflex.Patch.Map
14+
15+import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
16+import qualified Data.Dependent.Map as DMap
17+import Data.Functor.Constant
18+import Data.Functor.Misc
19+import qualified Data.IntMap as IntMap
20+import qualified Data.Map as Map
21+import Data.Semigroup (Semigroup (..))
22+import Data.Some (Some)
23+
24+-- | A set of changes to a 'DMap'. Any element may be inserted/updated or deleted.
25+-- Insertions are represented as @'ComposeMaybe' (Just value)@,
26+-- while deletions are represented as @'ComposeMaybe' Nothing@.
27+newtype PatchDMap k v = PatchDMap { unPatchDMap :: DMap k (ComposeMaybe v) }
28+
29+deriving instance GCompare k => Semigroup (PatchDMap k v)
30+
31+deriving instance GCompare k => Monoid (PatchDMap k v)
32+
33+-- | Apply the insertions or deletions to a given 'DMap'.
34+instance GCompare k => Patch (PatchDMap k v) where
35+ type PatchTarget (PatchDMap k v) = DMap k v
36+ 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?
37+ where insertions = DMap.mapMaybeWithKey (const $ getComposeMaybe) diff
38+ deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getComposeMaybe) diff
39+ nothingToJust = \case
40+ Nothing -> Just $ Constant ()
41+ Just _ -> Nothing
42+
43+-- | Map a function @v a -> v' a@ over any inserts/updates in the given
44+-- @'PatchDMap' k v@ to produce a @'PatchDMap' k v'@.
45+mapPatchDMap :: (forall a. v a -> v' a) -> PatchDMap k v -> PatchDMap k v'
46+mapPatchDMap f (PatchDMap p) = PatchDMap $ DMap.map (ComposeMaybe . fmap f . getComposeMaybe) p
47+
48+-- | Map an effectful function @v a -> f (v' a)@ over any inserts/updates in the given
49+-- @'PatchDMap' k v@ to produce a @'PatchDMap' k v'@.
50+traversePatchDMap :: Applicative f => (forall a. v a -> f (v' a)) -> PatchDMap k v -> f (PatchDMap k v')
51+traversePatchDMap f = traversePatchDMapWithKey $ const f
52+
53+-- | Map an effectful function @k a -> v a -> f (v' a)@ over any inserts/updates
54+-- in the given @'PatchDMap' k v@ to produce a @'PatchDMap' k v'@.
55+traversePatchDMapWithKey :: Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v')
56+traversePatchDMapWithKey f (PatchDMap p) = PatchDMap <$> DMap.traverseWithKey (\k (ComposeMaybe v) -> ComposeMaybe <$> traverse (f k) v) p
57+
58+-- | Weaken a @'PatchDMap' k v@ to a @'PatchMap' (Some k) v'@ using a function
59+-- @v a -> v'@ to weaken each value contained in the patch.
60+weakenPatchDMapWith :: (forall a. v a -> v') -> PatchDMap k v -> PatchMap (Some k) v'
61+weakenPatchDMapWith f (PatchDMap p) = PatchMap $ weakenDMapWith (fmap f . getComposeMaybe) p
62+
63+-- | Convert a weak @'PatchDMap' ('Const2' k a) v@ where the @a@ is known by way of
64+-- the @Const2@ into a @'PatchMap' k v'@ using a rank 1 function @v a -> v'@.
65+patchDMapToPatchMapWith :: (v a -> v') -> PatchDMap (Const2 k a) v -> PatchMap k v'
66+patchDMapToPatchMapWith f (PatchDMap p) = PatchMap $ dmapToMapWith (fmap f . getComposeMaybe) p
67+
68+-- | Convert a @'PatchMap' k v@ into a @'PatchDMap' ('Const2' k a) v'@ using a function @v -> v' a@.
69+const2PatchDMapWith :: forall k v v' a. (v -> v' a) -> PatchMap k v -> PatchDMap (Const2 k a) v'
70+const2PatchDMapWith f (PatchMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
71+ where g :: (k, Maybe v) -> DSum (Const2 k a) (ComposeMaybe v')
72+ g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)
73+
74+-- | Convert a @'PatchIntMap' v@ into a @'PatchDMap' ('Const2' Int a) v'@ using a function @v -> v' a@.
75+const2IntPatchDMapWith :: forall v f a. (v -> f a) -> PatchIntMap v -> PatchDMap (Const2 IntMap.Key a) f
76+const2IntPatchDMapWith f (PatchIntMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> IntMap.toAscList p
77+ where g :: (IntMap.Key, Maybe v) -> DSum (Const2 IntMap.Key a) (ComposeMaybe f)
78+ g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)
79+
80+-- | Get the values that will be replaced or deleted if the given patch is applied to the given 'DMap'.
81+getDeletions :: GCompare k => PatchDMap k v -> DMap k v' -> DMap k v'
82+getDeletions (PatchDMap p) m = DMap.intersectionWithKey (\_ v _ -> v) m p
src/Reflex/Patch/DMapWithMove.hsnew file+364
@@ -0,0 +1,364 @@
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, 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, 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+-- |Test whether two @'PatchDMapWithMove' k v@ contain the same patch operations.
108+instance EqTag k (NodeInfo k v) => Eq (PatchDMapWithMove k v) where
109+ PatchDMapWithMove a == PatchDMapWithMove b = a == b
110+
111+-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
112+data Pair1 f g a = Pair1 (f a) (g a)
113+
114+-- |Helper data structure used for composing patches using the monoid instance.
115+data Fixup k v a
116+ = Fixup_Delete
117+ | Fixup_Update (These (From k v a) (To k a))
118+
119+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
120+instance GCompare k => Semigroup (PatchDMapWithMove k v) where
121+ PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m
122+ where
123+ connections = DMap.toList $ DMap.intersectionWithKey (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b)) ma mb
124+ h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)]
125+ h (_ :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case (mToAfter, editBefore) of
126+ (Just toAfter, From_Move fromBefore)
127+ | isJust $ fromBefore `geq` toAfter
128+ -> [toAfter :=> Fixup_Delete]
129+ | otherwise
130+ -> [ toAfter :=> Fixup_Update (This editBefore)
131+ , fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))
132+ ]
133+ (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
134+ (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)]
135+ (Nothing, _) -> []
136+ mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
137+ mergeFixups _ (Fixup_Update a) (Fixup_Update b)
138+ | This x <- a, That y <- b
139+ = Fixup_Update $ These x y
140+ | That y <- a, This x <- b
141+ = Fixup_Update $ These x y
142+ mergeFixups _ _ _ = error "PatchDMapWithMove: incompatible fixups"
143+ fixups = DMap.fromListWithKey mergeFixups $ concatMap h connections
144+ combineNodeInfos _ nia nib = NodeInfo
145+ { _nodeInfo_from = _nodeInfo_from nia
146+ , _nodeInfo_to = _nodeInfo_to nib
147+ }
148+ applyFixup _ ni = \case
149+ Fixup_Delete -> Nothing
150+ Fixup_Update u -> Just $ NodeInfo
151+ { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u
152+ , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
153+ }
154+ m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups
155+ getHere :: These a b -> Maybe a
156+ getHere = \case
157+ This a -> Just a
158+ These a _ -> Just a
159+ That _ -> Nothing
160+ getThere :: These a b -> Maybe b
161+ getThere = \case
162+ This _ -> Nothing
163+ These _ b -> Just b
164+ That b -> Just b
165+
166+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
167+instance GCompare k => Monoid (PatchDMapWithMove k v) where
168+ mempty = PatchDMapWithMove mempty
169+ mappend = (<>)
170+
171+{-
172+mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
173+PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
174+ where
175+ 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
176+ removeRedundantDst toKey (From_Move fromKey) | isJust (toKey `geq` fromKey) = Nothing
177+ removeRedundantDst _ a = Just a
178+ f :: forall a. k a -> From k v a -> Maybe (From k v a)
179+ f toKey _ = removeRedundantDst toKey $ case getDstAction toKey dstAfter of
180+ From_Move fromKey -> getDstAction fromKey dstBefore
181+ nonMove -> nonMove
182+ dst = DMap.mapMaybeWithKey f $ DMap.union dstAfter dstBefore
183+ getSrcAction k m = fromMaybe (ComposeMaybe $ Just k) $ DMap.lookup k m
184+ removeRedundantSrc fromKey (ComposeMaybe (Just toKey)) | isJust (fromKey `geq` toKey) = Nothing
185+ removeRedundantSrc _ a = Just a
186+ g :: forall a. k a -> ComposeMaybe k a -> Maybe (ComposeMaybe k a)
187+ g fromKey _ = removeRedundantSrc fromKey $ case getSrcAction fromKey srcBefore of
188+ ComposeMaybe Nothing -> ComposeMaybe Nothing
189+ ComposeMaybe (Just toKeyBefore) -> getSrcAction toKeyBefore srcAfter
190+ src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
191+-}
192+
193+-- |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'.
194+insertDMapKey :: k a -> v a -> PatchDMapWithMove k v
195+insertDMapKey k v =
196+ PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing)
197+
198+-- |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:
199+--
200+-- @
201+-- 'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap))
202+-- @
203+moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
204+moveDMapKey src dst = case src `geq` dst of
205+ Nothing -> PatchDMapWithMove $ DMap.fromList
206+ [ dst :=> NodeInfo (From_Move src) (ComposeMaybe Nothing)
207+ , src :=> NodeInfo From_Delete (ComposeMaybe $ Just dst)
208+ ]
209+ Just _ -> mempty
210+
211+-- |Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
212+--
213+-- @
214+-- let aMay = DMap.lookup a dmap
215+-- bMay = DMap.lookup b dmap
216+-- in maybe id (DMap.insert a) (bMay `mplus` aMay)
217+-- . maybe id (DMap.insert b) (aMay `mplus` bMay)
218+-- . DMap.delete a . DMap.delete b $ dmap
219+-- @
220+swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
221+swapDMapKey src dst = case src `geq` dst of
222+ Nothing -> PatchDMapWithMove $ DMap.fromList
223+ [ dst :=> NodeInfo (From_Move src) (ComposeMaybe $ Just src)
224+ , src :=> NodeInfo (From_Move dst) (ComposeMaybe $ Just dst)
225+ ]
226+ Just _ -> mempty
227+
228+-- |Make a @'PatchDMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'DMap.delete'.
229+deleteDMapKey :: k a -> PatchDMapWithMove k v
230+deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete $ ComposeMaybe Nothing
231+
232+{-
233+k1, k2 :: Const2 Int () ()
234+k1 = Const2 1
235+k2 = Const2 2
236+p1, p2 :: PatchDMapWithMove (Const2 Int ()) Identity
237+p1 = moveDMapKey k1 k2
238+p2 = moveDMapKey k2 k1
239+p12 = p1 <> p2
240+p21 = p2 <> p1
241+p12Slow = p1 `mappendPatchDMapWithMoveSlow` p2
242+p21Slow = p2 `mappendPatchDMapWithMoveSlow` p1
243+
244+testPatchDMapWithMove = do
245+ print p1
246+ print p2
247+ print $ p12 == deleteDMapKey k1
248+ print $ p21 == deleteDMapKey k2
249+ print $ p12Slow == deleteDMapKey k1
250+ print $ p21Slow == deleteDMapKey k2
251+
252+dst (PatchDMapWithMove x _) = x
253+src (PatchDMapWithMove _ x) = x
254+-}
255+
256+-- |Extract the 'DMap' representing the patch changes from the 'PatchDMapWithMove'.
257+unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)
258+unPatchDMapWithMove (PatchDMapWithMove p) = p
259+
260+-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove', without checking any invariants.
261+--
262+-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchDMapWithMove' are preserved; they will not be checked.
263+unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v
264+unsafePatchDMapWithMove = PatchDMapWithMove
265+
266+-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while checking invariants. If the invariants are satisfied, @Right p@ is returned
267+-- otherwise @Left errors@.
268+patchDMapWithMove :: (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)
269+patchDMapWithMove dm =
270+ case validationErrorsForPatchDMapWithMove dm of
271+ [] -> Right $ unsafePatchDMapWithMove dm
272+ errs -> Left errs
273+
274+-- |Map a natural transform @v -> v'@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.
275+mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'
276+mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $
277+ DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p
278+ where g :: forall a. From k v a -> From k v' a
279+ g = \case
280+ From_Insert v -> From_Insert $ f v
281+ From_Delete -> From_Delete
282+ From_Move k -> From_Move k
283+
284+-- |Traverse an effectful function @forall a. v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.
285+traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
286+traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
287+
288+-- |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')@.
289+traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
290+traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p
291+ where g :: forall a. k a -> From k v a -> m (From k v' a)
292+ g k = \case
293+ From_Insert v -> From_Insert <$> f k v
294+ From_Delete -> pure From_Delete
295+ From_Move fromKey -> pure $ From_Move fromKey
296+
297+-- |Map a function which transforms @'From' k v a@ into a @'From' k v' a@ over a @'NodeInfo' k v a@.
298+nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a
299+nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
300+
301+-- |Map an effectful function which transforms @'From' k v a@ into a @f ('From' k v' a)@ over a @'NodeInfo' k v a@.
302+nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a)
303+nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
304+
305+-- |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
306+-- values.
307+weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'
308+weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
309+ where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) v'
310+ g ni = MapWithMove.NodeInfo
311+ { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
312+ From_Insert v -> MapWithMove.From_Insert $ f v
313+ From_Delete -> MapWithMove.From_Delete
314+ From_Move k -> MapWithMove.From_Move $ Some.This k
315+ , MapWithMove._nodeInfo_to = Some.This <$> getComposeMaybe (_nodeInfo_to ni)
316+ }
317+
318+-- |"Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k v'@. Weaken is in scare quotes because the 'Const2' has already disabled any
319+-- dependency in the typing and all points are already @a@, hence the function to map each value to @v'@ is not higher rank.
320+patchDMapWithMoveToPatchMapWithMoveWith :: forall k v v' a. (v a -> v') -> PatchDMapWithMove (Const2 k a) v -> PatchMapWithMove k v'
321+patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
322+ where g :: NodeInfo (Const2 k a) v a -> MapWithMove.NodeInfo k v'
323+ g ni = MapWithMove.NodeInfo
324+ { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
325+ From_Insert v -> MapWithMove.From_Insert $ f v
326+ From_Delete -> MapWithMove.From_Delete
327+ From_Move (Const2 k) -> MapWithMove.From_Move k
328+ , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)
329+ }
330+
331+-- |"Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove ('Const2' k a)@; that is, turn a non-dependently-typed patch into a dependently typed
332+-- one but which always has a constant key type represented by 'Const2'. Apply the given function to each @v@ to produce a @v' a@.
333+-- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
334+const2PatchDMapWithMoveWith :: forall k v v' a. (v -> v' a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) v'
335+const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
336+ where g :: (k, MapWithMove.NodeInfo k v) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v')
337+ g (k, ni) = Const2 k :=> NodeInfo
338+ { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of
339+ MapWithMove.From_Insert v -> From_Insert $ f v
340+ MapWithMove.From_Delete -> From_Delete
341+ MapWithMove.From_Move fromKey -> From_Move $ Const2 fromKey
342+ , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni
343+ }
344+
345+-- | Apply the insertions, deletions, and moves to a given 'DMap'.
346+instance GCompare k => Patch (PatchDMapWithMove k v) where
347+ type PatchTarget (PatchDMapWithMove k v) = DMap k v
348+ 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?
349+ where insertions = DMap.mapMaybeWithKey insertFunc p
350+ insertFunc :: forall a. k a -> NodeInfo k v a -> Maybe (v a)
351+ insertFunc _ ni = case _nodeInfo_from ni of
352+ From_Insert v -> Just v
353+ From_Move k -> DMap.lookup k old
354+ From_Delete -> Nothing
355+ deletions = DMap.mapMaybeWithKey deleteFunc p
356+ deleteFunc :: forall a. k a -> NodeInfo k v a -> Maybe (Constant () a)
357+ deleteFunc _ ni = case _nodeInfo_from ni of
358+ From_Delete -> Just $ Constant ()
359+ _ -> Nothing
360+
361+-- | Get the values that will be replaced, deleted, or moved if the given patch is applied to the given 'DMap'.
362+getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))
363+getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
364+ where f _ v ni = Pair v $ _nodeInfo_to ni
src/Reflex/Patch/IntMap.hsnew file+67
@@ -0,0 +1,67 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveFoldable #-}
3+{-# LANGUAGE DeriveFunctor #-}
4+{-# LANGUAGE DeriveTraversable #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6+{-# LANGUAGE TypeFamilies #-}
7+-- | Module containing 'PatchIntMap', a 'Patch' for 'IntMap' which allows for
8+-- insert/update or delete of associations.
9+module Reflex.Patch.IntMap where
10+
11+import Data.IntMap.Strict (IntMap)
12+import qualified Data.IntMap.Strict as IntMap
13+import Data.Maybe
14+import Data.Semigroup
15+import Reflex.Patch.Class
16+
17+-- | 'Patch' for 'IntMap' which represents insertion or deletion of keys in the mapping.
18+-- Internally represented by 'IntMap (Maybe a)', where @Just@ means insert/update
19+-- and @Nothing@ means delete.
20+newtype PatchIntMap a = PatchIntMap (IntMap (Maybe a)) deriving (Functor, Foldable, Traversable, Monoid)
21+
22+-- | Apply the insertions or deletions to a given 'IntMap'.
23+instance Patch (PatchIntMap a) where
24+ type PatchTarget (PatchIntMap a) = IntMap a
25+ apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $
26+ let removes = IntMap.filter isNothing p
27+ adds = IntMap.mapMaybe id p
28+ in IntMap.union adds $ v `IntMap.difference` removes
29+
30+-- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@.
31+-- If the same key is modified by both patches, the one on the left will take
32+-- precedence.
33+instance Semigroup (PatchIntMap v) where
34+ PatchIntMap a <> PatchIntMap b = PatchIntMap $ a `mappend` b --TODO: Add a semigroup instance for Map
35+ -- PatchMap is idempotent, so stimes n is id for every n
36+#if MIN_VERSION_semigroups(0,17,0)
37+ stimes = stimesIdempotentMonoid
38+#else
39+ times1p n x = case compare n 0 of
40+ LT -> error "stimesIdempotentMonoid: negative multiplier"
41+ EQ -> mempty
42+ GT -> x
43+#endif
44+
45+-- | Map a function @Int -> a -> b@ over all @a@s in the given @'PatchIntMap' a@
46+-- (that is, all inserts/updates), producing a @PatchIntMap b@.
47+mapIntMapPatchWithKey :: (Int -> a -> b) -> PatchIntMap a -> PatchIntMap b
48+mapIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap $ IntMap.mapWithKey (\ k mv -> f k <$> mv) m
49+
50+-- | Map an effectful function @Int -> a -> f b@ over all @a@s in the given @'PatchIntMap' a@
51+-- (that is, all inserts/updates), producing a @f (PatchIntMap b)@.
52+traverseIntMapPatchWithKey :: Applicative f => (Int -> a -> f b) -> PatchIntMap a -> f (PatchIntMap b)
53+traverseIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap <$> IntMap.traverseWithKey (\k mv -> traverse (f k) mv) m
54+
55+-- | Extract all @a@s inserted/updated by the given @'PatchIntMap' a@.
56+patchIntMapNewElements :: PatchIntMap a -> [a]
57+patchIntMapNewElements (PatchIntMap m) = catMaybes $ IntMap.elems m
58+
59+-- | Convert the given @'PatchIntMap' a@ into an @'IntMap' a@ with all
60+-- the inserts/updates in the given patch.
61+patchIntMapNewElementsMap :: PatchIntMap a -> IntMap a
62+patchIntMapNewElementsMap (PatchIntMap m) = IntMap.mapMaybe id m
63+
64+-- | Subset the given @'IntMap' a@ to contain only the keys that would be
65+-- deleted by the given @'PatchIntMap' a@.
66+getDeletions :: PatchIntMap v -> IntMap v' -> IntMap v'
67+getDeletions (PatchIntMap m) v = IntMap.intersection v m
src/Reflex/Patch/Map.hsnew file+63
@@ -0,0 +1,63 @@
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+-- | Apply the insertions or deletions to a given 'Map'.
22+instance Ord k => Patch (PatchMap k v) where
23+ type PatchTarget (PatchMap k v) = Map k v
24+ {-# INLINABLE apply #-}
25+ 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?
26+ where insertions = Map.mapMaybeWithKey (const id) p
27+ deletions = Map.mapMaybeWithKey (const nothingToJust) p
28+ nothingToJust = \case
29+ Nothing -> Just ()
30+ Just _ -> Nothing
31+
32+-- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@.
33+-- If the same key is modified by both patches, the one on the left will take
34+-- precedence.
35+instance Ord k => Semigroup (PatchMap k v) where
36+ PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map
37+ -- PatchMap is idempotent, so stimes n is id for every n
38+#if MIN_VERSION_semigroups(0,17,0)
39+ stimes = stimesIdempotentMonoid
40+#else
41+ times1p n x = case compare n 0 of
42+ LT -> error "stimesIdempotentMonoid: negative multiplier"
43+ EQ -> mempty
44+ GT -> x
45+#endif
46+
47+-- | The empty 'PatchMap' contains no insertions or deletions
48+instance Ord k => Monoid (PatchMap k v) where
49+ mempty = PatchMap mempty
50+ mappend = (<>)
51+
52+-- | 'fmap'ping a 'PatchMap' will alter all of the values it will insert.
53+-- Deletions are unaffected.
54+instance Functor (PatchMap k) where
55+ fmap f = PatchMap . fmap (fmap f) . unPatchMap
56+
57+-- | Returns all the new elements that will be added to the 'Map'
58+patchMapNewElements :: PatchMap k v -> [v]
59+patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p
60+
61+-- | Returns all the new elements that will be added to the 'Map'
62+patchMapNewElementsMap :: PatchMap k v -> Map k v
63+patchMapNewElementsMap (PatchMap p) = Map.mapMaybe id p
src/Reflex/Patch/MapWithMove.hsnew file+270
@@ -0,0 +1,270 @@
1+{-# LANGUAGE DeriveFoldable #-}
2+{-# LANGUAGE DeriveFunctor #-}
3+{-# LANGUAGE DeriveTraversable #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE LambdaCase #-}
6+{-# LANGUAGE PatternGuards #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeFamilies #-}
9+-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
10+-- another
11+module Reflex.Patch.MapWithMove where
12+
13+import Reflex.Patch.Class
14+
15+import Control.Arrow
16+import Control.Monad.State
17+import Data.Foldable
18+import Data.Function
19+import Data.List
20+import Data.Map (Map)
21+import qualified Data.Map as Map
22+import Data.Maybe
23+import Data.Semigroup (Semigroup (..), (<>))
24+import qualified Data.Set as Set
25+import Data.These (These(..))
26+import Data.Tuple
27+
28+-- | Patch a DMap with additions, deletions, and moves. Invariant: If key @k1@
29+-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
30+-- and vice versa. There should never be any unpaired From/To keys.
31+newtype PatchMapWithMove k v = PatchMapWithMove (Map k (NodeInfo k v)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
32+
33+-- | Holds the information about each key: where its new value should come from,
34+-- and where its old value should go to
35+data NodeInfo k v = NodeInfo
36+ { _nodeInfo_from :: !(From k v)
37+ -- ^ Where do we get the new value for this key?
38+ , _nodeInfo_to :: !(To k)
39+ -- ^ If the old value is being kept (i.e. moved rather than deleted or
40+ -- replaced), where is it going?
41+ }
42+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
43+
44+-- | Describe how a key's new value should be produced
45+data From k v
46+ = From_Insert v -- ^ Insert the given value here
47+ | From_Delete -- ^ Delete the existing value, if any, from here
48+ | From_Move !k -- ^ Move the value here from the given key
49+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
50+
51+-- | Describe where a key's old value will go. If this is 'Just', that means
52+-- the key's old value will be moved to the given other key; if it is 'Nothing',
53+-- that means it will be deleted.
54+type To = Maybe
55+
56+-- | Create a 'PatchMapWithMove', validating it
57+patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
58+patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing
59+ where valid = forwardLinks == backwardLinks
60+ forwardLinks = Map.mapMaybe _nodeInfo_to m
61+ backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, v) ->
62+ case _nodeInfo_from v of
63+ From_Move from -> Just (from, to)
64+ _ -> Nothing
65+
66+-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'
67+patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v
68+patchMapWithMoveInsertAll m = PatchMapWithMove $ flip fmap m $ \v -> NodeInfo
69+ { _nodeInfo_from = From_Insert v
70+ , _nodeInfo_to = Nothing
71+ }
72+
73+-- | Extract the internal representation of the 'PatchMapWithMove'
74+unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)
75+unPatchMapWithMove (PatchMapWithMove p) = p
76+
77+-- | Make a @'PatchMapWithMove' k v@ which has the effect of inserting or updating a value @v@ to the given key @k@, like 'Map.insert'.
78+insertMapKey :: k -> v -> PatchMapWithMove k v
79+insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing
80+
81+-- |Make a @'PatchMapWithMove' k v@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to:
82+--
83+-- @
84+-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
85+-- @
86+moveMapKey :: Ord k => k -> k -> PatchMapWithMove k v
87+moveMapKey src dst
88+ | src == dst = mempty
89+ | otherwise =
90+ PatchMapWithMove $ Map.fromList
91+ [ (dst, NodeInfo (From_Move src) Nothing)
92+ , (src, NodeInfo From_Delete (Just dst))
93+ ]
94+
95+-- |Make a @'PatchMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
96+--
97+-- @
98+-- let aMay = Map.lookup a map
99+-- bMay = Map.lookup b map
100+-- in maybe id (Map.insert a) (bMay `mplus` aMay)
101+-- . maybe id (Map.insert b) (aMay `mplus` bMay)
102+-- . Map.delete a . Map.delete b $ map
103+-- @
104+swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v
105+swapMapKey src dst
106+ | src == dst = mempty
107+ | otherwise =
108+ PatchMapWithMove $ Map.fromList
109+ [ (dst, NodeInfo (From_Move src) (Just src))
110+ , (src, NodeInfo (From_Move dst) (Just dst))
111+ ]
112+
113+-- |Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'Map.delete'.
114+deleteMapKey :: k -> PatchMapWithMove k v
115+deleteMapKey k = PatchMapWithMove . Map.singleton k $ NodeInfo From_Delete Nothing
116+
117+-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants.
118+--
119+-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithMove' are preserved; they will not be checked.
120+unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
121+unsafePatchMapWithMove = PatchMapWithMove
122+
123+-- | Apply the insertions, deletions, and moves to a given 'Map'
124+instance Ord k => Patch (PatchMapWithMove k v) where
125+ type PatchTarget (PatchMapWithMove k v) = Map k v
126+ 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?
127+ where insertions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of
128+ From_Insert v -> Just v
129+ From_Move k -> Map.lookup k old
130+ From_Delete -> Nothing
131+ deletions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of
132+ From_Delete -> Just ()
133+ _ -> Nothing
134+
135+-- | Returns all the new elements that will be added to the 'Map'.
136+patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
137+patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap
138+
139+-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@.
140+patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v
141+patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p
142+ where f ni = case _nodeInfo_from ni of
143+ From_Insert v -> Just v
144+ From_Move _ -> Nothing
145+ From_Delete -> Nothing
146+
147+-- | Create a 'PatchMapWithMove' that, if applied to the given 'Map', will sort
148+-- its values using the given ordering function. The set keys of the 'Map' is
149+-- not changed.
150+patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v
151+patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted
152+ where unsorted = Map.toList m
153+ sorted = sortBy (cmp `on` snd) unsorted
154+ f (to, _) (from, _) = if to == from then Nothing else
155+ Just (from, to)
156+ reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
157+ g (to, _) (from, _) = if to == from then Nothing else
158+ let Just movingTo = Map.lookup from reverseMapping
159+ in Just (to, NodeInfo (From_Move from) $ Just movingTo)
160+
161+-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
162+-- will produce a 'Map' with the same values as the second 'Map' but with the
163+-- values sorted with the given ordering function.
164+patchThatChangesAndSortsMapWith :: forall k v. (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
165+patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
166+ where newList = Map.toList newByIndexUnsorted
167+ newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
168+
169+-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
170+-- will produce the second 'Map'.
171+patchThatChangesMap :: (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v
172+patchThatChangesMap oldByIndex newByIndex = patch
173+ where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
174+ (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
175+ let f k v = do
176+ remainingValues <- get
177+ let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
178+ then Map.delete v remainingValues
179+ else Map.insert v remainingKeys remainingValues
180+ case Map.lookup v remainingValues of
181+ Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
182+ Just fromKs ->
183+ if k `Set.member` fromKs
184+ then do
185+ putRemainingKeys $ Set.delete k fromKs
186+ return $ NodeInfo (From_Move k) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
187+ else do
188+ (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
189+ putRemainingKeys remainingKeys
190+ return $ NodeInfo (From_Move fromK) $ Just undefined
191+ Map.traverseWithKey f newByIndex
192+ unusedOldKeys = fold unusedValuesByValue
193+ pointlessMove k = \case
194+ From_Move k' | k == k' -> True
195+ _ -> False
196+ keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
197+ then Just undefined
198+ else Nothing
199+ 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
200+
201+-- | Change the 'From' value of a 'NodeInfo'
202+nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
203+nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
204+
205+-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
206+-- 'Applicative', 'Monad', etc.) action to get the new value
207+nodeInfoMapMFrom :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
208+nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
209+
210+-- | Set the 'To' field of a 'NodeInfo'
211+nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v
212+nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
213+
214+-- |Helper data structure used for composing patches using the monoid instance.
215+data Fixup k v
216+ = Fixup_Delete
217+ | Fixup_Update (These (From k v) (To k))
218+
219+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
220+instance Ord k => Semigroup (PatchMapWithMove k v) where
221+ PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m
222+ where
223+ connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb
224+ h :: (k, (Maybe k, From k v)) -> [(k, Fixup k v)]
225+ h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of
226+ (Just toAfter, From_Move fromBefore)
227+ | fromBefore == toAfter
228+ -> [(toAfter, Fixup_Delete)]
229+ | otherwise
230+ -> [ (toAfter, Fixup_Update (This editBefore))
231+ , (fromBefore, Fixup_Update (That mToAfter))
232+ ]
233+ (Nothing, From_Move fromBefore) -> [(fromBefore, Fixup_Update (That mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map
234+ (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]
235+ (Nothing, _) -> []
236+ mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
237+ mergeFixups _ (Fixup_Update a) (Fixup_Update b)
238+ | This x <- a, That y <- b
239+ = Fixup_Update $ These x y
240+ | That y <- a, This x <- b
241+ = Fixup_Update $ These x y
242+ mergeFixups _ _ _ = error "PatchMapWithMove: incompatible fixups"
243+ fixups = Map.fromListWithKey mergeFixups $ concatMap h connections
244+ combineNodeInfos _ nia nib = NodeInfo
245+ { _nodeInfo_from = _nodeInfo_from nia
246+ , _nodeInfo_to = _nodeInfo_to nib
247+ }
248+ applyFixup _ ni = \case
249+ Fixup_Delete -> Nothing
250+ Fixup_Update u -> Just $ NodeInfo
251+ { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u
252+ , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
253+ }
254+ m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups
255+ getHere :: These a b -> Maybe a
256+ getHere = \case
257+ This a -> Just a
258+ These a _ -> Just a
259+ That _ -> Nothing
260+ getThere :: These a b -> Maybe b
261+ getThere = \case
262+ This _ -> Nothing
263+ These _ b -> Just b
264+ That b -> Just b
265+
266+--TODO: Figure out how to implement this in terms of PatchDMapWithMove rather than duplicating it here
267+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
268+instance Ord k => Monoid (PatchMapWithMove k v) where
269+ mempty = PatchMapWithMove mempty
270+ mappend = (<>)
src/Reflex/PerformEvent/Base.hs+1−3
@@ -141,7 +141,7 @@ hostPerformEventT a = do
141141 case mToPerform of
142142 Nothing -> return [result']
143143 Just toPerform -> do
144− responses <- runHostFrame $ traverseRequesterData (fmap Identity) toPerform
144+ responses <- runHostFrame $ traverseRequesterData (\v -> Identity <$> v) toPerform
145145 mrt <- readRef responseTrigger
146146 let followupEventTriggers = case mrt of
147147 Just rt -> [rt :=> Identity responses]
@@ -164,8 +164,6 @@ instance (ReflexHost t, MonadHold t m) => MonadHold t (PerformEventT t m) where
164164 buildDynamic getV0 v' = PerformEventT $ lift $ buildDynamic getV0 v'
165165 {-# INLINABLE headE #-}
166166 headE = PerformEventT . lift . headE
167− {-# INLINABLE now #-}
168− now = PerformEventT . lift $ now
169167
170168instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m) where
171169 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−2
@@ -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 #-}
@@ -83,8 +84,6 @@ instance MonadHold t m => MonadHold t (PostBuildT t m) where
8384 buildDynamic a0 = lift . buildDynamic a0
8485 {-# INLINABLE headE #-}
8586 headE = lift . headE
86− {-# INLINABLE now #-}
87− now = lift now
8887
8988instance PerformEvent t m => PerformEvent t (PostBuildT t m) where
9089 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+18−80
@@ -8,9 +8,6 @@
88{-# LANGUAGE StandaloneDeriving #-}
99{-# LANGUAGE TypeFamilies #-}
1010{-# LANGUAGE UndecidableInstances #-}
11−{-# LANGUAGE PolyKinds #-}
12−{-# LANGUAGE TypeApplications #-}
13−{-# LANGUAGE RankNTypes #-}
1411-- |
1512-- Module:
1613-- Reflex.Profiled
@@ -19,6 +16,7 @@
1916-- profiling/cost-center information.
2017module Reflex.Profiled where
2118
19+import Control.Lens hiding (children)
2220import Control.Monad
2321import Control.Monad.Exception
2422import Control.Monad.Fix
@@ -26,10 +24,8 @@ import Control.Monad.Primitive
2624import Control.Monad.Reader
2725import Control.Monad.Ref
2826import Control.Monad.State.Strict (StateT, execStateT, modify)
29−import Data.Bifunctor
3027import Data.Coerce
31−import Data.Dependent.Map (DMap)
32−import Data.GADT.Compare (GCompare)
28+import Data.Dependent.Map (DMap, GCompare)
3329import Data.FastMutableIntMap
3430import Data.IORef
3531import Data.List
@@ -37,27 +33,18 @@ import Data.Map (Map)
3733import qualified Data.Map.Strict as Map
3834import Data.Monoid ((<>))
3935import Data.Ord
40−import Data.Profunctor.Unsafe ((#.))
4136import qualified Data.Semigroup as S
4237import Data.Type.Coercion
4338import Foreign.Ptr
4439import GHC.Foreign
4540import GHC.IO.Encoding
4641import GHC.Stack
47−import Reflex.Adjustable.Class
48−import Reflex.BehaviorWriter.Class
4942import Reflex.Class
50−import Reflex.DynamicWriter.Class
51−import Reflex.EventWriter.Class
5243import Reflex.Host.Class
53−import Reflex.NotReady.Class
5444import Reflex.PerformEvent.Class
55−import Reflex.PostBuild.Class
56−import Reflex.Query.Class
57−import Reflex.Requester.Class
58−import Reflex.TriggerEvent.Class
5945
6046import System.IO.Unsafe
47+import Unsafe.Coerce
6148
6249data ProfiledTimeline t
6350
@@ -90,9 +77,9 @@ getCostCentreStack = go []
9077 go (cc : l) parent
9178
9279toCostCentreTree :: 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
80+toCostCentreTree ccs n = do
81+ ccList <- getCostCentreStack ccs
82+ return $ foldr (\cc child -> CostCentreTree 0 n $ Map.singleton cc child) (CostCentreTree n n mempty) ccList
9683
9784getCostCentreTree :: IO CostCentreTree
9885getCostCentreTree = do
@@ -146,32 +133,27 @@ instance Reflex t => Reflex (ProfiledTimeline t) where
146133 push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us
147134 pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e
148135 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)
136+ merge :: forall k. GCompare k => DMap k (Event (ProfiledTimeline t)) -> Event (ProfiledTimeline t) (DMap k Identity)
137+ merge = Event_Profiled . merge . (unsafeCoerce :: DMap k (Event (ProfiledTimeline t)) -> DMap k (Event t))
138+ fan (Event_Profiled e) = EventSelector $ coerce $ select (fan $ profileEvent e)
154139 switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b)
155140 coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e)
156141 current (Dynamic_Profiled d) = coerce $ current d
157142 updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d
158143 unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'
159144 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)
145+ mergeIncremental = Event_Profiled . mergeIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMap k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMap k (Event t)))
146+ mergeIncrementalWithMove = Event_Profiled . mergeIncrementalWithMove . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMapWithMove k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMapWithMove k (Event t)))
162147 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i
163148 updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i
164149 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)
150+ behaviorCoercion (c :: Coercion a b) = case behaviorCoercion c :: Coercion (Behavior t a) (Behavior t b) of
151+ Coercion -> unsafeCoerce (Coercion :: Coercion (Behavior (ProfiledTimeline t) a) (Behavior (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
152+ eventCoercion (c :: Coercion a b) = case eventCoercion c :: Coercion (Event t a) (Event t b) of
153+ Coercion -> unsafeCoerce (Coercion :: Coercion (Event (ProfiledTimeline t) a) (Event (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
154+ dynamicCoercion (c :: Coercion a b) = case dynamicCoercion c :: Coercion (Dynamic t a) (Dynamic t b) of
155+ Coercion -> unsafeCoerce (Coercion :: Coercion (Dynamic (ProfiledTimeline t) a) (Dynamic (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
156+ mergeIntIncremental = Event_Profiled . mergeIntIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchIntMap (Event (ProfiledTimeline t) a)) -> Incremental t (PatchIntMap (Event t a)))
175157 fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e
176158
177159deriving instance Functor (Dynamic t) => Functor (Dynamic (ProfiledTimeline t))
@@ -184,21 +166,10 @@ instance MonadHold t m => MonadHold (ProfiledTimeline t) (ProfiledM m) where
184166 holdIncremental v0 (Event_Profiled v') = ProfiledM $ Incremental_Profiled <$> holdIncremental v0 v'
185167 buildDynamic (ProfiledM v0) (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> buildDynamic v0 v'
186168 headE (Event_Profiled e) = ProfiledM $ Event_Profiled <$> headE e
187− now = ProfiledM $ Event_Profiled <$> now
188169
189170instance MonadSample t m => MonadSample (ProfiledTimeline t) (ProfiledM m) where
190171 sample (Behavior_Profiled b) = ProfiledM $ sample b
191172
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−
202173instance MonadTrans ProfiledM where
203174 lift = ProfiledM
204175
@@ -210,39 +181,6 @@ instance PerformEvent t m => PerformEvent (ProfiledTimeline t) (ProfiledM m) whe
210181 performEvent_ = lift . performEvent_ . coerce
211182 performEvent = lift . fmap coerce . performEvent . coerce
212183
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−
246184instance MonadRef m => MonadRef (ProfiledM m) where
247185 type Ref (ProfiledM m) = Ref m
248186 newRef = lift . newRef
src/Reflex/Pure.hs+18−27
@@ -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
@@ -31,10 +28,14 @@ module Reflex.Pure
3128 , Incremental (..)
3229 ) where
3330
31+#if !MIN_VERSION_base(4,8,0)
32+import Control.Applicative
33+#endif
34+
3435import Control.Monad
35−import Data.Dependent.Map (DMap)
36−import Data.GADT.Compare (GCompare)
36+import Data.Dependent.Map (DMap, GCompare)
3737import qualified Data.Dependent.Map as DMap
38+import Data.Functor.Identity
3839import Data.IntMap (IntMap)
3940import qualified Data.IntMap as IntMap
4041import Data.Maybe
@@ -42,11 +43,10 @@ import Data.MemoTrie
4243import Data.Monoid
4344import Data.Type.Coercion
4445import Reflex.Class
45−import Data.Kind (Type)
4646
4747-- | A completely pure-functional 'Reflex' timeline, identifying moments in time
4848-- with the type @/t/@.
49−data Pure (t :: Type)
49+data Pure t
5050
5151-- | The 'Enum' instance of @/t/@ must be dense: for all @/x :: t/@, there must not exist
5252-- any @/y :: t/@ such that @/'pred' x < y < x/@. The 'HasTrie' instance will be used
@@ -79,19 +79,17 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
7979 -- [UNUSED_CONSTRAINT]: The following type signature for merge will produce a
8080 -- warning because the GCompare instance is not used; however, removing the
8181 -- GCompare instance produces a different warning, due to that constraint
82− -- being present in the original class definition.
82+ -- being present in the original class definition
8383
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
84+ --merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity)
85+ merge events = Event $ memo $ \t ->
86+ let currentOccurrences = DMap.mapMaybeWithKey (\_ (Event a) -> Identity <$> a t) events
8887 in if DMap.null currentOccurrences
8988 then Nothing
9089 else Just currentOccurrences
9190
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
91+ fan :: GCompare k => Event (Pure t) (DMap k Identity) -> EventSelector (Pure t) k
92+ fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= fmap runIdentity . DMap.lookup k
9593
9694 switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a
9795 switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t
@@ -114,8 +112,8 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
114112 --a) -> Incremental (Pure t) p a
115113 unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t)
116114
117− mergeIncrementalG = mergeIncrementalImpl
118− mergeIncrementalWithMoveG = mergeIncrementalImpl
115+ mergeIncremental = mergeIncrementalImpl
116+ mergeIncrementalWithMove = mergeIncrementalImpl
119117
120118 currentIncremental i = Behavior $ \t -> fst $ unIncremental i t
121119
@@ -130,17 +128,14 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
130128 behaviorCoercion Coercion = Coercion
131129 eventCoercion Coercion = Coercion
132130 dynamicCoercion Coercion = Coercion
133− incrementalCoercion Coercion Coercion = Coercion
134131
135132 fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k
136133
137134 mergeIntIncremental = mergeIntIncrementalImpl
138135
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
136+mergeIncrementalImpl :: (PatchTarget p ~ DMap k (Event (Pure t)), GCompare k) => Incremental (Pure t) p -> Event (Pure t) (DMap k Identity)
137+mergeIncrementalImpl i = Event $ \t ->
138+ let results = DMap.mapMaybeWithKey (\_ (Event e) -> Identity <$> e t) $ fst $ unIncremental i t
144139 in if DMap.null results
145140 then Nothing
146141 else Just results
@@ -211,7 +206,3 @@ instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where
211206 Just x -> fromMaybe lastValue $ apply x lastValue
212207
213208 headE = slowHeadE
214− now t = Event $ guard . (t ==)
215−
216−
217−
src/Reflex/Query/Base.hs+41−43
@@ -1,6 +1,7 @@
11{-# LANGUAGE FlexibleInstances #-}
22{-# LANGUAGE GeneralizedNewtypeDeriving #-}
33{-# LANGUAGE InstanceSigs #-}
4+{-# LANGUAGE KindSignatures #-}
45{-# LANGUAGE LambdaCase #-}
56{-# LANGUAGE MultiParamTypeClasses #-}
67{-# LANGUAGE RankNTypes #-}
@@ -16,32 +17,29 @@ module Reflex.Query.Base
1617 , mapQueryResult
1718 , dynWithQueryT
1819 , withQueryT
19− , mapQueryT
2020 ) where
2121
2222import Control.Applicative (liftA2)
2323import Control.Monad.Exception
2424import Control.Monad.Fix
25−import Control.Monad.Morph
2625import Control.Monad.Primitive
2726import Control.Monad.Reader
2827import Control.Monad.Ref
2928import Control.Monad.State.Strict
3029import Data.Align
31−import Data.Dependent.Map (DMap)
30+import Data.Dependent.Map (DMap, DSum (..))
3231import qualified Data.Dependent.Map as DMap
33−import Data.Dependent.Sum (DSum(..))
3432import Data.Foldable
3533import Data.Functor.Compose
3634import Data.Functor.Misc
37−import Data.GADT.Compare (GCompare)
3835import Data.IntMap (IntMap)
3936import qualified Data.IntMap as IntMap
4037import Data.Map (Map)
4138import qualified Data.Map as Map
4239import Data.Monoid ((<>))
4340import qualified Data.Semigroup as S
44−import Data.Some (Some(Some))
41+import Data.Some (Some)
42+import qualified Data.Some as Some
4543import Data.These
4644
4745import Reflex.Class
@@ -50,7 +48,7 @@ import Reflex.DynamicWriter.Class
5048import Reflex.EventWriter.Base
5149import Reflex.EventWriter.Class
5250import Reflex.Host.Class
53−import qualified Data.Patch.MapWithMove as MapWithMove
51+import qualified Reflex.Patch.MapWithMove as MapWithMove
5452import Reflex.PerformEvent.Class
5553import Reflex.PostBuild.Class
5654import Reflex.Query.Class
@@ -76,19 +74,26 @@ getQueryTLoweredResultValue (QueryTLoweredResult (v, _)) = v
7674getQueryTLoweredResultWritten :: QueryTLoweredResult t q v -> [Behavior t q]
7775getQueryTLoweredResultWritten (QueryTLoweredResult (_, w)) = w
7876
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
77+{-
78+let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
79+ sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
80+ bs' = fmapCheap snd $ r'
81+ patches = unsafeBuildIncremental (sampleBs bs0) $
82+ flip pushCheap bs' $ \bs -> do
83+ p <- (~~) <$> sampleBs bs <*> sample (currentIncremental patches)
84+ return (Just (AdditivePatch p))
85+-}
86+
87+instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Adjustable t m) => Adjustable t (QueryT t q m) where
8388 runWithReplace (QueryT a0) a' = do
8489 ((r0, bs0), r') <- QueryT $ lift $ runWithReplace (runStateT a0 []) $ fmapCheap (flip runStateT [] . unQueryT) a'
8590 let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
8691 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
8792 bs' = fmapCheap snd $ r'
8893 bbs <- hold bs0 bs'
89− let patches = flip pushCheap bs' $ \newBs -> do
94+ let patches = flip pushAlwaysCheap bs' $ \newBs -> do
9095 oldBs <- sample bbs
91− maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)
96+ (~~) <$> sampleBs newBs <*> sampleBs oldBs
9297 QueryT $ modify $ (:) $ pull $ sampleBs =<< sample bbs
9398 QueryT $ lift $ tellEvent patches
9499 return (r0, fmapCheap fst r')
@@ -138,7 +143,7 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t
138143 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
139144 return (liftedResult0, liftedResult')
140145
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'))
146+ 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'))
142147 traverseDMapWithKeyWithAdjust f dm0 dm' = do
143148 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
144149 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
@@ -147,10 +152,10 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t
147152 liftedResult' = fforCheap result' $ \(PatchDMap p) -> PatchDMap $
148153 mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mr) -> k :=> ComposeMaybe (fmap (getQueryTLoweredResultValue . getCompose) mr)) p
149154 liftedBs0 :: Map (Some k) [Behavior t q]
150− liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0
155+ liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0
151156 liftedBs' :: Event t (PatchMap (Some k) [Behavior t q])
152157 liftedBs' = fforCheap result' $ \(PatchDMap p) -> PatchMap $
153− Map.fromDistinctAscList $ (\(k :=> ComposeMaybe mr) -> (Some k, fmap (getQueryTLoweredResultWritten . getCompose) mr)) <$> DMap.toList p
158+ Map.fromDistinctAscList $ (\(k :=> ComposeMaybe mr) -> (Some.This k, fmap (getQueryTLoweredResultWritten . getCompose) mr)) <$> DMap.toList p
154159 sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
155160 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
156161 accumBehaviors :: forall m'. MonadHold t m'
@@ -166,24 +171,24 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t
166171 let p k bs = case Map.lookup k bs0 of
167172 Nothing -> case bs of
168173 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
169− Nothing -> return Nothing
174+ Nothing -> return mempty
170175 -- 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
176+ Just newBs -> sampleBs newBs
172177 Just oldBs -> case bs of
173178 -- 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
179+ Nothing -> negateG <$> sampleBs oldBs
175180 -- 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
176181 -- composed with the sampling the child's new state.
177− Just newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)
182+ Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
178183 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
179184 -- child patches and wrap them in AdditivePatch.
180− patch <- fold <$> Map.traverseWithKey p bs'
181− return (apply pbs bs0, AdditivePatch <$> patch)
185+ patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'
186+ return (apply pbs bs0, Just patch)
182187 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'
183188 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
184189 return (liftedResult0, liftedResult')
185190
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'))
191+ 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'))
187192 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do
188193 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
189194 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
@@ -191,10 +196,10 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t
191196 let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0
192197 liftedResult' = fforCheap result' $ mapPatchDMapWithMove (getQueryTLoweredResultValue . getCompose)
193198 liftedBs0 :: Map (Some k) [Behavior t q]
194− liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0
199+ liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0
195200 liftedBs' :: Event t (PatchMapWithMove (Some k) [Behavior t q])
196201 liftedBs' = fforCheap result' $ weakenPatchDMapWithMoveWith (getQueryTLoweredResultWritten . getCompose) {- \(PatchDMap p) -> PatchMapWithMove $
197− Map.fromDistinctAscList $ (\(k :=> mr) -> (Some k, fmap (fmap (getQueryTLoweredResultWritten . getCompose)) mr)) <$> DMap.toList p -}
202+ Map.fromDistinctAscList $ (\(k :=> mr) -> (Some.This k, fmap (fmap (getQueryTLoweredResultWritten . getCompose)) mr)) <$> DMap.toList p -}
198203 sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
199204 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
200205 accumBehaviors' :: forall m'. MonadHold t m'
@@ -211,28 +216,28 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t
211216 p k bs = case Map.lookup k bs0 of
212217 Nothing -> case MapWithMove._nodeInfo_from bs of
213218 -- 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
219+ MapWithMove.From_Delete -> return mempty
215220 -- 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
221+ MapWithMove.From_Insert newBs -> sampleBs newBs
217222 MapWithMove.From_Move k' -> case Map.lookup k' bs0 of
218− Nothing -> return Nothing
219− Just newBs -> maskMempty <$> sampleBs newBs
223+ Nothing -> return mempty
224+ Just newBs -> sampleBs newBs
220225 Just oldBs -> case MapWithMove._nodeInfo_from bs of
221226 -- 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
227+ MapWithMove.From_Delete -> negateG <$> sampleBs oldBs
223228 -- 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
224229 -- composed with the sampling the child's new state.
225− MapWithMove.From_Insert newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)
230+ MapWithMove.From_Insert newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
226231 MapWithMove.From_Move k'
227− | k' == k -> return Nothing
232+ | k' == k -> return mempty
228233 | otherwise -> case Map.lookup k' bs0 of
229234 -- 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)
235+ Nothing -> negateG <$> sampleBs oldBs
236+ Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
232237 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
233238 -- child patches and wrap them in AdditivePatch.
234− patch <- fold <$> Map.traverseWithKey p bs'
235− return (apply pbs bs0, AdditivePatch <$> patch)
239+ patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'
240+ return (apply pbs bs0, Just patch)
236241 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors' liftedBs0 liftedBs'
237242 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
238243 return (liftedResult0, liftedResult')
@@ -240,9 +245,6 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t
240245instance MonadTrans (QueryT t q) where
241246 lift = QueryT . lift . lift . lift
242247
243−instance MFunctor (QueryT t q) where
244− hoist = mapQueryT
245−
246248instance PrimMonad m => PrimMonad (QueryT t q m) where
247249 type PrimState (QueryT t q m) = PrimState m
248250 primitive = lift . primitive
@@ -294,10 +296,6 @@ withQueryT f a = do
294296 (fmapCheap (AdditivePatch . mapQuery f . unAdditivePatch) $ updatedIncremental q)
295297 return result
296298
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−
301299-- | dynWithQueryT's (Dynamic t QueryMorphism) argument needs to be a group homomorphism at all times in order to behave correctly
302300dynWithQueryT :: (MonadFix m, PostBuild t m, Group q, Additive q, Group q', Additive q', Query q')
303301 => Dynamic t (QueryMorphism q q')
src/Reflex/Query/Class.hs+8−67
@@ -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,7 +15,6 @@ module Reflex.Query.Class
2215 , MonadQuery (..)
2316 , tellQueryDyn
2417 , queryDyn
25− , subQuery
2618 , mapQuery
2719 , mapQueryResult
2820 ) where
@@ -37,16 +29,9 @@ import Data.Map.Monoidal (MonoidalMap)
3729import qualified Data.Map.Monoidal as MonoidalMap
3830import Data.Semigroup (Semigroup(..))
3931import Foreign.Storable
40−import Data.Void
41−import Data.Monoid hiding ((<>))
42−import Control.Applicative
4332
4433import Reflex.Class
4534
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'.
5035class (Monoid (QueryResult a), Semigroup (QueryResult a)) => Query a where
5136 type QueryResult a :: *
5237 crop :: a -> QueryResult a -> QueryResult a
@@ -55,39 +40,8 @@ instance (Ord k, Query v) => Query (MonoidalMap k v) where
5540 type QueryResult (MonoidalMap k v) = MonoidalMap k (QueryResult v)
5641 crop q r = MonoidalMap.intersectionWith (flip crop) r q
5742
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.
43+-- | NB: QueryMorphism's must be group homomorphisms when acting on the query type
44+-- and compatible with the query relationship when acting on the query result
9145data QueryMorphism q q' = QueryMorphism
9246 { _queryMorphism_mapQuery :: q -> q'
9347 , _queryMorphism_mapQueryResult :: QueryResult q' -> QueryResult q
@@ -100,16 +54,13 @@ instance Category QueryMorphism where
10054 , _queryMorphism_mapQueryResult = mapQueryResult qm' . mapQueryResult qm
10155 }
10256
103−-- | Apply a 'QueryMorphism' to a 'Query'
10457mapQuery :: QueryMorphism q q' -> q -> q'
10558mapQuery = _queryMorphism_mapQuery
10659
107−-- | Map a 'QueryMorphism' to a 'QueryResult'
10860mapQueryResult :: QueryMorphism q q' -> QueryResult q' -> QueryResult q
10961mapQueryResult = _queryMorphism_mapQueryResult
11062
111−-- | This type can be used to track of the frequency of interest in a given 'Query'. See note on
112−-- 'combineSelectedCounts'
63+-- | This type keeps track of the multiplicity of elements of the view selector that are being used by the app
11364newtype SelectedCount = SelectedCount { unSelectedCount :: Int }
11465 deriving (Eq, Ord, Show, Read, Integral, Num, Bounded, Enum, Real, Ix, Bits, FiniteBits, Storable, Data)
11566
@@ -125,34 +76,24 @@ instance Group SelectedCount where
12576
12677instance Additive SelectedCount
12778
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.
79+-- | 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.
13180combineSelectedCounts :: SelectedCount -> SelectedCount -> Maybe SelectedCount
13281combineSelectedCounts (SelectedCount i) (SelectedCount j) = if i == negate j then Nothing else Just $ SelectedCount (i + j)
13382
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
83+class (Group q, Additive q, Query q) => MonadQuery t q m | m -> q t where
13784 tellQueryIncremental :: Incremental t (AdditivePatch q) -> m ()
13885 askQueryResult :: m (Dynamic t (QueryResult q))
13986 queryIncremental :: Incremental t (AdditivePatch q) -> m (Dynamic t (QueryResult q))
14087
141−instance MonadQuery t q m => MonadQuery t q (ReaderT r m) where
88+instance (Monad m, MonadQuery t q m) => MonadQuery t q (ReaderT r m) where
14289 tellQueryIncremental = lift . tellQueryIncremental
14390 askQueryResult = lift askQueryResult
14491 queryIncremental = lift . queryIncremental
14592
146−-- | Produce and send an 'Incremental' 'Query' from a 'Dynamic' 'Query'.
14793tellQueryDyn :: (Reflex t, MonadQuery t q m) => Dynamic t q -> m ()
14894tellQueryDyn d = tellQueryIncremental $ unsafeBuildIncremental (sample (current d)) $ attachWith (\old new -> AdditivePatch $ new ~~ old) (current d) (updated d)
14995
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))
96+queryDyn :: (Reflex t, Monad m, MonadQuery t q m) => Dynamic t q -> m (Dynamic t (QueryResult q))
15297queryDyn q = do
15398 tellQueryDyn q
15499 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+30−99
@@ -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 #-}
@@ -33,7 +32,6 @@ module Reflex.Requester.Base
3332 , requesterDataToList
3433 , singletonRequesterData
3534 , matchResponsesWithRequests
36− , matchResponseMapWithRequests
3735 , multiEntry
3836 , unMultiEntry
3937 , requesting'
@@ -51,17 +49,14 @@ import Reflex.TriggerEvent.Class
5149import Control.Applicative (liftA2)
5250import Control.Monad.Exception
5351import Control.Monad.Identity
54−import Control.Monad.Morph
5552import Control.Monad.Primitive
5653import Control.Monad.Reader
5754import Control.Monad.Ref
5855import Control.Monad.State.Strict
5956import Data.Bits
6057import Data.Coerce
61−import Data.Constraint
62−import Data.Dependent.Map (DMap)
58+import Data.Dependent.Map (DMap, DSum (..))
6359import qualified Data.Dependent.Map as DMap
64−import Data.Dependent.Sum (DSum (..))
6560import Data.Functor.Compose
6661import Data.Functor.Misc
6762import Data.IntMap.Strict (IntMap)
@@ -71,7 +66,8 @@ import qualified Data.Map as Map
7166import Data.Monoid ((<>))
7267import Data.Proxy
7368import qualified Data.Semigroup as S
74−import Data.Some (Some(Some))
69+import Data.Some (Some)
70+import qualified Data.Some as Some
7571import Data.Type.Equality
7672import Data.Unique.Tag
7773
@@ -84,51 +80,19 @@ newtype TagMap (f :: * -> *) = TagMap (IntMap Any)
8480
8581newtype RequesterData f = RequesterData (TagMap (Entry f))
8682
87−emptyRequesterData :: RequesterData f
88−emptyRequesterData = RequesterData $ TagMap IntMap.empty
89−
9083data RequesterDataKey a where
9184 RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a
9285 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
86+ RequesterDataKey_Multi2 :: {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
9487 RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
9588
9689singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f
9790singletonRequesterData rdk v = case rdk of
9891 RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v
9992 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− }
93+ RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
10494 RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
10595
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−
13296requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]
13397requesterDataToList (RequesterData m) = do
13498 k :=> Entry e <- tagMapToList m
@@ -138,12 +102,11 @@ requesterDataToList (RequesterData m) = do
138102 (k', e') <- IntMap.toList e
139103 k'' :=> e'' <- requesterDataToList e'
140104 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'''
105+ MyTagType_Multi2 -> do
106+ (k', e') <- Map.toList e
107+ (k'', e'') <- IntMap.toList e'
108+ k''' :=> e''' <- requesterDataToList e''
109+ return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''
147110 MyTagType_Multi3 -> do
148111 (k', e') <- IntMap.toList e
149112 (k'', e'') <- IntMap.toList e'
@@ -171,13 +134,7 @@ traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWith
171134 go k (Entry request) = Entry <$> case myKeyType k of
172135 MyTagType_Single -> f request
173136 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− }
137+ MyTagType_Multi2 -> traverse (traverse (traverseRequesterData f)) request
181138 MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request
182139
183140-- | 'traverseRequesterData' with its arguments flipped
@@ -221,14 +178,9 @@ instance MyTagTypeOffset Multi3 where
221178type family EntryContents request a where
222179 EntryContents request (Single a) = request a
223180 EntryContents request Multi = IntMap (RequesterData request)
224− EntryContents request (Multi2 k) = Multi2Contents k request
181+ EntryContents request (Multi2 k) = Map (Some k) (IntMap (RequesterData request))
225182 EntryContents request Multi3 = IntMap (IntMap (RequesterData request))
226183
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−
232184newtype Entry request x = Entry { unEntry :: EntryContents request x }
233185
234186{-# INLINE singleEntry #-}
@@ -357,7 +309,7 @@ tagRequest req = do
357309 return t
358310
359311{-# 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))
312+responseFromTag :: Monad m => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))
361313responseFromTag (MyTagWrap t) = do
362314 responses :: EventSelectorInt t Any <- RequesterT ask
363315 return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t
@@ -365,9 +317,6 @@ responseFromTag (MyTagWrap t) = do
365317instance MonadTrans (RequesterT t request response) where
366318 lift = RequesterT . lift . lift
367319
368−instance MFunctor (RequesterT t request response) where
369− hoist f = RequesterT . hoist (hoist f) . unRequesterT
370−
371320instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where
372321 type Performable (RequesterT t request response m) = Performable m
373322 performEvent_ = lift . performEvent_
@@ -487,12 +436,12 @@ traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchN
487436 let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))
488437 responses = fanMap $ fmapCheap unpack response
489438 unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))
490− unpack = _multi2Contents_values . unEntry
439+ unpack = unEntry
491440 pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)
492− pack m = Entry $ Multi2Contents { _multi2Contents_values = m, _multi2Contents_dict = Dict }
441+ pack = Entry
493442 f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)
494443 f' k (Compose (n, v)) = do
495− (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some k))
444+ (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some.This k))
496445 return $ Compose (fmapCheap (IntMap.singleton n) myRequests, result)
497446 ndm' <- numberOccurrencesFrom 1 dm'
498447 (children0, children') <- base f' (DMap.map (\v -> Compose (0, v)) dm0) $ fmap (\(n, dm) -> mapPatch (\v -> Compose (n, v)) dm) ndm'
@@ -510,30 +459,10 @@ traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchN
510459data Decoder rawResponse response =
511460 forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)
512461
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−
533462-- | Matches incoming responses with previously-sent requests
534463-- and uses the provided request "decoder" function to process
535464-- incoming responses.
536−matchResponseMapWithRequests
465+matchResponsesWithRequests
537466 :: forall t rawRequest rawResponse request response m.
538467 ( MonadFix m
539468 , MonadHold t m
@@ -544,14 +473,14 @@ matchResponseMapWithRequests
544473 -- request and a function used to process the associated response
545474 -> Event t (RequesterData request)
546475 -- ^ The outgoing requests
547− -> Event t (Map Int rawResponse)
548− -- ^ A map of incoming responses, tagged by an identifying key
476+ -> Event t (Int, rawResponse)
477+ -- ^ The incoming responses, tagged by an identifying key
549478 -> m ( Event t (Map Int rawRequest)
550479 , Event t (RequesterData response)
551480 )
552481 -- ^ A map of outgoing wire-format requests and an event of responses keyed
553482 -- by the 'RequesterData' key of the associated outgoing request
554−matchResponseMapWithRequests f send recv = do
483+matchResponsesWithRequests f send recv = do
555484 rec nextId <- hold 1 $ fmap (\(next, _, _) -> next) outgoing
556485 waitingFor :: Incremental t (PatchMap Int (Decoder rawResponse response)) <-
557486 holdIncremental mempty $ leftmost
@@ -593,15 +522,17 @@ matchResponseMapWithRequests f send recv = do
593522 processIncoming
594523 :: Incremental t (PatchMap Int (Decoder rawResponse response))
595524 -- A map of outstanding expected responses
596− -> Event t (Map Int rawResponse)
525+ -> Event t (Int, rawResponse)
597526 -- A incoming response paired with its identifying key
598527 -> Event t (RequesterData response, PatchMap Int v)
599528 -- The decoded response and a patch that clears the outstanding responses queue
600− processIncoming waitingFor inc = flip push inc $ \rspMap -> do
529+ processIncoming waitingFor inc = flip push inc $ \(n, rawRsp) -> do
601530 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)
531+ case Map.lookup n wf of
532+ Nothing -> return Nothing -- TODO How should lookup failures be handled here? They shouldn't ever happen..
533+ Just (Decoder k rspF) -> do
534+ let rsp = rspF rawRsp
535+ return $ Just
536+ ( singletonRequesterData k rsp
537+ , PatchMap $ Map.singleton n Nothing
538+ )
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/Internal.hs+447−739
@@ -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,15 +49,13 @@ import Data.GADT.Compare
5949import Data.IntMap.Strict (IntMap)
6050import qualified Data.IntMap.Strict as IntMap
6151import Data.IORef
62−import Data.Kind (Type)
6352import Data.Maybe hiding (mapMaybe)
64−import Data.Monoid (mempty, (<>))
53+import Data.Monoid ((<>))
6554import Data.Proxy
6655import Data.These
6756import Data.Traversable
68−import Data.Type.Equality ((:~:)(Refl))
6957import Data.Witherable (Filterable, mapMaybe)
70−import GHC.Exts hiding (toList)
58+import GHC.Exts
7159import GHC.IORef (IORef (..))
7260import GHC.Stack
7361import Reflex.FastWeak
@@ -75,57 +63,40 @@ import 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--------------------------------------------------------------------------------
@@ -251,9 +235,9 @@ subscribeAndRead = unEvent
251235-- caching; if the computation function is very cheap, this is (much) more
252236-- efficient than 'push'
253237{-# INLINE [1] pushCheap #-}
254−pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
238+pushCheap :: (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
@@ -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,15 +623,15 @@ 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
@@ -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 :: 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 :: 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
@@ -1193,30 +1133,19 @@ instance HasSpiderTimeline x => Filterable (Event x) where
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]
1201−
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
1136+ align ea eb = mapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
12081137
12091138data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)
12101139 | BuildDyn !(EventM x (PatchTarget p), Event x p)
12111140 | HoldDyn !(Hold x p)
12121141
1213−newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }
1142+newtype Dyn x p = Dyn { unDyn :: IORef (DynType x p) }
12141143
1215−newMapDyn :: HasSpiderTimeline x => (a -> b) -> DynamicS x (Identity a) -> DynamicS x (Identity b)
1144+newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)
12161145newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
12171146
12181147--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)
1148+zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c)
12201149zipDynWith f da db =
12211150 let eab = align (dynamicUpdated da) (dynamicUpdated db)
12221151 ec = flip push eab $ \o -> do
@@ -1239,12 +1168,18 @@ buildDynamic readV0 v' = do
12391168 return d
12401169
12411170unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
1242−unsafeBuildDynamic readV0 v' =
1243− Dyn $ unsafePerformIO $ newIORef $ UnsafeDyn (readV0, v')
1171+unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ UnsafeDyn x
1172+ where x = (readV0, v')
12441173
12451174-- ResultM can read behaviors and events
12461175type ResultM = EventM
12471176
1177+{-# NOINLINE unsafeNewIORef #-}
1178+unsafeNewIORef :: a -> b -> IORef b
1179+unsafeNewIORef a b = unsafePerformIO $ do
1180+ touch a
1181+ newIORef b
1182+
12481183instance HasSpiderTimeline x => Functor (Event x) where
12491184 fmap f = push $ return . Just . f
12501185
@@ -1257,42 +1192,33 @@ push f e = cacheEvent (pushCheap f e)
12571192
12581193{-# INLINABLE pull #-}
12591194pull :: BehaviorM x a -> Behavior x a
1260−pull a = unsafePerformIO $ do
1261− ref <- newIORef Nothing
1195+pull a = behaviorPull $ Pull
1196+ { pullCompute = a
1197+ , pullValue = unsafeNewIORef a Nothing
12621198#ifdef DEBUG_NODEIDS
1263− nid <- newNodeId
1199+ , pullNodeId = unsafeNodeId a
12641200#endif
1265− pure $ behaviorPull $ Pull
1266− { pullCompute = a
1267− , pullValue = ref
1268−#ifdef DEBUG_NODEIDS
1269− , pullNodeId = nid
1270−#endif
1271− }
1201+ }
12721202
12731203{-# INLINABLE switch #-}
12741204switch :: 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− }
1205+switch a = eventSwitch $ Switch
1206+ { switchParent = a
1207+ , switchSubscribed = unsafeNewIORef a Nothing
1208+ }
12811209
12821210coincidence :: 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− }
1211+coincidence a = eventCoincidence $ Coincidence
1212+ { coincidenceParent = a
1213+ , coincidenceSubscribed = unsafeNewIORef a Nothing
1214+ }
12891215
12901216-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
12911217run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
12921218run roots after = do
12931219 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
12941220 let t = spiderTimeline :: SpiderTimelineEnv x
1295− result <- SpiderHost $ withMVar (_spiderTimeline_lock (unSTE t)) $ \_ -> unSpiderHost $ runFrame $ do
1221+ result <- SpiderHost $ withMVar (_spiderTimeline_lock t) $ \_ -> unSpiderHost $ runFrame $ do
12961222 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
12971223 occBefore <- liftIO $ do
12981224 occBefore <- readIORef occRef
@@ -1330,11 +1256,11 @@ scheduleMerge' initialHeight heightRef a = scheduleMerge initialHeight $ do
13301256 GT -> scheduleMerge' height heightRef a -- The height has been increased (by a coincidence event; TODO: is this the only way?)
13311257 EQ -> a
13321258
1333−newtype Clear a = Clear (IORef (Maybe a))
1259+data SomeClear = forall a. SomeClear {-# UNPACK #-} !(IORef (Maybe a))
13341260
1335−newtype IntClear a = IntClear (IORef (IntMap a))
1261+data SomeIntClear = forall a. SomeIntClear {-# UNPACK #-} !(IORef (IntMap a))
13361262
1337−newtype RootClear k = RootClear (IORef (DMap k Identity))
1263+data SomeRootClear = forall k. SomeRootClear {-# UNPACK #-} !(IORef (DMap k Identity))
13381264
13391265data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a
13401266
@@ -1346,110 +1272,55 @@ mkWeakPtrWithDebug x debugNote = do
13461272 x' <- evaluate x
13471273 mkWeakPtr x' $
13481274 if debugFinalize
1349− then Just $ debugStrLn $ "finalizing: " ++ debugNote
1275+ then Just $ putStrLn $ "finalizing: " ++ debugNote
13501276 else Nothing
13511277
13521278type WeakList a = [Weak a]
13531279
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−
13811280{-# 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
1281+#ifdef DEBUG
1282+withIncreasedDepth :: CanTrace x m => m a -> m a
1283+withIncreasedDepth a = do
1284+ spiderTimeline <- askSpiderTimelineEnv
1285+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ
13851286 result <- a
1386− liftIO $ modifyIORef' (_spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)) pred
1287+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred
13871288 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−
14121289#else
1290+withIncreasedDepth :: m a -> m a
1291+withIncreasedDepth = id
1292+#endif
14131293
1414−{-# INLINE withIncreasedDepth #-}
1415−withIncreasedDepth :: proxy x -> m a -> m a
1416−withIncreasedDepth _ = id
1294+type CanTrace x m = (HasSpiderTimeline x, MonadIO m)
14171295
14181296{-# INLINE tracePropagate #-}
14191297tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1420−tracePropagate _ _ = return ()
1298+tracePropagate p = traceWhen p debugPropagate
14211299
14221300{-# INLINE traceInvalidate #-}
14231301traceInvalidate :: String -> IO ()
1424−traceInvalidate _ = return ()
1425−
1426−{-# INLINE traceInvalidateHeight #-}
1427−traceInvalidateHeight :: String -> IO ()
1428−traceInvalidateHeight _ = return ()
1302+traceInvalidate = when debugInvalidate . liftIO . putStrLn
14291303
1430−{-# INLINE debugSubscriber #-}
1431−debugSubscriber :: String -> Subscriber x a -> IO (Subscriber x a)
1432−debugSubscriber _ = return
1433−
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 ()
1304+{-# INLINE traceWhen #-}
1305+traceWhen :: (CanTrace x m) => proxy x -> Bool -> String -> m ()
1306+traceWhen p b message = traceMWhen p b $ return message
14471307
1308+{-# INLINE traceMWhen #-}
1309+traceMWhen :: (CanTrace x m) => proxy x -> Bool -> m String -> m ()
1310+traceMWhen _ b getMessage = when b $ do
1311+ message <- getMessage
1312+#ifdef DEBUG
1313+ spiderTimeline <- askSpiderTimelineEnv
1314+ d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline
1315+#else
1316+ let d = 0
14481317#endif
1318+ liftIO $ putStrLn $ replicate d ' ' <> message
14491319
14501320whoCreatedIORef :: IORef a -> IO [String]
14511321whoCreatedIORef (IORef a) = whoCreated $! a
14521322
1323+#ifdef DEBUG_CYCLES
14531324groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
14541325groupByHead = \case
14551326 [] -> []
@@ -1460,54 +1331,20 @@ groupByHead = \case
14601331 | otherwise -> (x, xs :| []) : l
14611332
14621333listsToForest :: 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
1474−#endif
1475−
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−
1334+listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l
14951335#endif
14961336
1497−
14981337{-# INLINE propagateSubscriberHold #-}
14991338propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()
15001339propagateSubscriberHold h a = do
1501− {-# SCC "trace" #-} when debugPropagate $ traceM (Proxy :: Proxy x) $ liftIO $ do
1340+ {-# SCC "trace" #-} traceMWhen (Proxy :: Proxy x) debugPropagate $ liftIO $ do
15021341 invalidators <- liftIO $ readIORef $ holdInvalidators h
15031342 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
1504−
15051343 v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h
15061344 case {-# SCC "apply" #-} apply a v of
15071345 Nothing -> return ()
15081346 Just v' -> do
1509− {-# SCC "trace2" #-} withIncreasedDepth (Proxy :: Proxy x) $
1510− tracePropagate (Proxy :: Proxy x) ("propagateSubscriberHold: assigning Hold" <> showNodeId h)
1347+ {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate (Proxy :: Proxy x) $ "propagateSubscriberHold: assigning Hold" <> showNodeId h
15111348 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
15121349 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
15131350 defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'
@@ -1515,25 +1352,25 @@ propagateSubscriberHold h a = do
15151352data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
15161353
15171354runBehaviorM :: 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)
1355+runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)
15191356
15201357askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
15211358askInvalidator = do
1522− (!m, _) <- ask
1359+ (!m, _) <- BehaviorM ask
15231360 case m of
15241361 Nothing -> return Nothing
15251362 Just (!wi, _) -> return $ Just wi
15261363
15271364askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
15281365askParentsRef = do
1529− (!m, _) <- ask
1366+ (!m, _) <- BehaviorM ask
15301367 case m of
15311368 Nothing -> return Nothing
15321369 Just (_, !p) -> return $ Just p
15331370
15341371askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
15351372askBehaviorHoldInits = do
1536− (_, !his) <- ask
1373+ (_, !his) <- BehaviorM ask
15371374 return his
15381375
15391376{-# INLINE getDynHold #-}
@@ -1561,7 +1398,7 @@ getDynHold d = do
15611398zeroRef :: IORef Height
15621399zeroRef = unsafePerformIO $ newIORef zeroHeight
15631400
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)
1401+getRootSubscribed :: GCompare k => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)
15651402getRootSubscribed k r sub = do
15661403 mSubscribed <- readIORef $ rootSubscribed r
15671404 let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r
@@ -1575,14 +1412,9 @@ getRootSubscribed k r sub = do
15751412 let !cached = rootSubscribed r
15761413 uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"
15771414 (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed
1578−
1579− tracePropagate (Proxy::Proxy x) $ "getRootSubscribed: calling rootInit"
1580−
1415+ when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"
15811416 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
15821417 writeIORef uninitRef $! uninit
1583−#ifdef DEBUG_NODEIDS
1584− nid <- newNodeId
1585−#endif
15861418 let !subscribed = RootSubscribed
15871419 { rootSubscribedKey = k
15881420 , rootSubscribedCachedSubscribed = cached
@@ -1591,7 +1423,7 @@ getRootSubscribed k r sub = do
15911423 , rootSubscribedUninit = uninit
15921424 , rootSubscribedWeakSelf = weakSelf
15931425#ifdef DEBUG_NODEIDS
1594− , rootSubscribedNodeId = nid
1426+ , rootSubscribedNodeId = unsafeNodeId (k, r, subs)
15951427#endif
15961428 }
15971429 -- If we die at the same moment that all our children die, they will
@@ -1627,9 +1459,6 @@ data FanInt x a = FanInt
16271459 { _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
16281460 , _fanInt_subscriptionRef :: {-# UNPACK #-} !(IORef (EventSubscription x)) -- This should have a valid subscription iff subscribers is non-empty
16291461 , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a))
1630−#ifdef DEBUG_NODEIDS
1631− , _fanInt_nodeId :: {-# UNPACK #-} !Int
1632−#endif
16331462 }
16341463
16351464newFanInt :: IO (FanInt x a)
@@ -1637,39 +1466,38 @@ newFanInt = do
16371466 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
16381467 subscriptionRef <- newIORef $ error "fanInt: no subscription"
16391468 occRef <- newIORef $ error "fanInt: no occurrence"
1640−#ifdef DEBUG_NODEIDS
1641− nodeId <- newNodeId
1642−#endif
16431469 return $ FanInt
16441470 { _fanInt_subscribers = subscribers
16451471 , _fanInt_subscriptionRef = subscriptionRef
16461472 , _fanInt_occRef = occRef
1647−#ifdef DEBUG_NODEIDS
1648− , _fanInt_nodeId = nodeId
1649−#endif
16501473 }
16511474
1475+{-# NOINLINE unsafeNewFanInt #-}
1476+unsafeNewFanInt :: b -> FanInt x a
1477+unsafeNewFanInt b = unsafePerformIO $ do
1478+ touch b
1479+ newFanInt
1480+
16521481fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a
1653−fanInt p = unsafePerformIO $ do
1654− self <- newFanInt
1655− pure $ EventSelectorInt $ \k -> Event $ \sub -> do
1482+fanInt p =
1483+ let self = unsafeNewFanInt p
1484+ in EventSelectorInt $ \k -> Event $ \sub -> do
16561485 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)
16571486 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
1487+ (subscription, parentOcc) <- subscribeAndRead p $ Subscriber
16601488 { subscriberPropagate = \m -> do
16611489 liftIO $ writeIORef (_fanInt_occRef self) m
16621490 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 ->
1491+ FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> do --TODO: Do we need to know that no subscribers are being added as we traverse?
1492+ FastWeakBag.traverse b $ \s -> do
16651493 subscriberPropagate s v
1666− , subscriberInvalidateHeight = \old ->
1667− FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->
1668− FastWeakBag.traverse_ b $ \s ->
1494+ , subscriberInvalidateHeight = \old -> do
1495+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1496+ FastWeakBag.traverse b $ \s -> do
16691497 subscriberInvalidateHeight s old
1670− , subscriberRecalculateHeight = \new ->
1671− FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->
1672− FastWeakBag.traverse_ b $ \s ->
1498+ , subscriberRecalculateHeight = \new -> do
1499+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1500+ FastWeakBag.traverse b $ \s -> do
16731501 subscriberRecalculateHeight s new
16741502 }
16751503 liftIO $ do
@@ -1683,28 +1511,13 @@ fanInt p = unsafePerformIO $ do
16831511 FastMutableIntMap.insert (_fanInt_subscribers self) k b
16841512 return b
16851513 Just b -> return b
1686− ticket <- liftIO $ FastWeakBag.insert sub b
1514+ t <- liftIO $ FastWeakBag.insert sub b
16871515 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−
1516+ (EventSubscription _ (EventSubscribed !heightRef _)) <- readIORef (_fanInt_subscriptionRef self)
1517+ return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)
17051518
17061519{-# 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))
1520+getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket, FanSubscribed x k, Maybe a)
17081521getFanSubscribed k f sub = do
17091522 mSubscribed <- liftIO $ readIORef $ fanSubscribed f
17101523 case mSubscribed of
@@ -1722,16 +1535,13 @@ getFanSubscribed k f sub = do
17221535 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
17231536 occRef <- liftIO $ newIORef parentOcc
17241537 when (isJust parentOcc) $ scheduleClear occRef
1725−#ifdef DEBUG_NODEIDS
1726− nid <- liftIO newNodeId
1727−#endif
17281538 let subscribed = FanSubscribed
17291539 { fanSubscribedCachedSubscribed = fanSubscribed f
17301540 , fanSubscribedOccurrence = occRef
17311541 , fanSubscribedParent = subscription
17321542 , fanSubscribedSubscribers = subscribersRef
17331543#ifdef DEBUG_NODEIDS
1734− , fanSubscribedNodeId = nid
1544+ , fanSubscribedNodeId = unsafeNodeId f
17351545#endif
17361546 }
17371547 let !self = (k, subscribed)
@@ -1741,7 +1551,7 @@ getFanSubscribed k f sub = do
17411551 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
17421552 return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)
17431553
1744−cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k v) -> IO ()
1554+cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO ()
17451555cleanupFanSubscribed (k, subscribed) = do
17461556 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
17471557 let reducedSubscribers = DMap.delete k subscribers
@@ -1753,7 +1563,7 @@ cleanupFanSubscribed (k, subscribed) = do
17531563 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
17541564
17551565{-# INLINE subscribeFanSubscribed #-}
1756−subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k v -> Subscriber x (v a) -> IO WeakBagTicket
1566+subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO WeakBagTicket
17571567subscribeFanSubscribed k subscribed sub = do
17581568 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
17591569 case DMap.lookup k subscribers of
@@ -1791,9 +1601,6 @@ getSwitchSubscribed s sub = do
17911601 when (isJust parentOcc) $ scheduleClear occRef
17921602 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
17931603 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1794−#ifdef DEBUG_NODEIDS
1795− nid <- liftIO newNodeId
1796−#endif
17971604 let !subscribed = SwitchSubscribed
17981605 { switchSubscribedCachedSubscribed = switchSubscribed s
17991606 , switchSubscribedOccurrence = occRef
@@ -1806,7 +1613,7 @@ getSwitchSubscribed s sub = do
18061613 , switchSubscribedCurrentParent = subscriptionRef
18071614 , switchSubscribedWeakSelf = weakSelf
18081615#ifdef DEBUG_NODEIDS
1809− , switchSubscribedNodeId = nid
1616+ , switchSubscribedNodeId = unsafeNodeId s
18101617#endif
18111618 }
18121619 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
@@ -1851,9 +1658,6 @@ getCoincidenceSubscribed c sub = do
18511658 scheduleClear innerSubdRef
18521659 weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
18531660 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
1854−#ifdef DEBUG_NODEIDS
1855− nid <- liftIO newNodeId
1856−#endif
18571661 let subscribed = CoincidenceSubscribed
18581662 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
18591663 , coincidenceSubscribedOccurrence = occRef
@@ -1864,7 +1668,7 @@ getCoincidenceSubscribed c sub = do
18641668 , coincidenceSubscribedInnerParent = innerSubdRef
18651669 , coincidenceSubscribedWeakSelf = weakSelf
18661670#ifdef DEBUG_NODEIDS
1867− , coincidenceSubscribedNodeId = nid
1671+ , coincidenceSubscribedNodeId = unsafeNodeId c
18681672#endif
18691673 }
18701674 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
@@ -1881,72 +1685,57 @@ cleanupCoincidenceSubscribed subscribed = do
18811685subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket
18821686subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
18831687
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)
1688+{-# INLINE merge #-}
1689+merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1690+merge d = cacheEvent (mergeCheap d)
18891691
18901692{-# 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)
1693+mergeWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1694+mergeWithMove d = cacheEvent (mergeCheapWithMove d)
18951695
18961696{-# 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
1697+mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1698+mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy
19031699 where
1904− updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)
1700+ updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)
19051701 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
19061702 let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do
19071703 (mOldSubd, newPs) <- case me of
19081704 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
19091705 Just e -> do
19101706 let s = subscriber $ return k
1911− subscription@(EventSubscription _ subd) <- subscribe (nt e) s
1707+ subscription@(EventSubscription _ subd) <- subscribe e s
19121708 newParentHeight <- liftIO $ getEventSubscribedHeight subd
19131709 let newParent = MergeSubscribedParent subscription
19141710 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
19151711 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
19161712 forM_ mOldSubd $ \oldSubd -> do
1917− oldHeight <- liftIO $ getEventSubscribedHeight $
1918− _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd
1919−
1713+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd
19201714 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
19211715 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
19221716 foldM f ([], oldParents) $ DMap.toList p
1923−
1924− getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParent x)
1717+ getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParent x)
19251718 getInitialSubscribers initialParents subscriber = do
19261719 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
19271720 let s = subscriber $ return k
1928− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s
1721+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
19291722 height <- liftIO $ getEventSubscribedHeight parentSubd
1930− return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParent subscription)
1723+ return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription)
19311724 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
19321725 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
19331726 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
19341727 )
1935−
19361728 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)
19371729 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub
19381730
19391731{-# 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
1732+mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1733+mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
19451734 where
1946− updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)
1735+ updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)
19471736 updateMe subscriber heightBagRef oldParents p = do
19481737 -- Prepare new parents for insertion
1949− let subscribeParent :: forall a. k a -> Event x (v a) -> EventM x (MergeSubscribedParentWithMove x k a)
1738+ let subscribeParent :: forall a. k a -> Event x a -> EventM x (MergeSubscribedParentWithMove x k a)
19501739 subscribeParent k e = do
19511740 keyRef <- liftIO $ newIORef k
19521741 let s = subscriber $ liftIO $ readIORef keyRef
@@ -1955,82 +1744,73 @@ mergeCheapWithMove nt = mergeGCheap' _mergeSubscribedParentWithMove_subscription
19551744 newParentHeight <- getEventSubscribedHeight subd
19561745 modifyIORef' heightBagRef $ heightBagAdd newParentHeight
19571746 return $ MergeSubscribedParentWithMove subscription keyRef
1958− p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey (\k q -> subscribeParent k (nt q)) p
1747+ p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey subscribeParent p
19591748 -- 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
1749+ let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Event x) a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
19611750 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
19621751 Nothing -> do
1963− oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $
1964− _mergeSubscribedParentWithMove_subscription parent
1965−
1752+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent
19661753 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
19671754 return $ Just $ _mergeSubscribedParentWithMove_subscription parent
19681755 Just toKey -> do
19691756 liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey
19701757 return Nothing
1971− toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $
1972− DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
1973−
1758+ toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
19741759 return (toDelete, applyAlways p' oldParents)
1975− getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)
1760+ getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k)
19761761 getInitialSubscribers initialParents subscriber = do
19771762 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
19781763 keyRef <- liftIO $ newIORef k
19791764 let s = subscriber $ liftIO $ readIORef keyRef
1980− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s
1765+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
19811766 height <- liftIO $ getEventSubscribedHeight parentSubd
1982− return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
1767+ return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
19831768 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
19841769 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
19851770 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
19861771 )
1987−
19881772 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)
19891773 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub
19901774
1991−type MergeUpdateFunc k v x p s
1992− = (forall a. EventM x (k a) -> Subscriber x (v a))
1775+type MergeUpdateFunc k x p s
1776+ = (forall a. EventM x (k a) -> Subscriber x a)
19931777 -> IORef HeightBag
19941778 -> DMap k s
19951779 -> p
19961780 -> EventM x ([EventSubscription x], DMap k s)
19971781
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)
1782+type MergeInitFunc k x s
1783+ = DMap k (Event x)
1784+ -> (forall a. EventM x (k a) -> Subscriber x a)
1785+ -> EventM x (DMap k Identity, [Height], DMap k s)
20041786
20051787type MergeDestroyFunc k s
20061788 = DMap k s
20071789 -> IO ()
20081790
2009−data Merge x k v s = Merge
1791+data Merge x k s = Merge
20101792 { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))
20111793 , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)
20121794 , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)
2013− , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k v))
2014− , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k v))
1795+ , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k Identity))
1796+ , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k Identity))
20151797 }
20161798
2017−invalidateMergeHeight :: Merge x k v s -> IO ()
1799+invalidateMergeHeight :: Merge x k s -> IO ()
20181800invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)
20191801
20201802invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
20211803invalidateMergeHeight' heightRef sub = do
20221804 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
1805+ 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
20251806 writeIORef heightRef $! invalidHeight
20261807 subscriberInvalidateHeight sub oldHeight
20271808
2028−revalidateMergeHeight :: Merge x k v s -> IO ()
1809+
1810+revalidateMergeHeight :: Merge x k s -> IO ()
20291811revalidateMergeHeight m = do
20301812 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
1813+ when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
20341814 heights <- readIORef $ _merge_heightBagRef m
20351815 parents <- readIORef $ _merge_parentsRef m
20361816 -- When the number of heights in the bag reaches the number of parents, we should have a valid height
@@ -2038,53 +1818,44 @@ revalidateMergeHeight m = do
20381818 LT -> return ()
20391819 EQ -> do
20401820 let height = succHeight $ heightBagMax heights
2041− traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height
1821+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
20421822 writeIORef (_merge_heightRef m) $! height
20431823 subscriberRecalculateHeight (_merge_sub m) height
20441824 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
20451825
2046−scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()
1826+scheduleMergeSelf :: HasSpiderTimeline x => Merge x k s -> Height -> EventM x ()
20471827scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
20481828 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
1829+ 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
20521830 --TODO: Assert that m is not empty
20531831 subscriberPropagate (_merge_sub m) vals
20541832
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
1833+mergeSubscriber :: forall x k s a. (HasSpiderTimeline x, GCompare k) => Merge x k s -> EventM x (k a) -> Subscriber x a
1834+mergeSubscriber m getKey = Subscriber
20781835 { subscriberPropagate = \a -> do
20791836 oldM <- liftIO $ readIORef $ _merge_accumRef m
20801837 k <- getKey
2081− let newM = DMap.insertWith (error "Same key fired multiple times for Merge") k a oldM
1838+ let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM
20821839 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
20831840 liftIO $ writeIORef (_merge_accumRef m) $! newM
20841841 when (DMap.null oldM) $ do -- Only schedule the firing once
20851842 height <- liftIO $ readIORef $ _merge_heightRef m
2086− checkCycle subscribed
2087−
1843+ --TODO: assertions about height
1844+ currentHeight <- getCurrentHeight
1845+ when (height <= currentHeight) $ do
1846+ if height /= invalidHeight
1847+ then do
1848+ myStack <- liftIO $ whoCreatedIORef undefined --TODO
1849+ error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
1850+ else liftIO $ do
1851+#ifdef DEBUG_CYCLES
1852+ nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
1853+ stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es
1854+ let cycleInfo = ":\n" <> drawForest (listsToForest stacks)
1855+#else
1856+ let cycleInfo = ""
1857+#endif
1858+ error $ "Causality loop found" <> cycleInfo
20881859 scheduleMergeSelf m height
20891860 , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating
20901861 modifyIORef' (_merge_heightBagRef m) $ heightBagRemove old
@@ -2095,45 +1866,30 @@ mergeSubscriber subscribed m getKey = Subscriber
20951866 }
20961867
20971868--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)
1869+updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k s -> MergeUpdateFunc k x p s -> p -> SomeMergeUpdate x
1870+updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)
21001871 where updateMe = do
21011872 oldParents <- liftIO $ readIORef $ _merge_parentsRef m
2102− (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber subscribed m) (_merge_heightBagRef m) oldParents p
1873+ (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber m) (_merge_heightBagRef m) oldParents p
21031874 liftIO $ writeIORef (_merge_parentsRef m) $! newParents
21041875 return subscriptionsToKill
21051876
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
1877+{-# INLINE mergeCheap' #-}
1878+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)
1879+mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
21101880 initialParents <- readBehaviorUntracked $ dynamicCurrent d
21111881 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
21121882 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
21131883 heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"
21141884 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
1885+ let m = Merge
21301886 { _merge_parentsRef = parentsRef
21311887 , _merge_heightBagRef = heightBagRef
21321888 , _merge_heightRef = heightRef
21331889 , _merge_sub = sub
21341890 , _merge_accumRef = accumRef
21351891 }
2136− (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber subscribed m
1892+ (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber m
21371893 let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights
21381894 myHeight = if invalidHeight `elem` heights
21391895 then invalidHeight
@@ -2142,57 +1898,50 @@ mergeGCheap' getParent getInitialSubscribers updateFunc destroy d = Event $ \sub
21421898 let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now
21431899 then (if DMap.null dm then Nothing else Just dm, DMap.empty)
21441900 else (Nothing, dm)
2145− unless (DMap.null accum) $ scheduleMergeSelf m myHeight
1901+ unless (DMap.null accum) $ do
1902+ scheduleMergeSelf m myHeight
21461903 liftIO $ writeIORef accumRef $! accum
21471904 liftIO $ writeIORef heightRef $! myHeight
21481905 liftIO $ writeIORef heightBagRef $! myHeightBag
1906+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
21491907 liftIO $ writeIORef parentsRef $! initialParentState
21501908 defer $ SomeMergeInit $ do
2151− let changeSubscriber = Subscriber
1909+ let s = Subscriber
21521910 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
2153− tracePropagate (Proxy :: Proxy x) "SubscriberMerge/Change"
2154− defer $ updateMerge subscribed m updateFunc a
1911+ tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change"
1912+ defer $ updateMerge m updateFunc a
21551913 , subscriberInvalidateHeight = \_ -> return ()
21561914 , subscriberRecalculateHeight = \_ -> return ()
21571915 }
2158− (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) changeSubscriber
2159− forM_ change $ \c -> defer $ updateMerge subscribed m updateFunc c
1916+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s
1917+ forM_ change $ \c -> defer $ updateMerge m updateFunc c
21601918 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
21611919 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
21621920 -- its subscription.
2163− liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)
1921+ liftIO $ writeIORef changeSubdRef (s, changeSubscription)
21641922 let unsubscribeAll = destroy =<< readIORef parentsRef
1923+ return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parentsRef, changeSubdRef)
1924+ , occ
1925+ )
21651926
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)
1927+mergeInt :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)
21701928mergeInt = cacheEvent . mergeIntCheap
21711929
21721930{-# INLINABLE mergeIntCheap #-}
2173−mergeIntCheap :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1931+mergeIntCheap :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)
21741932mergeIntCheap d = Event $ \sub -> do
21751933 initialParents <- readBehaviorUntracked $ dynamicCurrent d
21761934 accum <- liftIO $ FastMutableIntMap.newEmpty
21771935 heightRef <- liftIO $ newIORef zeroHeight
21781936 heightBagRef <- liftIO $ newIORef heightBagEmpty
21791937 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− }
21901938 let scheduleSelf = do
21911939 height <- liftIO $ readIORef $ heightRef
21921940 scheduleMerge' height heightRef $ do
21931941 vals <- liftIO $ FastMutableIntMap.getFrozenAndClear accum
21941942 subscriberPropagate sub vals
2195− invalidateMyHeight = invalidateMergeHeight' heightRef sub
1943+ invalidateMyHeight = do
1944+ invalidateMergeHeight' heightRef sub
21961945 recalculateMyHeight = do
21971946 currentHeight <- readIORef heightRef
21981947 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 +1951,12 @@ mergeIntCheap d = Event $ \sub -> do
22021951 LT -> return ()
22031952 EQ -> do
22041953 let height = succHeight $ heightBagMax heights
2205− traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height
1954+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
22061955 writeIORef heightRef $! height
22071956 subscriberRecalculateHeight sub height
22081957 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"
22091958 mySubscriber k = Subscriber
22101959 { subscriberPropagate = \a -> do
2211− checkCycle subscribed
2212−
22131960 wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum
22141961 liftIO $ FastMutableIntMap.insert accum k a
22151962 when wasEmpty scheduleSelf
@@ -2243,6 +1990,7 @@ mergeIntCheap d = Event $ \sub -> do
22431990 else liftIO $ Just <$> FastMutableIntMap.getFrozenAndClear accum
22441991 else do when (not isEmpty) scheduleSelf -- We have things accumulated, but we shouldn't have fired them yet
22451992 return Nothing
1993+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
22461994 defer $ SomeMergeInit $ do
22471995 let updateMe a = SomeMergeUpdate u invalidateMyHeight recalculateMyHeight
22481996 where
@@ -2256,39 +2004,35 @@ mergeIntCheap d = Event $ \sub -> do
22562004 oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions
22572005 liftIO $ for_ oldParents $ \oldParent -> do
22582006 oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent
2259−
2260− print ("updateMe", oldParentHeight)
22612007 modifyIORef' heightBagRef $ heightBagRemove oldParentHeight
22622008 return $ IntMap.elems oldParents
2263− let changeSubscriber = Subscriber
2009+ let s = Subscriber
22642010 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
22652011 tracePropagate (Proxy :: Proxy x) $ "SubscriberMergeInt/Change"
22662012 defer $ updateMe a
22672013 , subscriberInvalidateHeight = \_ -> return ()
22682014 , subscriberRecalculateHeight = \_ -> return ()
22692015 }
2270− (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) changeSubscriber
2016+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s
22712017 forM_ change $ \c -> defer $ updateMe c
22722018 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
22732019 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
22742020 -- its subscription.
2275− liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)
2021+ liftIO $ writeIORef changeSubdRef (s, changeSubscription)
22762022 let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents
2277−
2278−
2279− return (EventSubscription unsubscribeAll subscribed, occ)
2023+ return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parents, changeSubdRef)
2024+ , occ
2025+ )
22802026
22812027newtype 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) }
22832028
2284−fanG :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k v) -> EventSelectorG x k v
2285−fanG e = unsafePerformIO $ do
2286− ref <- newIORef Nothing
2029+fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k
2030+fan e =
22872031 let f = Fan
22882032 { fanParent = e
2289− , fanSubscribed = ref
2033+ , fanSubscribed = unsafeNewIORef e Nothing
22902034 }
2291− pure $ EventSelectorG $ \k -> eventFan k f
2035+ in EventSelector $ \k -> eventFan k f
22922036
22932037runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()
22942038runHoldInits holdInitRef dynInitRef mergeInitRef = do
@@ -2342,36 +2086,36 @@ clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeI
23422086-- | Run an event action outside of a frame
23432087runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
23442088runFrame a = SpiderHost $ do
2345− let env = _spiderTimeline_eventEnv $ unSTE (spiderTimeline :: SpiderTimelineEnv x)
2089+ let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
23462090 let go = do
23472091 result <- a
23482092 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
23492093 return result
23502094 result <- runEventM go
23512095 toClear <- readIORef $ eventEnvClears env
2352− forM_ toClear $ \(Some (Clear ref)) -> {-# SCC "clear" #-} writeIORef ref Nothing
2096+ forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing
23532097 toClearInt <- readIORef $ eventEnvIntClears env
2354− forM_ toClearInt $ \(Some (IntClear ref)) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty
2098+ forM_ toClearInt $ \(SomeIntClear ref) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty
23552099 toClearRoot <- readIORef $ eventEnvRootClears env
2356− forM_ toClearRoot $ \(Some (RootClear ref)) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty
2100+ forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty
23572101 toAssign <- readIORef $ eventEnvAssignments env
23582102 toReconnectRef <- newIORef []
23592103 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env
23602104 forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do
23612105 writeIORef vRef v
2362− traceInvalidate $ "Invalidating Hold"
2106+ when debugInvalidate $ putStrLn $ "Invalidating Hold"
23632107 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef
23642108 mergeUpdates <- readIORef $ eventEnvMergeUpdates env
23652109 writeIORef (eventEnvMergeUpdates env) []
2366− tracePropagate (Proxy::Proxy x) $ "Updating merges"
2110+ when debugPropagate $ putStrLn "Updating merges"
23672111 mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates
2368− tracePropagate (Proxy::Proxy x) $ "Updating merges done"
2112+ when debugPropagate $ putStrLn "Updating merges done"
23692113 toReconnect <- readIORef toReconnectRef
23702114 clearEventEnv env
23712115 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
23722116 oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed
23732117 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed
2374− traceInvalidate $ "Finalizing invalidator for Switch" <> showNodeId subscribed
2118+ when debugInvalidate $ putStrLn $ "Finalizing invalidator for Switch" <> showNodeId subscribed
23752119 finalize wi
23762120 i <- evaluate $ switchSubscribedOwnInvalidator subscribed
23772121 wi' <- mkWeakPtrWithDebug i "wi'"
@@ -2385,7 +2129,7 @@ runFrame a = SpiderHost $ do
23852129 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
23862130 {-
23872131 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
2388− liftIO $ debugStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
2132+ liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
23892133 EventRoot _ -> "EventRoot"
23902134 EventNever -> "EventNever"
23912135 _ -> "something else"
@@ -2400,7 +2144,7 @@ runFrame a = SpiderHost $ do
24002144 myHeight <- readIORef $ switchSubscribedHeight subscribed
24012145 when (parentHeight /= myHeight) $ do
24022146 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
2403− WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight
2147+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight
24042148 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
24052149 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
24062150 unsubscribe subscription
@@ -2441,7 +2185,7 @@ invalidateCoincidenceHeight subscribed = do
24412185 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
24422186 when (oldHeight /= invalidHeight) $ do
24432187 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight
2444− WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
2188+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
24452189
24462190updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()
24472191updateSwitchHeight new subscribed = do
@@ -2449,7 +2193,7 @@ updateSwitchHeight new subscribed = do
24492193 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
24502194 when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion
24512195 writeIORef (switchSubscribedHeight subscribed) $! new
2452− WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new
2196+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new
24532197
24542198recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
24552199recalculateCoincidenceHeight subscribed = do
@@ -2458,7 +2202,7 @@ recalculateCoincidenceHeight subscribed = do
24582202 height <- calculateCoincidenceHeight subscribed
24592203 when (height /= invalidHeight) $ do
24602204 writeIORef (coincidenceSubscribedHeight subscribed) $! height
2461− WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
2205+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
24622206
24632207calculateSwitchHeight :: SwitchSubscribed x a -> IO Height
24642208calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)
@@ -2520,8 +2264,6 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Event
25202264 {-# INLINABLE headE #-}
25212265 headE = R.slowHeadE
25222266-- headE (SpiderEvent e) = SpiderEvent <$> Reflex.Spider.Internal.headE e
2523− {-# INLINABLE now #-}
2524− now = nowSpiderEventM
25252267
25262268instance Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where
25272269 {-# INLINABLE sample #-}
@@ -2543,9 +2285,6 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide
25432285 {-# INLINABLE headE #-}
25442286 headE = R.slowHeadE
25452287-- headE (SpiderEvent e) = SpiderPushM $ SpiderEvent <$> Reflex.Spider.Internal.headE e
2546− {-# INLINABLE now #-}
2547− now = SpiderPushM nowSpiderEventM
2548−
25492288
25502289instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where
25512290 {-# INLINE return #-}
@@ -2554,13 +2293,11 @@ instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x))
25542293 x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x
25552294 {-# INLINE (>>) #-}
25562295 (>>) = (*>)
2557−#if !MIN_VERSION_base(4,13,0)
25582296 {-# INLINE fail #-}
25592297 fail _ = error "Dynamic does not support 'fail'"
2560−#endif
25612298
25622299{-# INLINABLE newJoinDyn #-}
2563−newJoinDyn :: HasSpiderTimeline x => DynamicS x (Identity (DynamicS x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)
2300+newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)
25642301newJoinDyn d =
25652302 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)
25662303 eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d
@@ -2609,9 +2346,6 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide
26092346 buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e
26102347 {-# INLINABLE headE #-}
26112348 headE e = runFrame . runSpiderHostFrame $ Reflex.Class.headE e
2612− {-# INLINABLE now #-}
2613− now = runFrame . runSpiderHostFrame $ Reflex.Class.now
2614−
26152349
26162350instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where
26172351 sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can
@@ -2628,8 +2362,6 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide
26282362 {-# INLINABLE headE #-}
26292363 headE = R.slowHeadE
26302364-- headE (SpiderEvent e) = SpiderHostFrame $ SpiderEvent <$> Reflex.Spider.Internal.headE e
2631− {-# INLINABLE now #-}
2632− now = SpiderHostFrame Reflex.Class.now
26332365
26342366instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where
26352367 {-# INLINABLE sample #-}
@@ -2650,8 +2382,6 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Refle
26502382 buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e
26512383 {-# INLINABLE headE #-}
26522384 headE e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.headE e
2653− {-# INLINABLE now #-}
2654− now = Reflex.Spider.Internal.ReadPhase Reflex.Class.now
26552385
26562386--------------------------------------------------------------------------------
26572387-- Deprecated items
@@ -2689,13 +2419,13 @@ instance HasSpiderTimeline x => Reflex.Host.Class.MonadReadEvent (SpiderTimeline
26892419 touch h
26902420 return result
26912421
2692−instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where
2422+instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where
26932423 newEventWithTrigger = SpiderHost . fmap SpiderEvent . newEventWithTriggerIO
26942424 newFanEventWithTrigger f = SpiderHost $ do
26952425 es <- newFanEventWithTriggerIO f
26962426 return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es
26972427
2698−instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where
2428+instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where
26992429 newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO
27002430 newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do
27012431 es <- newFanEventWithTriggerIO f
@@ -2717,7 +2447,7 @@ unsafeNewSpiderTimelineEnv = do
27172447#ifdef DEBUG
27182448 depthRef <- newIORef 0
27192449#endif
2720− return $ STE $ SpiderTimelineEnv
2450+ return $ SpiderTimelineEnv
27212451 { _spiderTimeline_lock = lock
27222452 , _spiderTimeline_eventEnv = env
27232453#ifdef DEBUG
@@ -2727,19 +2457,19 @@ unsafeNewSpiderTimelineEnv = do
27272457
27282458-- | Create a new SpiderTimelineEnv
27292459newSpiderTimeline :: IO (Some SpiderTimelineEnv)
2730−newSpiderTimeline = withSpiderTimeline (pure . Some)
2460+newSpiderTimeline = withSpiderTimeline (pure . Some.This)
27312461
2732−data LocalSpiderTimeline (x :: Type) s
2462+data LocalSpiderTimeline x s
27332463
27342464instance Reifies s (SpiderTimelineEnv x) =>
27352465 HasSpiderTimeline (LocalSpiderTimeline x s) where
2736− spiderTimeline = localSpiderTimeline Proxy $ reflect (Proxy :: Proxy s)
2466+ spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s)
27372467
27382468localSpiderTimeline
2739− :: proxy s
2469+ :: Proxy s
27402470 -> SpiderTimelineEnv x
27412471 -> SpiderTimelineEnv (LocalSpiderTimeline x s)
2742−localSpiderTimeline _ = coerce
2472+localSpiderTimeline _ = unsafeCoerce
27432473
27442474-- | Pass a new timeline to the given function.
27452475withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r
@@ -2747,18 +2477,18 @@ withSpiderTimeline k = do
27472477 env <- unsafeNewSpiderTimelineEnv
27482478 reify env $ \s -> k $ localSpiderTimeline s env
27492479
2750−newtype SpiderPullM (x :: Type) a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2480+newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
27512481
27522482type ComputeM = EventM
27532483
2754−newtype SpiderPushM (x :: Type) a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2484+newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
27552485
27562486instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
27572487 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
27582488 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
27592489 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 }
2490+ newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad)
2491+ newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }
27622492 type PullM (SpiderTimeline x) = SpiderPullM x
27632493 type PushM (SpiderTimeline x) = SpiderPushM x
27642494 {-# INLINABLE never #-}
@@ -2771,15 +2501,10 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
27712501 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
27722502 {-# INLINABLE pull #-}
27732503 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
2504+ {-# INLINABLE merge #-}
2505+ merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x))
2506+ {-# INLINABLE fan #-}
2507+ fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
27832508 {-# INLINABLE switch #-}
27842509 switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior
27852510 {-# INLINABLE coincidence #-}
@@ -2787,15 +2512,15 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
27872512 {-# INLINABLE current #-}
27882513 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
27892514 {-# INLINABLE updated #-}
2790− updated = SpiderEvent #. dynamicUpdated .# fmap coerce . unSpiderDynamic
2515+ updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic
27912516 {-# INLINABLE unsafeBuildDynamic #-}
27922517 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
27932518 {-# INLINABLE unsafeBuildIncremental #-}
27942519 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
2520+ {-# INLINABLE mergeIncremental #-}
2521+ mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental
2522+ {-# INLINABLE mergeIncrementalWithMove #-}
2523+ mergeIncrementalWithMove = SpiderEvent . mergeWithMove . (unsafeCoerce :: Dynamic x (PatchDMapWithMove k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMapWithMove k (Event x))) . unSpiderIncremental
27992524 {-# INLINABLE currentIncremental #-}
28002525 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
28012526 {-# INLINABLE updatedIncremental #-}
@@ -2806,10 +2531,9 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
28062531 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'
28072532 eventCoercion Coercion = Coercion
28082533 behaviorCoercion Coercion = Coercion
2809− dynamicCoercion Coercion = Coercion
2810− incrementalCoercion Coercion Coercion = Coercion
2534+ dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance
28112535 {-# INLINABLE mergeIntIncremental #-}
2812− mergeIntIncremental = SpiderEvent . mergeInt . coerce
2536+ mergeIntIncremental = SpiderEvent . mergeInt . (unsafeCoerce :: Dynamic x (PatchIntMap (R.Event (SpiderTimeline x) a)) -> Dynamic x (PatchIntMap (Event x a))) . unSpiderIncremental
28132537 {-# INLINABLE fanInt #-}
28142538 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))
28152539
@@ -2834,7 +2558,7 @@ instance MonadAtomicRef (EventM x) where
28342558 atomicModifyRef r f = liftIO $ atomicModifyRef r f
28352559
28362560-- | 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)
2561+newtype SpiderHost x a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
28382562
28392563instance Monad (SpiderHost x) where
28402564 {-# INLINABLE (>>=) #-}
@@ -2843,14 +2567,8 @@ instance Monad (SpiderHost x) where
28432567 SpiderHost x >> SpiderHost y = SpiderHost $ x >> y
28442568 {-# INLINABLE return #-}
28452569 return x = SpiderHost $ return x
2846−#if !MIN_VERSION_base(4,13,0)
28472570 {-# 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
2571+ fail s = SpiderHost $ fail s
28542572
28552573-- | Run an action affecting the global Spider timeline; this will be guarded by
28562574-- a mutex for that timeline
@@ -2862,7 +2580,7 @@ runSpiderHost (SpiderHost a) = a
28622580runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
28632581runSpiderHostForTimeline (SpiderHost a) _ = a
28642582
2865−newtype SpiderHostFrame (x :: Type) a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }
2583+newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }
28662584 deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
28672585
28682586instance Monad (SpiderHostFrame x) where
@@ -2872,21 +2590,19 @@ instance Monad (SpiderHostFrame x) where
28722590 SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y
28732591 {-# INLINABLE return #-}
28742592 return x = SpiderHostFrame $ return x
2875−#if !MIN_VERSION_base(4,13,0)
28762593 {-# INLINABLE fail #-}
28772594 fail s = SpiderHostFrame $ fail s
2878−#endif
28792595
28802596instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where
28812597 notReadyUntil _ = pure ()
28822598 notReady = pure ()
28832599
2884−newEventWithTriggerIO :: forall x a. HasSpiderTimeline x => (RootTrigger x a -> IO (IO ())) -> IO (Event x a)
2600+newEventWithTriggerIO :: (RootTrigger x a -> IO (IO ())) -> IO (Event x a)
28852601newEventWithTriggerIO f = do
28862602 es <- newFanEventWithTriggerIO $ \Refl -> f
28872603 return $ select es Refl
28882604
2889−newFanEventWithTriggerIO :: (HasSpiderTimeline x, GCompare k) => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)
2605+newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)
28902606newFanEventWithTriggerIO f = do
28912607 occRef <- newIORef DMap.empty
28922608 subscribedRef <- newIORef DMap.empty
@@ -2920,11 +2636,3 @@ instance MonadAtomicRef (SpiderHostFrame x) where
29202636instance PrimMonad (SpiderHostFrame x) where
29212637 type PrimState (SpiderHostFrame x) = PrimState IO
29222638 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/TriggerEvent/Base.hs−2
@@ -122,8 +122,6 @@ instance MonadHold t m => MonadHold t (TriggerEventT t m) where
122122 buildDynamic a0 = lift . buildDynamic a0
123123 {-# INLINABLE headE #-}
124124 headE = lift . headE
125− {-# INLINABLE now #-}
126− now = lift now
127125
128126instance Adjustable t m => Adjustable t (TriggerEventT t m) where
129127 {-# 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−1
@@ -13,7 +13,7 @@ import Data.Map (Map)
1313
1414import Reflex.Class
1515import Reflex.Adjustable.Class
16−import Data.Patch.MapWithMove
16+import Reflex.Patch.MapWithMove
1717
1818
1919-- | Build sortable content in such a way that re-sorting it can cause minimal
src/Reflex/Workflow.hs+2−2
@@ -34,14 +34,14 @@ workflow w0 = do
3434 rec eResult <- networkHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult
3535 return $ fmap fst eResult
3636
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'.
37+-- | Similar to 'workflow', but outputs an 'Event' that fires whenever the current 'Workflow' is replaced by the next 'Workflow'.
3838workflowView :: 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)
3939workflowView w0 = do
4040 rec eResult <- networkView . fmap unWorkflow =<< holdDyn w0 eReplace
4141 eReplace <- fmap switch $ hold never $ fmap snd eResult
4242 return $ fmap fst eResult
4343
44−-- | Map a function over a 'Workflow', possibly changing the return type.
44+-- | Map a function over a 'Workflow', possibly changing the resturn type.
4545mapWorkflow :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b
4646mapWorkflow f (Workflow x) = Workflow (fmap (f *** fmap (mapWorkflow f)) x)
4747
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+4−24
@@ -1,5 +1,3 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE BangPatterns #-}
31{-# LANGUAGE FlexibleContexts #-}
42{-# LANGUAGE GADTs #-}
53{-# LANGUAGE RecursiveDo #-}
@@ -14,10 +12,6 @@ import Data.Functor.Misc
1412import qualified Data.Map as M
1513import Data.These
1614
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−
2115import Reflex
2216import Reflex.EventWriter.Base
2317import Test.Run
@@ -42,9 +36,6 @@ main = do
4236 print os4
4337 os5@[[Nothing, Just [1, 2]]] <- runApp' (unwrapApp testLiveTellEventDMap) [Just ()]
4438 print os5
45− os6 <- runApp' (unwrapApp delayedPulse) [Just ()]
46− print os6
47− let ![[Nothing, Nothing]] = os6
4839 return ()
4940
5041unwrapApp :: (Reflex t, Monad m) => (a -> EventWriterT t [Int] m ()) -> a -> m (Event t [Int])
@@ -53,13 +44,16 @@ unwrapApp x appIn = do
5344 return e
5445
5546testOrdering :: (Reflex t, Monad m) => Event t () -> EventWriterT t [Int] m ()
56−testOrdering pulse = forM_ [10,9..1] $ \i -> tellEvent ([i] <$ pulse)
47+testOrdering pulse = do
48+ forM_ [10,9..1] $ \i -> tellEvent ([i] <$ pulse)
49+ return ()
5750
5851testSimultaneous :: (Reflex t, Adjustable t m, MonadHold t m) => Event t (These () ()) -> EventWriterT t [Int] m ()
5952testSimultaneous pulse = do
6053 let e0 = fmapMaybe (^? here) pulse
6154 e1 = fmapMaybe (^? there) pulse
6255 forM_ [1,3..9] $ \i -> runWithReplace (tellEvent ([i] <$ e0)) $ ffor e1 $ \_ -> tellEvent ([i+1] <$ e0)
56+ return ()
6357
6458-- | Test that a widget telling and event which fires at the same time it has been replaced
6559-- doesn't count along with the new widget.
@@ -118,17 +112,3 @@ testLiveTellEventDMap pulse = do
118112 (mapToDMap $ M.singleton 1 ())
119113 ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton 2 ()) <$ pulse)
120114 return ()
121−
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+1−5
@@ -19,12 +19,8 @@ import Data.Map.Monoidal (MonoidalMap)
1919import Data.Semigroup
2020import Data.These
2121
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−
2622import Reflex
27−import Data.Patch.MapWithMove
23+import Reflex.Patch.MapWithMove
2824import Test.Run
2925
3026newtype MyQuery = MyQuery SelectedCount
test/Reflex/Bench/Focused.hs−12
@@ -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
@@ -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−1
@@ -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
test/Reflex/Test/CrossImpl.hs+8−18
@@ -21,12 +21,11 @@ import Reflex.Dynamic
2121import Reflex.Host.Class
2222import qualified Reflex.Pure as P
2323import qualified Reflex.Spider.Internal as S
24−import qualified Reflex.Profiled as Prof
2524
2625import Control.Arrow (second, (&&&))
2726import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
2827import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
29−import Data.Dependent.Sum (DSum (..))
28+import Data.Dependent.Map (DSum (..))
3029import Data.Foldable
3130import Data.Map.Strict (Map)
3231import qualified Data.Map.Strict as Map
@@ -36,6 +35,8 @@ import Data.Traversable
3635import System.Exit
3736import System.Mem
3837
38+import System.IO.Unsafe
39+
3940mapToPureBehavior :: Map Int a -> Behavior PureReflexDomain a
4041mapToPureBehavior m = P.Behavior $ \t -> case Map.lookupLE t m of
4142 Nothing -> error $ "mapToPureBehavior: no value for time " <> show t
@@ -72,14 +73,11 @@ instance MapMSignals (Event t a) (Event t' a) t t' where
7273instance (MapMSignals a a' t t', MapMSignals b b' t t') => MapMSignals (a, b) (a', b') t t' where
7374 mapMSignals fb fe (a, b) = liftM2 (,) (mapMSignals fb fe a) (mapMSignals fb fe b)
7475
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
76+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)
77+testSpider builder (bMap, eMap) = unsafePerformIO $ S.runSpiderHost $ do
8078 (re, reTrigger) <- newEventWithTriggerRef
8179 (rb, rbTrigger) <- newEventWithTriggerRef
82− b <- runHostFrame $ hold (error "testTimeline: No value for input behavior yet") rb
80+ b <- runHostFrame $ hold (error "testSpider: No value for input behavior yet") rb
8381 (b', e') <- runHostFrame $ builder (b, re)
8482 e'Handle <- subscribeEvent e' --TODO: This should be unnecessary
8583 let times = relevantTestingTimes (bMap, eMap)
@@ -104,11 +102,9 @@ testAgreement :: (Eq c, Eq d, Show c, Show d) => (forall m t. TestCaseConstraint
104102testAgreement builder inputs = do
105103 let identityResult = testPure builder inputs
106104 tracePerf "---------" $ return ()
107− spiderResult <- S.runSpiderHost $ testTimeline builder inputs
108− tracePerf "---------" $ return ()
109− profiledResult <- S.runSpiderHost $ Prof.runProfiledM $ testTimeline builder inputs
105+ let spiderResult = testSpider builder inputs
110106 tracePerf "---------" $ return ()
111− let resultsAgree = identityResult == spiderResult && identityResult == profiledResult
107+ let resultsAgree = identityResult == spiderResult
112108 if resultsAgree
113109 then do --putStrLn "Success:"
114110 --print identityResult
@@ -116,7 +112,6 @@ testAgreement builder inputs = do
116112 else do putStrLn "Failure:"
117113 putStrLn $ "Pure result: " <> show identityResult
118114 putStrLn $ "Spider result: " <> show spiderResult
119− putStrLn $ "Profiled result: " <> show profiledResult
120115 return resultsAgree
121116
122117type TestCaseConstraint t m = (Reflex t, MonadSample t m, MonadHold t m, MonadFix m, MonadFix (PushM t))
@@ -223,11 +218,6 @@ testCases =
223218 bb <- hold b $ pushAlways (const $ hold "asdf" eo) eo
224219 let b' = pull $ sample =<< sample bb
225220 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)
231221 , (,) "joinDyn" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
232222 bb <- hold "b" e
233223 bd <- hold never . fmap (const e) =<< headE e
test/Reflex/Test/Micro.hs+2−8
@@ -322,14 +322,8 @@ testCases =
322322 let e = never <$ switch b
323323 return $ void e
324324 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
325+
326+
333327 ] where
334328
335329 events1, events2, events3 :: TestPlan t m => m (Event t String)
test/RequesterT.hs+4−170
@@ -1,40 +1,15 @@
1−{-# LANGUAGE CPP #-}
21{-# LANGUAGE BangPatterns #-}
32{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
53{-# LANGUAGE GADTs #-}
6−{-# LANGUAGE LambdaCase #-}
7−{-# LANGUAGE MultiParamTypeClasses #-}
8−{-# LANGUAGE RecursiveDo #-}
4+{-# LANGUAGE RankNTypes #-}
95{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TemplateHaskell #-}
11−{-# LANGUAGE TypeApplications #-}
12−{-# LANGUAGE TypeFamilies #-}
136module Main where
147
15−import Control.Lens hiding (has)
8+import Control.Lens
169import 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
2210import qualified Data.Dependent.Map as DMap
2311import 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)
3212import 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
3813
3914import Reflex
4015import Reflex.Requester.Base
@@ -50,6 +25,7 @@ main = do
5025 [ Just ()
5126 ]
5227 print os1
28+ let ![[Just [10,9,8,7,6,5,4,3,2,1]]] = os1
5329 os2 <- runApp' (unwrapApp testSimultaneous) $ map Just $
5430 [ This ()
5531 , That ()
@@ -57,27 +33,7 @@ main = do
5733 , These () ()
5834 ]
5935 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−
36+ let ![[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]] = os2
8137 return ()
8238
8339unwrapRequest :: DSum tag RequestInt -> Int
@@ -111,125 +67,3 @@ testSimultaneous pulse = do
11167 switchE = fmapMaybe (^? there) pulse
11268 forM_ [1,3..9] $ \i -> runWithReplace (requestingIdentity (RequestInt i <$ tellE)) $ ffor switchE $ \_ ->
11369 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/hlint.hs+8−3
@@ -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
@@ -22,8 +22,6 @@ main = do
2222 , "--ignore=Use unless"
2323 , "--ignore=Reduce duplication"
2424 , "--cpp-define=USE_TEMPLATE_HASKELL"
25− , "--cpp-define=DEBUG"
26− , "--ignore=Use tuple-section"
2725 ]
2826 recurseInto = and <$> sequence
2927 [ fileType ==? Directory
@@ -31,9 +29,16 @@ main = do
3129 ]
3230 matchFile = and <$> sequence
3331 [ extension ==? ".hs"
32+ , let notElem' = liftOp notElem
33+ in filePath `notElem'` filePathExceptions pwd
3434 ]
3535 files <- find recurseInto matchFile (pwd </> "src") --TODO: Someday fix all hints in tests, etc.
3636 ideas <- fmap concat $ forM files $ \f -> do
3737 putStr $ "linting file " ++ drop (length pwd + 1) f ++ "... "
3838 runHlint f
3939 if null ideas then exitSuccess else exitFailure
40+
41+filePathExceptions :: FilePath -> [FilePath]
42+filePathExceptions pwd = map (pwd </>) $
43+ [ "src/Data/AppendMap.hs" -- parse error when hlint runs
44+ ]