git.iko.soy/reflex
on develop help sign in
swap
90891e1338 ahead, 9 behind
68 files changed+2141−2280
since splitsnapshots
unifiedsplit
.github/workflows/haskell.yml+41 .travis.yml−171 ChangeLog.md+110−5 Quickref.md+15−11 README.md+15−17 cabal.haskell-ci+7 cabal.project.freeze−1 default.nix−42 dep/reflex-platform/default.nix+7 dep/reflex-platform/github.json+7 hydra.json−29 jobsets.nix−70 reflex-platform.nix−8 reflex.cabal+136−37 release.nix+56−7 src/Control/Monad/ReaderIO.hs+60 src/Data/AppendMap.hs+2−2 src/Data/FastMutableIntMap.hs+7−3 src/Data/FastWeakBag.hs+9−4 src/Data/Functor/Misc.hs−234 src/Data/Map/Misc.hs+1−1 src/Data/WeakBag.hs+8−3 src/Reflex/Adjustable/Class.hs+3−2 src/Reflex/BehaviorWriter/Base.hs+16−7 src/Reflex/BehaviorWriter/Class.hs+11−5 src/Reflex/Class.hs+118−17 src/Reflex/Collection.hs+1−1 src/Reflex/Dynamic.hs+17−2 src/Reflex/DynamicWriter/Base.hs+14−5 src/Reflex/DynamicWriter/Class.hs−1 src/Reflex/EventWriter/Base.hs+16−5 src/Reflex/FastWeak.hs+10 src/Reflex/Host/Headless.hs+128 src/Reflex/Network.hs+1−1 src/Reflex/Patch.hs−46 src/Reflex/Patch/Class.hs−34 src/Reflex/Patch/DMap.hs−82 src/Reflex/Patch/DMapWithMove.hs−363 src/Reflex/Patch/DMapWithReset.hs−120 src/Reflex/Patch/IntMap.hs−59 src/Reflex/Patch/Map.hs−55 src/Reflex/Patch/MapWithMove.hs−270 src/Reflex/Patch/Patchable.hs−44 src/Reflex/PerformEvent/Base.hs+3−1 src/Reflex/PerformEvent/Class.hs+6−1 src/Reflex/PostBuild/Base.hs+2−1 src/Reflex/PostBuild/Class.hs−1 src/Reflex/Profiled.hs+77−15 src/Reflex/Pure.hs+27−14 src/Reflex/Query/Base.hs+15−4 src/Reflex/Query/Class.hs+44−4 src/Reflex/Requester/Base.hs+97−27 src/Reflex/Spider/Internal.hs+695−420 src/Reflex/TriggerEvent/Base.hs+2 src/Reflex/TriggerEvent/Class.hs+6 src/Reflex/Widget/Basic.hs+1−1 src/Reflex/Workflow.hs+1−1 test/Adjustable.hs+62 test/DebugCycles.hs+171 test/GC.hs+6−5 test/Headless.hs+10 test/QueryT.hs+1−1 test/Reflex/Bench/Focused.hs+12 test/Reflex/Plan/Pure.hs+1 test/Reflex/Test/CrossImpl.hs+13−8 test/Reflex/Test/Micro.hs+8−2 test/RequesterT.hs+63−2 test/hlint.hs+2−8
.github/workflows/haskell.ymlnew file+41
@@ -0,0 +1,41 @@
1+name: github-action
2+
3+on: [push, pull_request]
4+
5+jobs:
6+ build:
7+ strategy:
8+ matrix:
9+ ghc: ['8.4.4', '8.6.5', '8.8.4', '8.10.2']
10+ os: ['ubuntu-latest', 'macos-latest']
11+ runs-on: ${{ matrix.os }}
12+
13+ name: GHC ${{ matrix.ghc }} on ${{ matrix.os }}
14+ steps:
15+ - uses: actions/checkout@v2
16+ - uses: actions/setup-haskell@v1
17+ with:
18+ ghc-version: ${{ matrix.ghc }}
19+ - name: Cache
20+ uses: actions/cache@v1
21+ env:
22+ cache-name: cache-cabal
23+ with:
24+ path: ~/.cabal
25+ key: ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }}
26+ restore-keys: |
27+ ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-
28+ ${{ runner.os }}-${{ matrix.ghc }}-build-
29+ ${{ runner.os }}-${{ matrix.ghc }}-
30+ ${{ runner.os }}
31+
32+ - name: Install dependencies
33+ run: |
34+ cabal update
35+ cabal build --only-dependencies --enable-tests --enable-benchmarks
36+ - name: Build
37+ run: cabal build --enable-tests --enable-benchmarks all
38+ - name: Run tests
39+ run: cabal test all
40+ - name: Build Docs
41+ run: cabal haddock
.travis.ymldeleted−171
@@ -1,171 +0,0 @@
1−# This Travis job script has been generated by a script via
2−#
3−# haskell-ci '--config=cabal.haskell-ci' 'cabal.project'
4−#
5−# For more information, see https://github.com/haskell-CI/haskell-ci
6−#
7−# version: 0.3.20190814
8−#
9−language: c
10−dist: xenial
11−sudo: required
12−git:
13− # whether to recursively clone submodules
14− submodules: false
15−cache:
16− directories:
17− - $HOME/.cabal/packages
18− - $HOME/.cabal/store
19−before_cache:
20− - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
21− # remove files that are regenerated by 'cabal update'
22− - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*
23− - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json
24− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache
25− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar
26− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx
27− - rm -rfv $CABALHOME/packages/head.hackage
28−matrix:
29− include:
30− - compiler: ghcjs-8.4
31− addons: {"apt":{"sources":["hvr-ghc"],"packages":["cabal-install-3.0"]}}
32− - compiler: ghc-8.6.5
33− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-2.4"]}}
34− - compiler: ghc-8.4.4
35− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-2.4"]}}
36− - compiler: ghc-8.2.2
37− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-2.4"]}}
38− - compiler: ghc-8.0.2
39− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-2.4"]}}
40−before_install:
41− - |
42− if [ "$TRAVIS_OS_NAME" = "linux" ]; then
43− sudo add-apt-repository -y ppa:hvr/ghcjs;
44− curl -s https://deb.nodesource.com/gpgkey/nodesource.gpg.key | sudo apt-key add -
45− sudo apt-add-repository 'https://deb.nodesource.com/node_8.x xenial main'
46− sudo apt-get update;
47− sudo apt-get install $CC cabal-install-3.0 nodejs;
48− fi
49− - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')
50− - WITHCOMPILER="-w $HC"
51− - |
52− if echo $CC | grep -q ghcjs; then
53− GHCJS=true
54− HC=${HC}js
55− WITHCOMPILER="--ghcjs ${WITHCOMPILER}js"
56− else
57− GHCJS=false;
58− fi
59− - if $GHCJS ; then sudo apt-get install -y ghc-8.4.4 ; fi
60− - if $GHCJS ; then PATH="/opt/ghc/8.4.4/bin:$PATH" ; fi
61− - HCPKG="$HC-pkg"
62− - unset CC
63− - CABAL=/opt/ghc/bin/cabal
64− - CABALHOME=$HOME/.cabal
65− - export PATH="$CABALHOME/bin:$PATH"
66− - TOP=$(pwd)
67− - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')"
68− - echo $HCNUMVER
69− - CABAL="$CABAL -vnormal+nowrap+markoutput"
70− - set -o pipefail
71− - |
72− echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk
73− echo 'BEGIN { state = "output"; }' >> .colorful.awk
74− echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk
75− echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk
76− echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk
77− echo ' if (state == "cabal") {' >> .colorful.awk
78− echo ' print blue($0)' >> .colorful.awk
79− echo ' } else {' >> .colorful.awk
80− echo ' print $0' >> .colorful.awk
81− echo ' }' >> .colorful.awk
82− echo '}' >> .colorful.awk
83− - cat .colorful.awk
84− - |
85− color_cabal_output () {
86− awk -f $TOP/.colorful.awk
87− }
88− - echo text | color_cabal_output
89−install:
90− - ${CABAL} --version
91− - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
92− - node --version
93− - echo $GHCJS
94− - TEST=--enable-tests
95− - BENCH=--enable-benchmarks
96− - BENCH=--disable-benchmarks
97− - HEADHACKAGE=false
98− - rm -f $CABALHOME/config
99− - |
100− echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config
101− echo "remote-build-reporting: anonymous" >> $CABALHOME/config
102− echo "write-ghc-environment-files: always" >> $CABALHOME/config
103− echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config
104− echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config
105− echo "world-file: $CABALHOME/world" >> $CABALHOME/config
106− echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config
107− echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config
108− echo "installdir: $CABALHOME/bin" >> $CABALHOME/config
109− echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config
110− echo "store-dir: $CABALHOME/store" >> $CABALHOME/config
111− echo "install-dirs user" >> $CABALHOME/config
112− echo " prefix: $CABALHOME" >> $CABALHOME/config
113− echo "repository hackage.haskell.org" >> $CABALHOME/config
114− echo " url: http://hackage.haskell.org/" >> $CABALHOME/config
115− - cat $CABALHOME/config
116− - rm -fv cabal.project cabal.project.local cabal.project.freeze
117− - travis_retry ${CABAL} v2-update -v
118− - if $GHCJS ; then (cd /tmp && ${CABAL} v2-install -w ghc-8.4.4 happy) ; fi
119− # Generate cabal.project
120− - rm -rf cabal.project cabal.project.local cabal.project.freeze
121− - touch cabal.project
122− - |
123− echo "packages: ." >> cabal.project
124− - |
125− - cat cabal.project || true
126− - cat cabal.project.local || true
127− - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi
128− - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output
129− - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"
130− - rm cabal.project.freeze
131−script:
132− - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
133− # Packaging...
134− - ${CABAL} v2-sdist all | color_cabal_output
135− # Unpacking...
136− - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
137− - cd ${DISTDIR} || false
138− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;
139− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \;
140− - PKGDIR_reflex="$(find . -maxdepth 1 -type d -regex '.*/reflex-[0-9.]*')"
141− # Generate cabal.project
142− - rm -rf cabal.project cabal.project.local cabal.project.freeze
143− - touch cabal.project
144− - |
145− echo "packages: ${PKGDIR_reflex}" >> cabal.project
146− - |
147− - cat cabal.project || true
148− - cat cabal.project.local || true
149− # Building...
150− # this builds all libraries and executables (without tests/benchmarks)
151− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output
152− # Building with tests and benchmarks...
153− # build & run tests, build benchmarks
154− - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output
155− # Testing...
156− - if ! $GHCJS ; then ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi
157− # cabal check...
158− - (cd ${PKGDIR_reflex} && ${CABAL} -vnormal check)
159− # haddock...
160− - if ! $GHCJS ; then ${CABAL} v2-haddock $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi
161− # Constraint sets
162− - rm -rf cabal.project.local
163− # Constraint set no-th
164− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='reflex -use-template-haskell' all | color_cabal_output
165− # Constraint set old-these
166− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='these <1' all | color_cabal_output
167− # Constraint set old-witherable
168− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='witherable <0.3.2' all | color_cabal_output
169−
170−# REGENDATA ["--config=cabal.haskell-ci","cabal.project"]
171−# EOF
ChangeLog.md+110−5
@@ -1,5 +1,87 @@
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+
385## 0.6.2.4
486
587* Update to monoidal-containers 0.6
@@ -11,36 +93,59 @@
1193## 0.6.2.2
1294
1395* Support these >= 1. Add `split-these` flag to control whether to use new these/semialign combination or not.
96+
1497* Update version bounds to fix some CI failures
98+
1599* Add travis CI configuration
16100
17101## 0.6.2.1
18102
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+
19112* Generalize merging functions:
20− `merge` to `mergeG`,
21− `mergeIncremental` to `mergeIncrementalG`,
22− `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`,
23− `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`.
113+ `merge` to `mergeG`,
114+ `mergeIncremental` to `mergeIncrementalG`,
115+ `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`.
116+
117+* Generalize distribute function:
118+ `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`,
24119
25120## 0.6.2.0
26121
27−* Fix `holdDyn` so that it is lazy in its event argument
122+* Fix `holdDyn` so that it is lazy in its event argument
28123 These produce `DMap`s whose values needn't be `Identity`.
124+
29125* Stop using the now-deprecated `*Tag` classes (e.g., `ShowTag`).
126+
30127* Fix `holdDyn` so that it is lazy in its event argument.
31128
32129## 0.6.1.0
33130
34131* Re-export all of `Data.Map.Monoidal`
132+
35133* Fix `QueryT` and `RequesterT` tests
36134
37135## 0.6.0.0 -- 2019-03-20
38136
39137* Deprecate `FunctorMaybe` in favor of `Data.Witherable.Filterable`. We still export `fmapMaybe`, `ffilter`, etc., but they all rely on `Filterable` now.
138+
40139* Rename `MonadDynamicWriter` to `DynamicWriter` and add a deprecation for the old name.
140+
41141* Remove many deprecated functions.
142+
42143* Add a `Num` instance for `Dynamic`.
144+
43145* Add `matchRequestsWithResponses` to make it easier to use `Requester` with protocols that don't do this matching for you.
146+
44147* Add `withRequesterT` to map functions over the request and response of a `RequesterT`.
148+
45149* Suppress nil patches in `QueryT` as an optimization. The `Query` type must now have an `Eq` instance.
150+
46151* Add `throttleBatchWithLag` to `Reflex.Time`. See that module for details.
Quickref.md+15−11
@@ -54,6 +54,7 @@ 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
5758[ ] mergeWith :: (a -> a -> a) -> [Event a] -> Event a
5859[ ] leftmost :: [Event a] -> Event a
5960[ ] mergeList :: [Event a] -> Event (NonEmpty a)
@@ -198,7 +199,7 @@ For Events, the returned Event fires whenever the latest Event supplied by the w
198199The functions mentioned above are used to create a static FRP network.
199200There 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.
200201
201−Th typeclasses and their associated annotations include:
202+The typeclasses and their associated annotations include:
202203
203204- `PostBuild`
204205 Fire an Event when an FRP network has been set up.
@@ -206,7 +207,7 @@ Th typeclasses and their associated annotations include:
206207 [B] -- Function runs in any monad supporting PostBuild
207208 ```
208209
209−- `Adjustable`
210+- `Adjustable`
210211 Use Events to add or remove pieces of an FRP network.
211212 ```haskell
212213 [A] -- Function runs in any monad supporting Adjustable
@@ -271,7 +272,7 @@ Th typeclasses and their associated annotations include:
271272```haskell
272273-- Run side-effecting actions in Event when it occurs; returned Event contains
273274-- results. Side effects run in the (Performable m) monad which is associated with
274−-- the (PerformEvent t m) typeclass constraint.
275+-- the (PerformEvent t m) typeclass constraint.
275276-- This allows for working with IO when a ((MonadIO (Performable m)) constraint is available.
276277[P] performEvent :: Event (Performable m a ) -> m (Event a)
277278
@@ -295,17 +296,20 @@ Th typeclasses and their associated annotations include:
295296## Networks
296297
297298```haskell
298−-- Functions from Reflex.Network used to deal with Dynamics/Events carrying (m a)
299+-- Functions from Reflex.Adjustable / Reflex.Network used to deal with Dynamics/Events carrying (m a)
299300
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,
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,
302305-- in which case the return value is an Event-of-Events that would typically be flattened (via switchHold).
303−[P,A] networkView :: Dynamic (m a) -> m (Event a)
306+[P,A] networkView :: Dynamic (m a) -> m (Event a)
304307
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
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
307310-- Event, in which case the return value is a Dynamic-of-Events that would typically be flattened.
308−[H,A] networkHold :: m a -> Event (m a) -> m (Dynamic a)
311+[H,A] networkHold :: m a -> Event (m a) -> m (Dynamic a)
309312
310313-- Render a placeholder network to be shown while another network is not yet done building
311−[P,A] untilReady :: m a -> m b -> m (a, Event b)
314+[P,A] untilReady :: m a -> m b -> m (a, Event b)
315+```
README.md+15−17
@@ -1,25 +1,23 @@
1−## [Reflex](https://reflex-frp.org/)
1+# [Reflex](https://reflex-frp.org/)
22
3−[![Hackage](https://img.shields.io/hackage/v/reflex.svg)](http://hackage.haskell.org/package/reflex)
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)
44
5−### Practical Functional Reactive Programming
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.
66
7−Reflex is a fully-deterministic, higher-order Functional Reactive Programming (FRP) interface and an engine that efficiently implements that interface.
7+Reflex is a fully-deterministic, higher-order Functional Reactive Programming interface and an engine that efficiently implements that interface.
88
9−[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.
9+**Visit https://reflex-frp.org for more information, tutorials, documentation and [examples](https://examples.reflex-frp.org/).**
1010
11−A summary of Reflex functions is available in the [quick reference](Quickref.md).
11+## Resources
1212
13−**Visit https://reflex-frp.org/ for more information, tutorials, documentation and [examples](https://examples.reflex-frp.org/).**
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)
1420
15−### Resources
16−[Get started with Reflex](https://github.com/reflex-frp/reflex-platform)
21+## Hacking
1722
18−[/r/reflexfrp](https://www.reddit.com/r/reflexfrp)
19−
20−[irc.freenode.net #reflex-frp](http://webchat.freenode.net?channels=%23reflex-frp&uio=d4)
21−
22−### Hacking
23−
24−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.
25−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.
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.
cabal.haskell-ci+7
@@ -10,7 +10,14 @@ constraint-set no-th
1010 constraints: reflex -use-template-haskell
1111
1212constraint-set old-these
13+ ghc: <8.8
1314 constraints: these <1
1415
1516constraint-set old-witherable
1617 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.project.freezedeleted−1
@@ -1 +0,0 @@
1−constraints: any.text < 1.2.4.0
default.nixdeleted−42
@@ -1,42 +0,0 @@
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, profunctors
10−, semialign ? null, splitThese ? (semialign != null)
11−, useTemplateHaskell ? true
12−}:
13−mkDerivation {
14− pname = "reflex";
15− version = "0.6.2.4";
16− src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.;
17− libraryHaskellDepends = [
18− base bifunctors containers dependent-map dependent-sum
19− exception-transformers lens
20− MemoTrie monad-control mtl primitive ref-tf semigroupoids
21− semigroups stm syb template-haskell these transformers
22− transformers-compat prim-uniq
23− base bifunctors containers deepseq dependent-map dependent-sum
24− mtl ref-tf split transformers data-default
25− random time unbounded-delays monoidal-containers witherable
26− ] ++ (if ghc.isGhcjs or false then [
27− ghcjs-base
28− ] else []) ++ (if !useTemplateHaskell then [] else [
29− haskell-src-exts haskell-src-meta
30− ]) ++ (if splitThese then [
31− semialign
32− ] else []);
33− testHaskellDepends = if ghc.isGhcjs or false then [] else [
34− hlint filepath directory filemanip
35− ];
36− configureFlags =
37− stdenv.lib.optional (!useTemplateHaskell) [ "-f-use-template-haskell" ] ++
38− stdenv.lib.optional (!splitThese) [ "-f-split-these" ];
39− homepage = "https://github.com/reflex-frp/reflex";
40− description = "Higher-order Functional Reactive Programming";
41− license = stdenv.lib.licenses.bsd3;
42−}
dep/reflex-platform/default.nixnew file+7
@@ -0,0 +1,7 @@
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.jsonnew file+7
@@ -0,0 +1,7 @@
1+{
2+ "owner": "reflex-frp",
3+ "repo": "reflex-platform",
4+ "branch": "develop",
5+ "rev": "f628398d076243a0851b27e625b37f65dff9b89b",
6+ "sha256": "0sl0hf1glgyb1vmf2mhw4r9ipmcqk1y19d3wsic7dix2jwywzrh9"
7+}
hydra.jsondeleted−29
@@ -1,29 +0,0 @@
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.nixdeleted−70
@@ -1,70 +0,0 @@
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.nixdeleted−8
@@ -1,8 +0,0 @@
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+136−37
@@ -1,7 +1,17 @@
11Name: reflex
2−Version: 0.6.2.4
2+Version: 0.8.2.0
33Synopsis: Higher-order Functional Reactive Programming
4−Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system
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>
515License: BSD3
616License-file: LICENSE
717Author: Ryan Trinkle
@@ -9,7 +19,7 @@ Maintainer: ryan.trinkle@gmail.com
919Stability: Experimental
1020Category: FRP
1121Build-type: Simple
12−Cabal-version: >=1.9.2
22+Cabal-version: 1.22
1323homepage: https://reflex-frp.org
1424bug-reports: https://github.com/reflex-frp/reflex/issues
1525extra-source-files:
@@ -18,8 +28,8 @@ extra-source-files:
1828 ChangeLog.md
1929
2030tested-with:
21− GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5,
22− GHCJS ==8.4
31+ GHC ==8.4.4 || ==8.6.5 || ==8.8.1 || ==8.10.2,
32+ GHCJS ==8.6
2333
2434flag use-reflex-optimizer
2535 description: Use the GHC plugin Reflex.Optimizer on some of the modules in the package. This is still experimental.
@@ -41,43 +51,56 @@ flag fast-weak
4151 default: False
4252 manual: True
4353
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+
4464flag split-these
4565 description: Use split these/semialign packages
4666 manual: False
4767 default: True
4868
4969library
70+ default-language: Haskell2010
5071 hs-source-dirs: src
5172 build-depends:
5273 MemoTrie == 0.6.*,
53− base >= 4.9 && < 4.13,
74+ base >= 4.11 && < 4.15,
5475 bifunctors >= 5.2 && < 5.6,
5576 comonad >= 5.0.4 && < 5.1,
77+ constraints >= 0.10 && <0.14,
5678 constraints-extras >= 0.3 && < 0.4,
5779 containers >= 0.6 && < 0.7,
5880 data-default >= 0.5 && < 0.8,
59− dependent-map >= 0.3 && < 0.4,
81+ dependent-map >= 0.3 && < 0.5,
6082 exception-transformers == 0.4.*,
61− profunctors >= 5.3 && < 5.5,
6283 lens >= 4.7 && < 5,
84+ mmorph >= 1.0 && < 1.2,
6385 monad-control >= 1.0.1 && < 1.1,
6486 mtl >= 2.1 && < 2.3,
65− prim-uniq >= 0.1.0.1 && < 0.2,
87+ patch >= 0.0.1 && < 0.1,
88+ prim-uniq >= 0.1.0.1 && < 0.3,
6689 primitive >= 0.5 && < 0.8,
67− profunctors,
90+ profunctors >= 5.3 && < 5.7,
6891 random == 1.1.*,
6992 ref-tf == 0.4.*,
7093 reflection == 2.1.*,
7194 semigroupoids >= 4.0 && < 6,
7295 stm >= 2.4 && < 2.6,
7396 syb >= 0.5 && < 0.8,
74− time >= 1.4 && < 1.9,
97+ time >= 1.4 && < 1.10,
7598 transformers >= 0.5.6.0 && < 0.6,
7699 unbounded-delays >= 0.1.0.0 && < 0.2,
77− witherable >= 0.3 && < 0.3.2
100+ witherable >= 0.3 && < 0.5
78101
79102 if flag(split-these)
80− build-depends: these >= 1 && <1.1,
103+ build-depends: these >= 1 && <1.2,
81104 semialign >=1 && <1.2,
82105 monoidal-containers >= 0.6 && < 0.7
83106 else
@@ -85,10 +108,10 @@ library
85108 monoidal-containers == 0.4.0.0
86109
87110 exposed-modules:
111+ Control.Monad.ReaderIO
88112 Data.AppendMap,
89113 Data.FastMutableIntMap,
90114 Data.FastWeakBag,
91− Data.Functor.Misc,
92115 Data.Map.Misc,
93116 Data.WeakBag,
94117 Reflex,
@@ -108,17 +131,9 @@ library
108131 Reflex.FastWeak,
109132 Reflex.FunctorMaybe,
110133 Reflex.Host.Class,
134+ Reflex.Host.Headless,
111135 Reflex.Network,
112136 Reflex.NotReady.Class,
113− Reflex.Patch,
114− Reflex.Patch.Class,
115− Reflex.Patch.DMap,
116− Reflex.Patch.DMapWithMove,
117− Reflex.Patch.DMapWithReset,
118− Reflex.Patch.IntMap,
119− Reflex.Patch.Map,
120− Reflex.Patch.MapWithMove,
121− Reflex.Patch.Patchable,
122137 Reflex.PerformEvent.Base,
123138 Reflex.PerformEvent.Class,
124139 Reflex.PostBuild.Base,
@@ -137,38 +152,57 @@ library
137152 Reflex.Widget.Basic,
138153 Reflex.Workflow
139154
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+
140165 ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively
141166
142167 if flag(debug-trace-events)
143168 cpp-options: -DDEBUG_TRACE_EVENTS
144− build-depends: bytestring
169+ build-depends:
170+ bytestring >= 0.10.8 && < 0.11
145171
146172 if flag(use-reflex-optimizer)
147173 cpp-options: -DUSE_REFLEX_OPTIMIZER
148174 build-depends: ghc
149175 exposed-modules: Reflex.Optimizer
150176
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+
151183 if flag(use-template-haskell)
152184 cpp-options: -DUSE_TEMPLATE_HASKELL
153185 build-depends:
154− dependent-sum >= 0.6 && < 0.7,
155− haskell-src-exts >= 1.16 && < 1.22,
186+ dependent-sum >= 0.6 && < 0.8,
187+ haskell-src-exts >= 1.16 && < 1.24,
156188 haskell-src-meta >= 0.6 && < 0.9,
157− template-haskell >= 2.9 && < 2.15
189+ template-haskell >= 2.9 && < 2.17
158190 exposed-modules:
159191 Reflex.Dynamic.TH
160192 other-extensions: TemplateHaskell
161193 else
162194 build-depends:
163− dependent-sum >= 0.6 && < 0.7
195+ dependent-sum >= 0.6 && < 0.8
164196
165197 if flag(fast-weak) && impl(ghcjs)
166198 cpp-options: -DGHCJS_FAST_WEAK
167199
168200 if impl(ghcjs)
169− build-depends: ghcjs-base
201+ build-depends:
202+ ghcjs-base == 0.2.*
170203
171204test-suite semantics
205+ default-language: Haskell2010
172206 type: exitcode-stdio-1.0
173207 main-is: semantics.hs
174208 hs-source-dirs: test
@@ -194,6 +228,7 @@ test-suite semantics
194228 Reflex.TestPlan
195229
196230test-suite CrossImpl
231+ default-language: Haskell2010
197232 type: exitcode-stdio-1.0
198233 main-is: Reflex/Test/CrossImpl.hs
199234 hs-source-dirs: test
@@ -215,6 +250,7 @@ test-suite CrossImpl
215250 Reflex.Plan.Pure
216251
217252test-suite hlint
253+ default-language: Haskell2010
218254 type: exitcode-stdio-1.0
219255 main-is: hlint.hs
220256 hs-source-dirs: test
@@ -222,11 +258,15 @@ test-suite hlint
222258 , directory
223259 , filepath
224260 , filemanip
225− , hlint < 2.1 || >= 2.2.2
261+ if impl(ghc >= 8.8)
262+ build-depends: hlint >= 3 && < 4
263+ else
264+ build-depends: hlint (< 2.1 || >= 2.2.2) && < 4
226265 if impl(ghcjs)
227266 buildable: False
228267
229268test-suite EventWriterT
269+ default-language: Haskell2010
230270 type: exitcode-stdio-1.0
231271 main-is: EventWriterT.hs
232272 hs-source-dirs: test
@@ -246,28 +286,57 @@ test-suite EventWriterT
246286 build-depends: these-lens
247287
248288 other-modules:
249− Reflex.Test
250− Reflex.TestPlan
251− Reflex.Plan.Reflex
252− Reflex.Plan.Pure
253289 Test.Run
254290
255291
256−test-suite RequesterT
292+test-suite DebugCycles
293+ default-language: Haskell2010
257294 type: exitcode-stdio-1.0
258− main-is: RequesterT.hs
295+ main-is: DebugCycles.hs
259296 hs-source-dirs: test
297+ ghc-options: -threaded
260298 build-depends: base
261299 , containers
262300 , deepseq
263− , dependent-sum
264301 , dependent-map
302+ , dependent-sum
303+ , hspec
265304 , lens
266305 , mtl
267306 , these
268307 , transformers
269308 , reflex
270309 , ref-tf
310+ , witherable
311+ , proctest
312+
313+
314+ if flag(split-these)
315+ build-depends: these-lens, semialign
316+
317+ other-modules:
318+ Test.Run
319+
320+
321+test-suite RequesterT
322+ default-language: Haskell2010
323+ type: exitcode-stdio-1.0
324+ main-is: RequesterT.hs
325+ hs-source-dirs: test
326+ build-depends: base
327+ , constraints
328+ , constraints-extras
329+ , containers
330+ , deepseq
331+ , dependent-map
332+ , dependent-sum
333+ , lens
334+ , mtl
335+ , ref-tf
336+ , reflex
337+ , text
338+ , these
339+ , transformers
271340
272341 if flag(split-these)
273342 build-depends: these-lens
@@ -277,7 +346,31 @@ test-suite RequesterT
277346 Reflex.Plan.Pure
278347 Test.Run
279348
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
365+ , reflex
366+ , ref-tf
367+ , these
368+
369+ other-modules:
370+ Test.Run
371+
280372test-suite QueryT
373+ default-language: Haskell2010
281374 type: exitcode-stdio-1.0
282375 main-is: QueryT.hs
283376 hs-source-dirs: test
@@ -289,6 +382,7 @@ test-suite QueryT
289382 , lens
290383 , monoidal-containers
291384 , mtl
385+ , patch
292386 , ref-tf
293387 , reflex
294388 , these
@@ -304,6 +398,7 @@ test-suite QueryT
304398 Reflex.Plan.Pure
305399
306400test-suite GC-Semantics
401+ default-language: Haskell2010
307402 type: exitcode-stdio-1.0
308403 main-is: GC.hs
309404 hs-source-dirs: test
@@ -313,6 +408,7 @@ test-suite GC-Semantics
313408 , dependent-map
314409 , deepseq
315410 , mtl
411+ , patch
316412 , these
317413 , transformers
318414 , reflex
@@ -328,6 +424,7 @@ test-suite GC-Semantics
328424 Test.Run
329425
330426test-suite rootCleanup
427+ default-language: Haskell2010
331428 type: exitcode-stdio-1.0
332429 main-is: rootCleanup.hs
333430 hs-source-dirs: test
@@ -345,6 +442,7 @@ test-suite rootCleanup
345442 Test.Run
346443
347444benchmark spider-bench
445+ default-language: Haskell2010
348446 type: exitcode-stdio-1.0
349447 hs-source-dirs: bench test
350448 main-is: Main.hs
@@ -369,6 +467,7 @@ benchmark spider-bench
369467 Reflex.Bench.Focused
370468
371469benchmark saulzar-bench
470+ default-language: Haskell2010
372471 type: exitcode-stdio-1.0
373472 hs-source-dirs: bench test
374473 c-sources: bench-cbits/checkCapability.c
release.nix+56−7
@@ -1,9 +1,58 @@
1−{ rp ? import ./reflex-platform.nix {}
1+{ reflex-platform-fun ? import ./dep/reflex-platform
2+, supportedSystems ? ["x86_64-linux" "x86_64-darwin"]
23}:
4+
35let
4− inherit (rp.nixpkgs) lib;
5− compilers = ["ghc8_4" "ghc8_0" "ghcjs8_4" "ghcjs8_0"];
6−in lib.attrValues (lib.genAttrs compilers (ghc: {
7− reflex-useTemplateHaskell = rp.${ghc}.callPackage ./. { useTemplateHaskell = true; splitThese = false; };
8− reflex = rp.${ghc}.callPackage ./. { useTemplateHaskell = false; splitThese = false; };
9−}))
6+ native-reflex-platform = reflex-platform-fun {};
7+ inherit (native-reflex-platform.nixpkgs) lib;
8+
9+ perPlatform = lib.genAttrs supportedSystems (system: let
10+ reflex-platform = reflex-platform-fun { inherit system; };
11+ compilers = [
12+ "ghc"
13+ "ghcjs"
14+ ] ++ lib.optionals (reflex-platform.androidSupport) [
15+ "ghcAndroidAarch64"
16+ "ghcAndroidAarch32"
17+ ] ++ lib.optionals (reflex-platform.iosSupport) [
18+ "ghcIosAarch64"
19+ ];
20+ variations = map (v: "reflex" + v) [
21+ "-dontUseTemplateHaskell"
22+ ""
23+ ];
24+ compilerPkgs = lib.genAttrs compilers (ghc: let
25+ variationPkgs = lib.genAttrs variations (variation: let
26+ reflex-platform = reflex-platform-fun {
27+ inherit system;
28+ __useTemplateHaskell = variation == "reflex"; # TODO hack
29+ haskellOverlays = [
30+ # Use this package's source for reflex
31+ (self: super: {
32+ _dep = super._dep // {
33+ reflex = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [
34+ "release.nix"
35+ ".git"
36+ "dist"
37+ "cabal.haskell-ci"
38+ "cabal.project"
39+ ".travis.yml"
40+ ])) ./.;
41+ };
42+ })
43+ ];
44+ };
45+ in reflex-platform.${ghc}.reflex);
46+ in variationPkgs // {
47+ cache = reflex-platform.pinBuildInputs "reflex-${system}-${ghc}"
48+ (builtins.attrValues variationPkgs);
49+ });
50+ in compilerPkgs // {
51+ cache = reflex-platform.pinBuildInputs "reflex-${system}"
52+ (map (a: a.cache) (builtins.attrValues compilerPkgs));
53+ });
54+
55+ metaCache = native-reflex-platform.pinBuildInputs "reflex-everywhere"
56+ (map (a: a.cache) (builtins.attrValues perPlatform));
57+
58+in perPlatform // { inherit metaCache; }
src/Control/Monad/ReaderIO.hsnew file+60
@@ -0,0 +1,60 @@
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+2−2
@@ -20,7 +20,7 @@ module Data.AppendMap
2020 , module Data.Map.Monoidal
2121 ) where
2222
23−import Prelude hiding (map, null)
23+import Prelude hiding (null)
2424
2525import Data.Coerce
2626import Data.Default
@@ -71,7 +71,7 @@ mapMaybeNoNull f as =
7171 then Nothing
7272 else Just bs
7373
74−-- TODO: Move instances to `Reflex.Patch`
74+-- TODO: Move instances to `Data.Patch`
7575-- | Displays a 'MonoidalMap' as a tree. See 'Data.Map.Lazy.showTree' for details.
7676showTree :: forall k a. (Show k, Show a) => MonoidalMap k a -> String
7777showTree = coerce (Map.showTree :: Map k a -> String)
src/Data/FastMutableIntMap.hs+7−3
@@ -21,6 +21,7 @@ module Data.FastMutableIntMap
2121 , patchIntMapNewElements
2222 , patchIntMapNewElementsMap
2323 , getDeletions
24+ , toList
2425 ) where
2526
2627--TODO: Pure JS version
@@ -34,8 +35,8 @@ import Data.Foldable (traverse_)
3435import Data.IntMap.Strict (IntMap)
3536import qualified Data.IntMap.Strict as IntMap
3637import Data.IORef
37−import Reflex.Patch.Class
38−import Reflex.Patch.IntMap
38+import Data.Patch.Class
39+import Data.Patch.IntMap
3940
4041-- | A 'FastMutableIntMap' holds a map of values of type @a@ and allows low-overhead modifications via IO.
4142-- Operations on 'FastMutableIntMap' run in IO.
@@ -84,10 +85,13 @@ getFrozenAndClear (FastMutableIntMap r) = do
8485 writeIORef r IntMap.empty
8586 return result
8687
87−-- | Updates the value of a 'FastMutableIntMap' with the given patch (see 'Reflex.Patch.IntMap'),
88+-- | Updates the value of a 'FastMutableIntMap' with the given patch (see 'Data.Patch.IntMap'),
8889-- and returns an 'IntMap' with the modified keys and values.
8990applyPatch :: FastMutableIntMap a -> PatchIntMap a -> IO (IntMap a)
9091applyPatch (FastMutableIntMap r) p@(PatchIntMap m) = do
9192 v <- readIORef r
9293 writeIORef r $! applyAlways p v
9394 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+9−4
@@ -18,6 +18,7 @@ module Data.FastWeakBag
1818 , isEmpty
1919 , insert
2020 , traverse
21+ , traverse_
2122 , remove
2223 -- * Internal functions
2324 -- These will not always be available.
@@ -116,14 +117,14 @@ foreign import javascript unsafe "(function(){ for(var i = 0; i < $1.tickets.len
116117isEmpty bag = {-# SCC "isEmpty" #-} IntMap.null <$> readIORef (_weakBag_children bag)
117118#endif
118119
119−{-# INLINE traverse #-}
120+{-# INLINE traverse_ #-}
120121-- | Visit every node in the given list. If new nodes are appended during the
121122-- traversal, they will not be visited. Every live node that was in the list
122123-- when the traversal began will be visited exactly once; however, no guarantee
123124-- is made about the order of the traversal.
124−traverse :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m ()
125+traverse_ :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m ()
125126#ifdef GHCJS_FAST_WEAK
126−traverse wb f = do
127+traverse_ wb f = do
127128 let go cursor = when (not $ js_isNull cursor) $ do
128129 val <- liftIO $ js_getTicketValue cursor
129130 f $ unsafeFromRawJSVal val
@@ -134,13 +135,17 @@ foreign import javascript unsafe "$r = $1.val;" js_getTicketValue :: JSVal -> IO
134135--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
135136foreign 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
136137#else
137−traverse (FastWeakBag _ children) f = {-# SCC "traverse" #-} do
138+traverse_ (FastWeakBag _ children) f = {-# SCC "traverse_" #-} do
138139 cs <- liftIO $ readIORef children
139140 forM_ cs $ \c -> do
140141 ma <- liftIO $ deRefWeak c
141142 mapM_ f ma
142143#endif
143144
145+{-# DEPRECATED traverse "Use 'traverse_' instead" #-}
146+traverse :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m ()
147+traverse = traverse_
148+
144149-- | Remove an item from the 'FastWeakBag'; does nothing if invoked multiple times
145150-- on the same 'FastWeakBagTicket'.
146151{-# INLINE remove #-}
src/Data/Functor/Misc.hsdeleted−234
@@ -1,234 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveDataTypeable #-}
3−{-# LANGUAGE DeriveFunctor #-}
4−{-# LANGUAGE FlexibleContexts #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE GADTs #-}
7−{-# LANGUAGE LambdaCase #-}
8−{-# LANGUAGE MultiParamTypeClasses #-}
9−{-# LANGUAGE PatternSynonyms #-}
10−{-# LANGUAGE PolyKinds #-}
11−{-# LANGUAGE RankNTypes #-}
12−{-# LANGUAGE ScopedTypeVariables #-}
13−{-# LANGUAGE StandaloneDeriving #-}
14−#ifdef USE_REFLEX_OPTIMIZER
15−{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
16−#endif
17−-- | This module provides types and functions with no particular theme, but
18−-- which are relevant to the use of 'Functor'-based datastructures like
19−-- 'Data.Dependent.Map.DMap'.
20−module Data.Functor.Misc
21− ( -- * Const2
22− Const2 (..)
23− , unConst2
24− , dmapToMap
25− , dmapToIntMap
26− , dmapToMapWith
27− , mapToDMap
28− , weakenDMapWith
29− -- * WrapArg
30− , WrapArg (..)
31− -- * Convenience functions for DMap
32− , mapWithFunctorToDMap
33− , intMapWithFunctorToDMap
34− , mapKeyValuePairsMonotonic
35− , combineDMapsWithKey
36− , EitherTag (..)
37− , dmapToThese
38− , eitherToDSum
39− , dsumToEither
40− , ComposeMaybe (..)
41− ) where
42−
43−import Control.Applicative ((<$>))
44−import Control.Monad.Identity
45−import Data.Dependent.Map (DMap)
46−import qualified Data.Dependent.Map as DMap
47−import Data.Dependent.Sum
48−import Data.GADT.Compare
49−import Data.GADT.Show
50−import Data.IntMap (IntMap)
51−import qualified Data.IntMap as IntMap
52−import Data.Map (Map)
53−import qualified Data.Map as Map
54−import Data.Some (Some(Some))
55−import Data.These
56−import Data.Typeable hiding (Refl)
57−
58−--------------------------------------------------------------------------------
59−-- Const2
60−--------------------------------------------------------------------------------
61−
62−-- | 'Const2' stores a value of a given type 'k' and ensures that a particular
63−-- type 'v' is always given for the last type parameter
64−data Const2 :: * -> x -> x -> * where
65− Const2 :: k -> Const2 k v v
66− deriving (Typeable)
67−
68−-- | Extract the value from a Const2
69−unConst2 :: Const2 k v v' -> k
70−unConst2 (Const2 k) = k
71−
72−deriving instance Eq k => Eq (Const2 k v v')
73−deriving instance Ord k => Ord (Const2 k v v')
74−deriving instance Show k => Show (Const2 k v v')
75−deriving instance Read k => Read (Const2 k v v)
76−
77−instance Show k => GShow (Const2 k v) where
78− gshowsPrec n x@(Const2 _) = showsPrec n x
79−
80−instance Eq k => GEq (Const2 k v) where
81− geq (Const2 a) (Const2 b) =
82− if a == b
83− then Just Refl
84− else Nothing
85−
86−instance Ord k => GCompare (Const2 k v) where
87− gcompare (Const2 a) (Const2 b) = case compare a b of
88− LT -> GLT
89− EQ -> GEQ
90− GT -> GGT
91−
92−-- | Convert a 'DMap' to a regular 'Map'
93−dmapToMap :: DMap (Const2 k v) Identity -> Map k v
94−dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList
95−
96−-- | Convert a 'DMap' to an 'IntMap'
97−dmapToIntMap :: DMap (Const2 IntMap.Key v) Identity -> IntMap v
98−dmapToIntMap = IntMap.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList
99−
100−-- | Convert a 'DMap' to a regular 'Map', applying the given function to remove
101−-- the wrapping 'Functor'
102−dmapToMapWith :: (f v -> v') -> DMap (Const2 k v) f -> Map k v'
103−dmapToMapWith f = Map.fromDistinctAscList . map (\(Const2 k :=> v) -> (k, f v)) . DMap.toAscList
104−
105−-- | Convert a regular 'Map' to a 'DMap'
106−mapToDMap :: Map k v -> DMap (Const2 k v) Identity
107−mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> Identity v) . Map.toAscList
108−
109−-- | Convert a regular 'Map', where the values are already wrapped in a functor,
110−-- to a 'DMap'
111−mapWithFunctorToDMap :: Map k (f v) -> DMap (Const2 k v) f
112−mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . Map.toAscList
113−
114−-- | Convert a regular 'IntMap', where the values are already wrapped in a
115−-- functor, to a 'DMap'
116−intMapWithFunctorToDMap :: IntMap (f v) -> DMap (Const2 IntMap.Key v) f
117−intMapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . IntMap.toAscList
118−
119−-- | Convert a 'DMap' to a regular 'Map' by forgetting the types associated with
120−-- the keys, using a function to remove the wrapping 'Functor'
121−weakenDMapWith :: (forall a. v a -> v') -> DMap k v -> Map (Some k) v'
122−weakenDMapWith f = Map.fromDistinctAscList . map (\(k :=> v) -> (Some k, f v)) . DMap.toAscList
123−
124−--------------------------------------------------------------------------------
125−-- WrapArg
126−--------------------------------------------------------------------------------
127−
128−-- | 'WrapArg' can be used to tag a value in one functor with a type
129−-- representing another functor. This was primarily used with dependent-map <
130−-- 0.2, in which the value type was not wrapped in a separate functor.
131−data WrapArg :: (k -> *) -> (k -> *) -> * -> * where
132− WrapArg :: f a -> WrapArg g f (g a)
133−
134−deriving instance Eq (f a) => Eq (WrapArg g f (g' a))
135−deriving instance Ord (f a) => Ord (WrapArg g f (g' a))
136−deriving instance Show (f a) => Show (WrapArg g f (g' a))
137−deriving instance Read (f a) => Read (WrapArg g f (g a))
138−
139−instance GEq f => GEq (WrapArg g f) where
140− geq (WrapArg a) (WrapArg b) = (\Refl -> Refl) <$> geq a b
141−
142−instance GCompare f => GCompare (WrapArg g f) where
143− gcompare (WrapArg a) (WrapArg b) = case gcompare a b of
144− GLT -> GLT
145− GEQ -> GEQ
146− GGT -> GGT
147−
148−--------------------------------------------------------------------------------
149−-- Convenience functions for DMap
150−--------------------------------------------------------------------------------
151−
152−-- | Map over all key/value pairs in a 'DMap', potentially altering the key as
153−-- well as the value. The provided function MUST preserve the ordering of the
154−-- keys, or the resulting 'DMap' will be malformed.
155−mapKeyValuePairsMonotonic :: (DSum k v -> DSum k' v') -> DMap k v -> DMap k' v'
156−mapKeyValuePairsMonotonic f = DMap.fromDistinctAscList . map f . DMap.toAscList
157−
158−{-# INLINE combineDMapsWithKey #-}
159−-- | Union two 'DMap's of different types, yielding another type. Each key that
160−-- is present in either input map will be present in the output.
161−combineDMapsWithKey :: forall f g h i.
162− GCompare f
163− => (forall a. f a -> These (g a) (h a) -> i a)
164− -> DMap f g
165− -> DMap f h
166− -> DMap f i
167−combineDMapsWithKey f mg mh = DMap.fromList $ go (DMap.toList mg) (DMap.toList mh)
168− where go :: [DSum f g] -> [DSum f h] -> [DSum f i]
169− go [] hs = map (\(hk :=> hv) -> hk :=> f hk (That hv)) hs
170− go gs [] = map (\(gk :=> gv) -> gk :=> f gk (This gv)) gs
171− go gs@((gk :=> gv) : gs') hs@((hk :=> hv) : hs') = case gk `gcompare` hk of
172− GLT -> (gk :=> f gk (This gv)) : go gs' hs
173− GEQ -> (gk :=> f gk (These gv hv)) : go gs' hs'
174− GGT -> (hk :=> f hk (That hv)) : go gs hs'
175−
176−-- | Extract the values of a 'DMap' of 'EitherTag's.
177−dmapToThese :: DMap (EitherTag a b) Identity -> Maybe (These a b)
178−dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of
179− (Nothing, Nothing) -> Nothing
180− (Just (Identity a), Nothing) -> Just $ This a
181− (Nothing, Just (Identity b)) -> Just $ That b
182− (Just (Identity a), Just (Identity b)) -> Just $ These a b
183−
184−-- | Tag type for 'Either' to use it as a 'DSum'.
185−data EitherTag l r a where
186− LeftTag :: EitherTag l r l
187− RightTag :: EitherTag l r r
188− deriving (Typeable)
189−
190−deriving instance Show (EitherTag l r a)
191−deriving instance Eq (EitherTag l r a)
192−deriving instance Ord (EitherTag l r a)
193−
194−instance GEq (EitherTag l r) where
195− geq a b = case (a, b) of
196− (LeftTag, LeftTag) -> Just Refl
197− (RightTag, RightTag) -> Just Refl
198− _ -> Nothing
199−
200−instance GCompare (EitherTag l r) where
201− gcompare a b = case (a, b) of
202− (LeftTag, LeftTag) -> GEQ
203− (LeftTag, RightTag) -> GLT
204− (RightTag, LeftTag) -> GGT
205− (RightTag, RightTag) -> GEQ
206−
207−instance GShow (EitherTag l r) where
208− gshowsPrec _ a = case a of
209− LeftTag -> showString "LeftTag"
210− RightTag -> showString "RightTag"
211−
212−-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.
213−eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity
214−eitherToDSum = \case
215− Left a -> (LeftTag :=> Identity a)
216− Right b -> (RightTag :=> Identity b)
217−
218−-- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'.
219−dsumToEither :: DSum (EitherTag a b) Identity -> Either a b
220−dsumToEither = \case
221− (LeftTag :=> Identity a) -> Left a
222− (RightTag :=> Identity b) -> Right b
223−
224−--------------------------------------------------------------------------------
225−-- ComposeMaybe
226−--------------------------------------------------------------------------------
227−
228−-- | We can't use @Compose Maybe@ instead of 'ComposeMaybe', because that would
229−-- make the 'f' parameter have a nominal type role. We need f to be
230−-- representational so that we can use safe 'coerce'.
231−newtype ComposeMaybe f a =
232− ComposeMaybe { getComposeMaybe :: Maybe (f a) } deriving (Show, Eq, Ord)
233−
234−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 'Reflex.Patch.Map' and 'Reflex.Patch.MapWithMove'.
46+-- See also 'Data.Patch.Map' and 'Data.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+8−3
@@ -15,6 +15,7 @@ module Data.WeakBag
1515 , singleton
1616 , insert
1717 , traverse
18+ , traverse_
1819 , remove
1920 -- * Internal functions
2021 -- These will not always be available.
@@ -99,18 +100,22 @@ singleton a wbRef finalizer = {-# SCC "singleton" #-} do
99100 ticket <- insert a bag wbRef finalizer
100101 return (bag, ticket)
101102
102−{-# INLINE traverse #-}
103+{-# INLINE traverse_ #-}
103104-- | Visit every node in the given list. If new nodes are appended during the
104105-- traversal, they will not be visited. Every live node that was in the list
105106-- when the traversal began will be visited exactly once; however, no guarantee
106107-- is made about the order of the traversal.
107−traverse :: MonadIO m => WeakBag a -> (a -> m ()) -> m ()
108−traverse (WeakBag _ children) f = {-# SCC "traverse" #-} do
108+traverse_ :: MonadIO m => WeakBag a -> (a -> m ()) -> m ()
109+traverse_ (WeakBag _ children) f = {-# SCC "traverse" #-} do
109110 cs <- liftIO $ readIORef children
110111 forM_ cs $ \c -> do
111112 ma <- liftIO $ deRefWeak c
112113 mapM_ f ma
113114
115+{-# DEPRECATED traverse "Use 'traverse_' instead" #-}
116+traverse :: MonadIO m => WeakBag a -> (a -> m ()) -> m ()
117+traverse = traverse_
118+
114119-- | Remove an item from the 'WeakBag'; does nothing if invoked multiple times
115120-- on the same 'WeakBagTicket'.
116121{-# INLINE remove #-}
src/Reflex/Adjustable/Class.hs+3−2
@@ -30,7 +30,8 @@ module Reflex.Adjustable.Class
3030
3131import Control.Monad.Identity
3232import Control.Monad.Reader
33−import Data.Dependent.Map (DMap, GCompare (..))
33+import Data.Dependent.Map (DMap)
34+import Data.GADT.Compare (GCompare(..))
3435import qualified Data.Dependent.Map as DMap
3536import Data.Functor.Constant
3637import Data.Functor.Misc
@@ -39,7 +40,7 @@ import qualified Data.IntMap.Strict as IntMap
3940import Data.Map (Map)
4041
4142import Reflex.Class
42−import Reflex.Patch.DMapWithMove
43+import Data.Patch.DMapWithMove
4344
4445-- | A 'Monad' that supports adjustment over time. After an action has been
4546-- run, if the given events fire, it will adjust itself so that its net effect
src/Reflex/BehaviorWriter/Base.hs+16−7
@@ -1,6 +1,6 @@
11{-|
22Module: Reflex.BehaviorWriter.Base
3−Description: Implementation of MonadBehaviorWriter
3+Description: Implementation of BehaviorWriter
44-}
55{-# LANGUAGE CPP #-}
66{-# LANGUAGE FlexibleInstances #-}
@@ -24,6 +24,7 @@ module Reflex.BehaviorWriter.Base
2424import Control.Monad.Exception
2525import Control.Monad.Identity
2626import Control.Monad.IO.Class
27+import Control.Monad.Morph
2728import Control.Monad.Reader
2829import Control.Monad.Ref
2930import Control.Monad.State.Strict
@@ -46,9 +47,20 @@ import Reflex.Query.Class
4647import Reflex.Requester.Class
4748import Reflex.TriggerEvent.Class
4849
49−-- | A basic implementation of 'MonadBehaviorWriter'.
50+-- | A basic implementation of 'BehaviorWriter'.
5051newtype BehaviorWriterT t w m a = BehaviorWriterT { unBehaviorWriterT :: StateT [Behavior t w] m a }
51− deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadAsyncException, MonadException) -- The list is kept in reverse order
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+ )
5264
5365-- | Run a 'BehaviorWriterT' action. The behavior writer output will be provided
5466-- along with the result of the action.
@@ -73,9 +85,6 @@ withBehaviorWriterT f dw = do
7385deriving instance MonadHold t m => MonadHold t (BehaviorWriterT t w m)
7486deriving instance MonadSample t m => MonadSample t (BehaviorWriterT t w m)
7587
76−instance MonadTrans (BehaviorWriterT t w) where
77− lift = BehaviorWriterT . lift
78−
7988instance MonadRef m => MonadRef (BehaviorWriterT t w m) where
8089 type Ref (BehaviorWriterT t w m) = Ref m
8190 newRef = lift . newRef
@@ -89,7 +98,7 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (BehaviorWri
8998 newEventWithTrigger = lift . newEventWithTrigger
9099 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
91100
92−instance (Monad m, Monoid w, Reflex t) => MonadBehaviorWriter t w (BehaviorWriterT t w m) where
101+instance (Monad m, Monoid w, Reflex t) => BehaviorWriter t w (BehaviorWriterT t w m) where
93102 tellBehavior w = BehaviorWriterT $ modify (w :)
94103
95104instance MonadReader r m => MonadReader r (BehaviorWriterT t w m) where
src/Reflex/BehaviorWriter/Class.hs+11−5
@@ -1,8 +1,9 @@
11{-|
22Module: Reflex.BehaviorWriter.Class
3−Description: This module defines the 'MonadBehaviorWriter' class
3+Description: This module defines the 'BehaviorWriter' class
44-}
55{-# LANGUAGE CPP #-}
6+{-# LANGUAGE ConstraintKinds #-}
67{-# LANGUAGE FlexibleInstances #-}
78{-# LANGUAGE FunctionalDependencies #-}
89{-# LANGUAGE UndecidableInstances #-}
@@ -10,16 +11,21 @@ Description: This module defines the 'MonadBehaviorWriter' class
1011{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
1112#endif
1213module Reflex.BehaviorWriter.Class
13− ( MonadBehaviorWriter (..)
14+ ( MonadBehaviorWriter
15+ , BehaviorWriter(..)
1416 ) where
1517
1618import Control.Monad.Reader (ReaderT, lift)
1719import Reflex.Class (Behavior)
1820
19−-- | 'MonadBehaviorWriter' efficiently collects 'Behavior' values using 'tellBehavior'
21+{-# DEPRECATED MonadBehaviorWriter "Use 'BehaviorWriter' instead" #-}
22+-- | Type synonym for 'BehaviorWriter'
23+type MonadBehaviorWriter = BehaviorWriter
24+
25+-- | 'BehaviorWriter' efficiently collects 'Behavior' values using 'tellBehavior'
2026-- and combines them monoidally to provide a 'Behavior' result.
21−class (Monad m, Monoid w) => MonadBehaviorWriter t w m | m -> t w where
27+class (Monad m, Monoid w) => BehaviorWriter t w m | m -> t w where
2228 tellBehavior :: Behavior t w -> m ()
2329
24−instance MonadBehaviorWriter t w m => MonadBehaviorWriter t w (ReaderT r m) where
30+instance BehaviorWriter t w m => BehaviorWriter t w (ReaderT r m) where
2531 tellBehavior = lift . tellBehavior
src/Reflex/Class.hs+118−17
@@ -16,6 +16,7 @@
1616{-# LANGUAGE TypeFamilies #-}
1717{-# LANGUAGE TypeOperators #-}
1818{-# LANGUAGE UndecidableInstances #-}
19+{-# LANGUAGE Trustworthy #-}
1920#ifdef USE_REFLEX_OPTIMIZER
2021{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
2122#endif
@@ -28,23 +29,28 @@
2829-- convenience functions for working with 'Event's, 'Behavior's, and other
2930-- signals.
3031module Reflex.Class
31− ( module Reflex.Patch
32+ ( module Data.Patch
3233 -- * Primitives
3334 , Reflex (..)
3435 , mergeInt
3536 , coerceBehavior
3637 , coerceEvent
3738 , coerceDynamic
39+ , coerceIncremental
3840 , MonadSample (..)
3941 , MonadHold (..)
4042 -- ** 'fan' related types
4143 , EventSelector (..)
44+ , EventSelectorG (..)
4245 , EventSelectorInt (..)
4346 -- * Convenience functions
4447 , constDyn
4548 , pushAlways
4649 -- ** Combining 'Event's
4750 , leftmost
51+ , merge
52+ , mergeIncremental
53+ , mergeIncrementalWithMove
4854 , mergeMap
4955 , mergeIntMap
5056 , mergeMapIncremental
@@ -59,6 +65,7 @@ module Reflex.Class
5965 , alignEventWithMaybe
6066 -- ** Breaking up 'Event's
6167 , splitE
68+ , fan
6269 , fanEither
6370 , fanThese
6471 , fanMap
@@ -83,6 +90,7 @@ module Reflex.Class
8390 , gate
8491 -- ** Combining 'Dynamic's
8592 , distributeDMapOverDynPure
93+ , distributeDMapOverDynPureG
8694 , distributeListOverDyn
8795 , distributeListOverDynWith
8896 , zipDyn
@@ -172,7 +180,7 @@ import Prelude hiding (zip, zipWith)
172180import Data.These.Combinators (justThese)
173181#endif
174182#if MIN_VERSION_semialign(1,1,0)
175−import Data.Zip (Zip (..))
183+import Data.Zip (Zip (..), Unzip (..))
176184#endif
177185#endif
178186
@@ -188,11 +196,12 @@ import Data.Align
188196import Data.Bifunctor
189197import Data.Coerce
190198import Data.Default
191−import Data.Dependent.Map (DMap, DSum (..))
199+import Data.Dependent.Map (DMap)
200+import Data.Dependent.Sum (DSum (..))
192201import qualified Data.Dependent.Map as DMap
193202import Data.Functor.Compose
194203import Data.Functor.Product
195−import Data.GADT.Compare (GEq (..), GCompare (..), (:~:) (..))
204+import Data.GADT.Compare (GEq (..), GCompare (..))
196205import Data.FastMutableIntMap (PatchIntMap)
197206import Data.Foldable
198207import Data.Functor.Bind
@@ -202,17 +211,18 @@ import Data.IntMap.Strict (IntMap)
202211import qualified Data.IntMap.Strict as IntMap
203212import Data.List.NonEmpty (NonEmpty (..))
204213import Data.Map (Map)
205−import Data.Semigroup (Semigroup, sconcat, stimes, (<>))
214+import Data.Semigroup (Semigroup (..))
206215import Data.Some (Some(Some))
207216import Data.String
208217import Data.These
209218import Data.Type.Coercion
219+import Data.Type.Equality ((:~:) (..))
210220import Data.Witherable (Filterable(..))
211221import qualified Data.Witherable as W
212222import Reflex.FunctorMaybe (FunctorMaybe)
213223import qualified Reflex.FunctorMaybe
214−import Reflex.Patch
215−import qualified Reflex.Patch.MapWithMove as PatchMapWithMove
224+import Data.Patch
225+import qualified Data.Patch.MapWithMove as PatchMapWithMove
216226
217227import Debug.Trace (trace)
218228
@@ -265,15 +275,21 @@ class ( MonadHold t (PushM t)
265275 -- | Merge a collection of events; the resulting 'Event' will only occur if at
266276 -- least one input event is occurring, and will contain all of the input keys
267277 -- that are occurring simultaneously
268− 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
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+
269283 -- | Efficiently fan-out an event to many destinations. You should save the
270− -- result in a @let@-binding, and then repeatedly 'select' on the result to
284+ -- result in a @let@-binding, and then repeatedly 'selectG' on the result to
271285 -- create child events
272− fan :: GCompare k => Event t (DMap k Identity) -> EventSelector t k
286+ fanG :: GCompare k => Event t (DMap k v) -> EventSelectorG t k v
287+
273288 -- | Create an 'Event' that will occur whenever the currently-selected input
274289 -- 'Event' occurs
275290 switch :: Behavior t (Event t a) -> Event t a
276− -- | Create an 'Event' that will occur whenever the input event is occurring -- and its occurrence value, another 'Event', is also occurring
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.
277293 coincidence :: Event t (Event t a) -> Event t a
278294 -- | Extract the 'Behavior' of a 'Dynamic'.
279295 current :: Dynamic t a -> Behavior t a
@@ -287,9 +303,14 @@ class ( MonadHold t (PushM t)
287303 -- that value.
288304 unsafeBuildIncremental :: Patch p => PullM t (PatchTarget p) -> Event t p -> Incremental t p
289305 -- | Create a merge whose parents can change over time
290− mergeIncremental :: GCompare k => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)
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)
291310 -- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental
292− mergeIncrementalWithMove :: GCompare k => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)
311+ mergeIncrementalWithMoveG :: GCompare k
312+ => (forall a. q a -> Event t (v a))
313+ -> Incremental t (PatchDMapWithMove k q) -> Event t (DMap k v)
293314 -- | Extract the 'Behavior' component of an 'Incremental'
294315 currentIncremental :: Patch p => Incremental t p -> Behavior t (PatchTarget p)
295316 -- | Extract the 'Event' component of an 'Incremental'
@@ -305,9 +326,25 @@ class ( MonadHold t (PushM t)
305326 -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its
306327 -- occurrence type
307328 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)
308333 mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)
309334 fanInt :: Event t (IntMap a) -> EventSelectorInt t a
310335
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+
311348--TODO: Specialize this so that we can take advantage of knowing that there's no changing going on
312349-- | Constructs a single 'Event' out of a map of events. The output event may fire with multiple
313350-- keys simultaneously.
@@ -326,6 +363,12 @@ coerceEvent = coerceWith $ eventCoercion Coercion
326363coerceDynamic :: (Reflex t, Coercible a b) => Dynamic t a -> Dynamic t b
327364coerceDynamic = coerceWith $ dynamicCoercion Coercion
328365
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+
329372-- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'. The 'Behavior'
330373-- __must__ change when and only when the 'Event' fires, such that the
331374-- 'Behavior''s value is always equal to the most recent firing of the 'Event';
@@ -378,6 +421,13 @@ class MonadSample t m => MonadHold t m where
378421 -- | Create a new 'Event' that only occurs only once, on the first occurrence of
379422 -- the supplied 'Event'.
380423 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
381431
382432-- | Accumulate an 'Incremental' with the supplied initial value and the firings of the provided 'Event',
383433-- using the combining function to produce a patch.
@@ -495,6 +545,17 @@ newtype EventSelector t k = EventSelector
495545 select :: forall a. k a -> Event t a
496546 }
497547
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+
498559-- | Efficiently select an 'Event' keyed on 'Int'. This is more efficient than manually
499560-- filtering by key.
500561newtype EventSelectorInt t a = EventSelectorInt { selectInt :: Int -> Event t a }
@@ -512,6 +573,7 @@ instance MonadHold t m => MonadHold t (ReaderT r m) where
512573 holdIncremental a0 = lift . holdIncremental a0
513574 buildDynamic a0 = lift . buildDynamic a0
514575 headE = lift . headE
576+ now = lift now
515577
516578instance (MonadSample t m, Monoid r) => MonadSample t (WriterT r m) where
517579 sample = lift . sample
@@ -522,6 +584,7 @@ instance (MonadHold t m, Monoid r) => MonadHold t (WriterT r m) where
522584 holdIncremental a0 = lift . holdIncremental a0
523585 buildDynamic a0 = lift . buildDynamic a0
524586 headE = lift . headE
587+ now = lift now
525588
526589instance MonadSample t m => MonadSample t (StateT s m) where
527590 sample = lift . sample
@@ -532,6 +595,7 @@ instance MonadHold t m => MonadHold t (StateT s m) where
532595 holdIncremental a0 = lift . holdIncremental a0
533596 buildDynamic a0 = lift . buildDynamic a0
534597 headE = lift . headE
598+ now = lift now
535599
536600instance MonadSample t m => MonadSample t (ExceptT e m) where
537601 sample = lift . sample
@@ -542,6 +606,7 @@ instance MonadHold t m => MonadHold t (ExceptT e m) where
542606 holdIncremental a0 = lift . holdIncremental a0
543607 buildDynamic a0 = lift . buildDynamic a0
544608 headE = lift . headE
609+ now = lift now
545610
546611instance (MonadSample t m, Monoid w) => MonadSample t (RWST r w s m) where
547612 sample = lift . sample
@@ -552,6 +617,7 @@ instance (MonadHold t m, Monoid w) => MonadHold t (RWST r w s m) where
552617 holdIncremental a0 = lift . holdIncremental a0
553618 buildDynamic a0 = lift . buildDynamic a0
554619 headE = lift . headE
620+ now = lift now
555621
556622instance MonadSample t m => MonadSample t (ContT r m) where
557623 sample = lift . sample
@@ -562,6 +628,7 @@ instance MonadHold t m => MonadHold t (ContT r m) where
562628 holdIncremental a0 = lift . holdIncremental a0
563629 buildDynamic a0 = lift . buildDynamic a0
564630 headE = lift . headE
631+ now = lift now
565632
566633--------------------------------------------------------------------------------
567634-- Convenience functions
@@ -611,7 +678,9 @@ instance Reflex t => Monad (Behavior t) where
611678 a >>= f = pull $ sample a >>= sample . f
612679 -- 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.
613680 return = constant
681+#if !MIN_VERSION_base(4,13,0)
614682 fail = error "Monad (Behavior t) does not support fail"
683+#endif
615684
616685instance (Reflex t, Monoid a) => Monoid (Behavior t a) where
617686 mempty = constant mempty
@@ -1036,6 +1105,12 @@ instance Reflex t => Zip (Event t) where
10361105 zip x y = mapMaybe justThese $ align x y
10371106#endif
10381107
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
10391114
10401115-- | Create a new 'Event' that only occurs if the supplied 'Event' occurs and
10411116-- the 'Behavior' is true at the time of occurrence.
@@ -1087,12 +1162,21 @@ instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where
10871162-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same
10881163-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators.
10891164distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity)
1090−distributeDMapOverDynPure dm = case DMap.toList dm of
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
10911175 [] -> constDyn DMap.empty
1092− [k :=> v] -> fmap (DMap.singleton k . Identity) v
1176+ [k :=> v] -> DMap.singleton k <$> nt v
10931177 _ ->
1094− let getInitial = DMap.traverseWithKey (\_ -> fmap Identity . sample . current) dm
1095− edmPre = merge $ DMap.map updated dm
1178+ let getInitial = DMap.traverseWithKey (\_ -> sample . current . nt) dm
1179+ edmPre = mergeG getCompose $ DMap.map (Compose . updated . nt) dm
10961180 result = unsafeBuildDynamic getInitial $ flip pushAlways edmPre $ \news -> do
10971181 olds <- sample $ current result
10981182 return $ DMap.unionWithKey (\_ _ new -> new) olds news
@@ -1565,6 +1649,23 @@ fmapCheap f = pushCheap $ return . Just . f
15651649tagCheap :: Reflex t => Behavior t b -> Event t a -> Event t b
15661650tagCheap b = pushAlwaysCheap $ \_ -> sample b
15671651
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+
15681669-- | A "cheap" version of 'mergeWithCheap'. See the performance note on 'pushCheap'.
15691670{-# INLINE mergeWithCheap #-}
15701671mergeWithCheap :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a
src/Reflex/Collection.hs+1−1
@@ -130,7 +130,7 @@ listWithKeyShallowDiff initialVals valsChanged mkChild = do
130130 Nothing -> Just Nothing
131131
132132 -- We don't want to let spurious re-creations of items through
133− Just _ -> Nothing
133+ Just _ -> Nothing
134134 listHoldWithKey
135135 initialVals
136136 (attachWith (flip (Map.differenceWith relevantPatch))
src/Reflex/Dynamic.hs+17−2
@@ -53,10 +53,12 @@ module Reflex.Dynamic
5353 , foldDynMaybe
5454 , foldDynMaybeM
5555 , joinDynThroughMap
56+ , joinDynThroughIntMap
5657 , traceDyn
5758 , traceDynWith
5859 , splitDynPure
5960 , distributeMapOverDynPure
61+ , distributeIntMapOverDynPure
6062 , distributeDMapOverDynPure
6163 , distributeListOverDynPure
6264 , Demux
@@ -87,11 +89,14 @@ import Data.Align
8789import Data.Dependent.Map (DMap)
8890import qualified Data.Dependent.Map as DMap
8991import Data.Dependent.Sum (DSum (..))
90−import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), GOrdering (..))
92+import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))
93+import Data.IntMap (IntMap)
94+import qualified Data.IntMap as IntMap
9195import Data.Map (Map)
9296import Data.Maybe
9397import Data.Monoid ((<>))
9498import Data.These
99+import Data.Type.Equality ((:~:) (..))
95100
96101import Debug.Trace
97102
@@ -201,6 +206,11 @@ splitDynPure d = (fmap fst d, fmap snd d)
201206distributeMapOverDynPure :: (Reflex t, Ord k) => Map k (Dynamic t v) -> Dynamic t (Map k v)
202207distributeMapOverDynPure = fmap dmapToMap . distributeDMapOverDynPure . mapWithFunctorToDMap
203208
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+
204214-- | Convert a list with 'Dynamic' elements into a 'Dynamic' of a list with
205215-- non-'Dynamic' elements, preserving the order of the elements.
206216{-# DEPRECATED distributeListOverDynPure "Use 'distributeListOverDyn' instead" #-}
@@ -213,6 +223,11 @@ distributeListOverDynPure = distributeListOverDyn
213223joinDynThroughMap :: forall t k a. (Reflex t, Ord k) => Dynamic t (Map k (Dynamic t a)) -> Dynamic t (Map k a)
214224joinDynThroughMap = (distributeMapOverDynPure =<<)
215225
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 =<<)
230+
216231-- | Print the value of the 'Dynamic' when it is first read and on each
217232-- subsequent change that is observed (as 'traceEvent'), prefixed with the
218233-- provided string. This should /only/ be used for debugging.
@@ -333,7 +348,7 @@ factorDyn d = buildDynamic (sample (current d) >>= holdKey) update where
333348--
334349-- > demuxed (demux d) k === fmap (== k) d
335350--
336−-- However, when getDemuxed is used multiple times, the complexity is only
351+-- However, when 'demuxed' is used multiple times, the complexity is only
337352-- /O(log(n))/, rather than /O(n)/ for fmap.
338353data Demux t k = Demux { demuxValue :: Behavior t k
339354 , demuxSelector :: EventSelector t (Const2 k Bool)
src/Reflex/DynamicWriter/Base.hs+14−5
@@ -22,6 +22,7 @@ module Reflex.DynamicWriter.Base
2222import Control.Monad.Exception
2323import Control.Monad.Identity
2424import Control.Monad.IO.Class
25+import Control.Monad.Morph
2526import Control.Monad.Primitive
2627import Control.Monad.Reader
2728import Control.Monad.Ref
@@ -44,16 +45,13 @@ import Reflex.Class
4445import Reflex.DynamicWriter.Class
4546import Reflex.EventWriter.Class (EventWriter, tellEvent)
4647import Reflex.Host.Class
47−import qualified Reflex.Patch.MapWithMove as MapWithMove
48+import qualified Data.Patch.MapWithMove as MapWithMove
4849import Reflex.PerformEvent.Class
4950import Reflex.PostBuild.Class
5051import Reflex.Query.Class
5152import Reflex.Requester.Class
5253import Reflex.TriggerEvent.Class
5354
54−instance MonadTrans (DynamicWriterT t w) where
55− lift = DynamicWriterT . lift
56−
5755mapIncrementalMapValues :: (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')
5856mapIncrementalMapValues f = unsafeMapIncremental (fmap f) (fmap f)
5957
@@ -90,7 +88,18 @@ mergeDynIncrementalWithMove a = unsafeBuildIncremental (mapM (sample . current)
9088
9189-- | A basic implementation of 'DynamicWriter'.
9290newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT [Dynamic t w] m a }
93− deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadAsyncException, MonadException) -- The list is kept in reverse order
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+ )
94103
95104deriving instance MonadHold t m => MonadHold t (DynamicWriterT t w m)
96105deriving instance MonadSample t m => MonadSample t (DynamicWriterT t w m)
src/Reflex/DynamicWriter/Class.hs−1
@@ -26,4 +26,3 @@ 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+16−5
@@ -35,12 +35,14 @@ import Reflex.TriggerEvent.Class
3535
3636import Control.Monad.Exception
3737import Control.Monad.Identity
38+import Control.Monad.Morph
3839import Control.Monad.Primitive
3940import Control.Monad.Reader
4041import Control.Monad.Ref
4142import Control.Monad.State.Strict
42−import Data.Dependent.Map (DMap, DSum (..))
43+import Data.Dependent.Map (DMap)
4344import qualified Data.Dependent.Map as DMap
45+import Data.Dependent.Sum (DSum (..))
4446import Data.Functor.Compose
4547import Data.Functor.Misc
4648import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))
@@ -96,7 +98,17 @@ data EventWriterState t w = EventWriterState
9698
9799-- | A basic implementation of 'EventWriter'.
98100newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (EventWriterState t w) m a }
99− deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
101+ deriving
102+ ( Functor
103+ , Applicative
104+ , Monad
105+ , MonadTrans
106+ , MFunctor
107+ , MonadFix
108+ , MonadIO
109+ , MonadException
110+ , MonadAsyncException
111+ )
100112
101113-- | Run a 'EventWriterT' action.
102114runEventWriterT :: forall t m w a. (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)
@@ -116,9 +128,6 @@ instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m
116128 , _eventWriterState_told = (tellId myId :=> w) : _eventWriterState_told old
117129 }
118130
119−instance MonadTrans (EventWriterT t w) where
120− lift = EventWriterT . lift
121−
122131instance MonadSample t m => MonadSample t (EventWriterT t w m) where
123132 sample = lift . sample
124133
@@ -133,6 +142,8 @@ instance MonadHold t m => MonadHold t (EventWriterT t w m) where
133142 buildDynamic a0 = lift . buildDynamic a0
134143 {-# INLINABLE headE #-}
135144 headE = lift . headE
145+ {-# INLINABLE now #-}
146+ now = lift now
136147
137148instance (Reflex t, Adjustable t m, MonadHold t m, Semigroup w) => Adjustable t (EventWriterT t w m) where
138149 runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
src/Reflex/FastWeak.hs+10
@@ -151,6 +151,16 @@ 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 #-}
154164mkFastWeakTicket :: a -> IO (FastWeakTicket a)
155165-- 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
156166-- associated FastWeak to actually be weak
src/Reflex/Host/Headless.hsnew file+128
@@ -0,0 +1,128 @@
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 when the 'Dynamic' updates.
23+-- The returned Event of network results fires at post-build time and 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/Patch.hsdeleted−46
@@ -1,46 +0,0 @@
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.hsdeleted−34
@@ -1,34 +0,0 @@
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.hsdeleted−82
@@ -1,82 +0,0 @@
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.hsdeleted−363
@@ -1,363 +0,0 @@
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.Constraint.Extras
23−import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
24−import qualified Data.Dependent.Map as DMap
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(Some))
34−import Data.These
35−
36−-- | 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
37−-- destinations.
38−--
39−-- Invariants:
40−--
41−-- * A key should not move to itself.
42−-- * A move should always be represented with both the destination key (as a 'From_Move') and the source key (as a @'ComposeMaybe' ('Just' destination)@)
43−newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
44−
45−-- |Structure which represents what changes apply to a particular key. @_nodeInfo_from@ specifies what happens to this key, and in particular what other key
46−-- the current key is moving from, while @_nodeInfo_to@ specifies what key the current key is moving to if involved in a move.
47−data NodeInfo k v a = NodeInfo
48− { _nodeInfo_from :: !(From k v a)
49− -- ^Change applying to the current key, be it an insert, move, or delete.
50− , _nodeInfo_to :: !(To k a)
51− -- ^Where this key is moving to, if involved in a move. Should only be @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.
52− }
53− deriving (Show)
54−
55−-- |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
56−-- key (@From_Delete@), or moving a key (@From_Move@).
57−data From (k :: a -> *) (v :: a -> *) :: a -> * where
58− -- |Insert a new or update an existing key with the given value @v a@
59− From_Insert :: v a -> From k v a
60− -- |Delete the existing key
61− From_Delete :: From k v a
62− -- |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@,
63− -- usually but not necessarily with @From_Delete@.
64− From_Move :: !(k a) -> From k v a
65− deriving (Show, Read, Eq, Ord)
66−
67−-- |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
68−-- operation.
69−type To = ComposeMaybe
70−
71−-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
72−validPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Bool
73−validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove
74−
75−-- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid.
76−validationErrorsForPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> [String]
77−validationErrorsForPatchDMapWithMove m =
78− noSelfMoves <> movesBalanced
79− where
80− noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m
81− selfMove (dst :=> NodeInfo (From_Move src) _) | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"
82− selfMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
83− selfMove _ = Nothing
84− movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m
85− unbalancedMove (dst :=> NodeInfo (From_Move src) _) =
86− case DMap.lookup src m of
87− Nothing -> Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key is not in the patch"
88− Just (NodeInfo _ (ComposeMaybe (Just dst'))) ->
89− if isNothing (dst' `geq` dst)
90− then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead"
91− else Nothing
92− _ ->
93− Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key has no move to key"
94− unbalancedMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) =
95− case DMap.lookup dst m of
96− Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch"
97− Just (NodeInfo (From_Move src') _) ->
98− if isNothing (src' `geq` src)
99− then Just $ "unbalanced move at source key " <> gshow src <> " to " <> gshow dst <> " is coming from " <> gshow src' <> " instead"
100− else Nothing
101−
102− _ ->
103− Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
104− unbalancedMove _ = Nothing
105−
106−-- |Test whether two @'PatchDMapWithMove' k v@ contain the same patch operations.
107−instance (GEq k, Has' Eq k (NodeInfo k v)) => Eq (PatchDMapWithMove k v) where
108− PatchDMapWithMove a == PatchDMapWithMove b = a == b
109−
110−-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
111−data Pair1 f g a = Pair1 (f a) (g a)
112−
113−-- |Helper data structure used for composing patches using the monoid instance.
114−data Fixup k v a
115− = Fixup_Delete
116− | Fixup_Update (These (From k v a) (To k a))
117−
118−-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
119−instance GCompare k => Semigroup (PatchDMapWithMove k v) where
120− PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m
121− where
122− connections = DMap.toList $ DMap.intersectionWithKey (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b)) ma mb
123− h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)]
124− h (_ :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case (mToAfter, editBefore) of
125− (Just toAfter, From_Move fromBefore)
126− | isJust $ fromBefore `geq` toAfter
127− -> [toAfter :=> Fixup_Delete]
128− | otherwise
129− -> [ toAfter :=> Fixup_Update (This editBefore)
130− , fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))
131− ]
132− (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
133− (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)]
134− (Nothing, _) -> []
135− mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
136− mergeFixups _ (Fixup_Update a) (Fixup_Update b)
137− | This x <- a, That y <- b
138− = Fixup_Update $ These x y
139− | That y <- a, This x <- b
140− = Fixup_Update $ These x y
141− mergeFixups _ _ _ = error "PatchDMapWithMove: incompatible fixups"
142− fixups = DMap.fromListWithKey mergeFixups $ concatMap h connections
143− combineNodeInfos _ nia nib = NodeInfo
144− { _nodeInfo_from = _nodeInfo_from nia
145− , _nodeInfo_to = _nodeInfo_to nib
146− }
147− applyFixup _ ni = \case
148− Fixup_Delete -> Nothing
149− Fixup_Update u -> Just $ NodeInfo
150− { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u
151− , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
152− }
153− m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups
154− getHere :: These a b -> Maybe a
155− getHere = \case
156− This a -> Just a
157− These a _ -> Just a
158− That _ -> Nothing
159− getThere :: These a b -> Maybe b
160− getThere = \case
161− This _ -> Nothing
162− These _ b -> Just b
163− That b -> Just b
164−
165−-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
166−instance GCompare k => Monoid (PatchDMapWithMove k v) where
167− mempty = PatchDMapWithMove mempty
168− mappend = (<>)
169−
170−{-
171−mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
172−PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
173− where
174− 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
175− removeRedundantDst toKey (From_Move fromKey) | isJust (toKey `geq` fromKey) = Nothing
176− removeRedundantDst _ a = Just a
177− f :: forall a. k a -> From k v a -> Maybe (From k v a)
178− f toKey _ = removeRedundantDst toKey $ case getDstAction toKey dstAfter of
179− From_Move fromKey -> getDstAction fromKey dstBefore
180− nonMove -> nonMove
181− dst = DMap.mapMaybeWithKey f $ DMap.union dstAfter dstBefore
182− getSrcAction k m = fromMaybe (ComposeMaybe $ Just k) $ DMap.lookup k m
183− removeRedundantSrc fromKey (ComposeMaybe (Just toKey)) | isJust (fromKey `geq` toKey) = Nothing
184− removeRedundantSrc _ a = Just a
185− g :: forall a. k a -> ComposeMaybe k a -> Maybe (ComposeMaybe k a)
186− g fromKey _ = removeRedundantSrc fromKey $ case getSrcAction fromKey srcBefore of
187− ComposeMaybe Nothing -> ComposeMaybe Nothing
188− ComposeMaybe (Just toKeyBefore) -> getSrcAction toKeyBefore srcAfter
189− src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
190−-}
191−
192−-- |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'.
193−insertDMapKey :: k a -> v a -> PatchDMapWithMove k v
194−insertDMapKey k v =
195− PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing)
196−
197−-- |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:
198−--
199−-- @
200−-- 'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap))
201−-- @
202−moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
203−moveDMapKey src dst = case src `geq` dst of
204− Nothing -> PatchDMapWithMove $ DMap.fromList
205− [ dst :=> NodeInfo (From_Move src) (ComposeMaybe Nothing)
206− , src :=> NodeInfo From_Delete (ComposeMaybe $ Just dst)
207− ]
208− Just _ -> mempty
209−
210−-- |Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
211−--
212−-- @
213−-- let aMay = DMap.lookup a dmap
214−-- bMay = DMap.lookup b dmap
215−-- in maybe id (DMap.insert a) (bMay `mplus` aMay)
216−-- . maybe id (DMap.insert b) (aMay `mplus` bMay)
217−-- . DMap.delete a . DMap.delete b $ dmap
218−-- @
219−swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
220−swapDMapKey src dst = case src `geq` dst of
221− Nothing -> PatchDMapWithMove $ DMap.fromList
222− [ dst :=> NodeInfo (From_Move src) (ComposeMaybe $ Just src)
223− , src :=> NodeInfo (From_Move dst) (ComposeMaybe $ Just dst)
224− ]
225− Just _ -> mempty
226−
227−-- |Make a @'PatchDMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'DMap.delete'.
228−deleteDMapKey :: k a -> PatchDMapWithMove k v
229−deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete $ ComposeMaybe Nothing
230−
231−{-
232−k1, k2 :: Const2 Int () ()
233−k1 = Const2 1
234−k2 = Const2 2
235−p1, p2 :: PatchDMapWithMove (Const2 Int ()) Identity
236−p1 = moveDMapKey k1 k2
237−p2 = moveDMapKey k2 k1
238−p12 = p1 <> p2
239−p21 = p2 <> p1
240−p12Slow = p1 `mappendPatchDMapWithMoveSlow` p2
241−p21Slow = p2 `mappendPatchDMapWithMoveSlow` p1
242−
243−testPatchDMapWithMove = do
244− print p1
245− print p2
246− print $ p12 == deleteDMapKey k1
247− print $ p21 == deleteDMapKey k2
248− print $ p12Slow == deleteDMapKey k1
249− print $ p21Slow == deleteDMapKey k2
250−
251−dst (PatchDMapWithMove x _) = x
252−src (PatchDMapWithMove _ x) = x
253−-}
254−
255−-- |Extract the 'DMap' representing the patch changes from the 'PatchDMapWithMove'.
256−unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)
257−unPatchDMapWithMove (PatchDMapWithMove p) = p
258−
259−-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove', without checking any invariants.
260−--
261−-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchDMapWithMove' are preserved; they will not be checked.
262−unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v
263−unsafePatchDMapWithMove = PatchDMapWithMove
264−
265−-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while checking invariants. If the invariants are satisfied, @Right p@ is returned
266−-- otherwise @Left errors@.
267−patchDMapWithMove :: (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)
268−patchDMapWithMove dm =
269− case validationErrorsForPatchDMapWithMove dm of
270− [] -> Right $ unsafePatchDMapWithMove dm
271− errs -> Left errs
272−
273−-- |Map a natural transform @v -> v'@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.
274−mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'
275−mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $
276− DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p
277− where g :: forall a. From k v a -> From k v' a
278− g = \case
279− From_Insert v -> From_Insert $ f v
280− From_Delete -> From_Delete
281− From_Move k -> From_Move k
282−
283−-- |Traverse an effectful function @forall a. v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.
284−traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
285−traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
286−
287−-- |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')@.
288−traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
289−traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p
290− where g :: forall a. k a -> From k v a -> m (From k v' a)
291− g k = \case
292− From_Insert v -> From_Insert <$> f k v
293− From_Delete -> pure From_Delete
294− From_Move fromKey -> pure $ From_Move fromKey
295−
296−-- |Map a function which transforms @'From' k v a@ into a @'From' k v' a@ over a @'NodeInfo' k v a@.
297−nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a
298−nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
299−
300−-- |Map an effectful function which transforms @'From' k v a@ into a @f ('From' k v' a)@ over a @'NodeInfo' k v a@.
301−nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a)
302−nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
303−
304−-- |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
305−-- values.
306−weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'
307−weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
308− where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) v'
309− g ni = MapWithMove.NodeInfo
310− { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
311− From_Insert v -> MapWithMove.From_Insert $ f v
312− From_Delete -> MapWithMove.From_Delete
313− From_Move k -> MapWithMove.From_Move $ Some k
314− , MapWithMove._nodeInfo_to = Some <$> getComposeMaybe (_nodeInfo_to ni)
315− }
316−
317−-- |"Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k v'@. Weaken is in scare quotes because the 'Const2' has already disabled any
318−-- dependency in the typing and all points are already @a@, hence the function to map each value to @v'@ is not higher rank.
319−patchDMapWithMoveToPatchMapWithMoveWith :: forall k v v' a. (v a -> v') -> PatchDMapWithMove (Const2 k a) v -> PatchMapWithMove k v'
320−patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
321− where g :: NodeInfo (Const2 k a) v a -> MapWithMove.NodeInfo k v'
322− g ni = MapWithMove.NodeInfo
323− { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
324− From_Insert v -> MapWithMove.From_Insert $ f v
325− From_Delete -> MapWithMove.From_Delete
326− From_Move (Const2 k) -> MapWithMove.From_Move k
327− , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)
328− }
329−
330−-- |"Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove ('Const2' k a)@; that is, turn a non-dependently-typed patch into a dependently typed
331−-- one but which always has a constant key type represented by 'Const2'. Apply the given function to each @v@ to produce a @v' a@.
332−-- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
333−const2PatchDMapWithMoveWith :: forall k v v' a. (v -> v' a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) v'
334−const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
335− where g :: (k, MapWithMove.NodeInfo k v) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v')
336− g (k, ni) = Const2 k :=> NodeInfo
337− { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of
338− MapWithMove.From_Insert v -> From_Insert $ f v
339− MapWithMove.From_Delete -> From_Delete
340− MapWithMove.From_Move fromKey -> From_Move $ Const2 fromKey
341− , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni
342− }
343−
344−-- | Apply the insertions, deletions, and moves to a given 'DMap'.
345−instance GCompare k => Patch (PatchDMapWithMove k v) where
346− type PatchTarget (PatchDMapWithMove k v) = DMap k v
347− 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?
348− where insertions = DMap.mapMaybeWithKey insertFunc p
349− insertFunc :: forall a. k a -> NodeInfo k v a -> Maybe (v a)
350− insertFunc _ ni = case _nodeInfo_from ni of
351− From_Insert v -> Just v
352− From_Move k -> DMap.lookup k old
353− From_Delete -> Nothing
354− deletions = DMap.mapMaybeWithKey deleteFunc p
355− deleteFunc :: forall a. k a -> NodeInfo k v a -> Maybe (Constant () a)
356− deleteFunc _ ni = case _nodeInfo_from ni of
357− From_Delete -> Just $ Constant ()
358− _ -> Nothing
359−
360−-- | Get the values that will be replaced, deleted, or moved if the given patch is applied to the given 'DMap'.
361−getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))
362−getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
363− where f _ v ni = Pair v $ _nodeInfo_to ni
src/Reflex/Patch/DMapWithReset.hsdeleted−120
@@ -1,120 +0,0 @@
1−{-# LANGUAGE FlexibleContexts #-}
2−{-# LANGUAGE FlexibleInstances #-}
3−{-# LANGUAGE LambdaCase #-}
4−{-# LANGUAGE MultiParamTypeClasses #-}
5−{-# LANGUAGE PolyKinds #-}
6−{-# LANGUAGE Rank2Types #-}
7−{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE StandaloneDeriving #-}
9−{-# LANGUAGE TypeApplications #-}
10−{-# LANGUAGE TypeFamilies #-}
11−{-# LANGUAGE UndecidableInstances #-}
12−
13−{-# OPTIONS_GHC -Wall #-}
14−
15−-- | 'Patch'es on 'DMap' that consist only of insertions (or overwrites) and deletions.
16−module Reflex.Patch.DMapWithReset where
17−
18−import Reflex.Patch.Class
19−
20−import Data.Dependent.Map (DMap, GCompare (..))
21−import qualified Data.Dependent.Map as DMap
22−import Data.Semigroup (Semigroup (..))
23−import Data.Constraint.Extras
24−
25−-- | A set of changes to a 'DMap'. Any element may be inserted/updated or deleted.
26−-- Insertions are represented as @'ComposeMaybe' (Just value)@,
27−-- while deletions are represented as @'ComposeMaybe' Nothing@.
28−newtype PatchDMapWithReset k p = PatchDMapWithReset { unPatchDMapWithReset :: DMap k (By p) }
29−
30−-- | Holds the information about each key: where its new value should come from,
31−-- and where its old value should go to
32−data By p a
33− = By_Insert (PatchTarget (p a)) -- ^ Insert the given value here
34− | By_Delete -- ^ Delete the existing value, if any, from here
35− | By_Patch (p a) -- ^ Patch the value here with the given patch
36−
37−instance (Semigroup (p a), Patch (p a)) => Semigroup (By p a) where
38− x@(By_Insert _) <> _ = x
39− By_Delete <> _ = By_Delete
40− By_Patch x <> By_Insert y = By_Insert (applyAlways x y)
41− By_Patch x <> By_Patch y = By_Patch (x <> y)
42− By_Patch _ <> By_Delete = By_Delete
43−
44−instance (Monoid (p a), Patch (p a)) => Monoid (By p a) where
45− mappend = (<>)
46− mempty = By_Patch mempty
47−
48−instance
49− ( GCompare k
50− , Has' Semigroup k p
51− , Has' Patch k p
52− )
53− => Semigroup (PatchDMapWithReset k p) where
54− PatchDMapWithReset xs <> PatchDMapWithReset ys = PatchDMapWithReset $ DMap.unionWithKey
55− (\k -> has' @Patch @p k
56− $ has' @Semigroup @p k
57− $ (<>)) xs ys
58−
59−instance
60− ( GCompare k
61− , Has' Semigroup k p
62− , Has' Patch k p
63− )
64− => Monoid (PatchDMapWithReset k p) where
65− mappend = (<>)
66− mempty = PatchDMapWithReset DMap.empty
67−
68−class (Patch (p a), PatchTarget (p a) ~ Patches1LocallyTarget p a) => Patches1Locally p a where
69− type Patches1LocallyTarget p :: k -> *
70−
71−data These1 f g x
72− = This1 (f x)
73− | That1 (g x)
74− | These1 (f x) (g x)
75−
76−mergeWithKey
77− :: forall k v1 v2 v.
78− (GCompare k)
79− => (forall x. k x -> v1 x -> Maybe (v x))
80− -> (forall x. k x -> v2 x -> Maybe (v x))
81− -> (forall x. k x -> v1 x -> v2 x -> Maybe (v x))
82− -> DMap k v1 -> DMap k v2 -> DMap k v
83−mergeWithKey f g fg = \xs ys -> DMap.mapMaybeWithKey onlyThat $ DMap.unionWithKey doIt (DMap.map This1 xs) (DMap.map That1 ys)
84− where
85− doIt _ (This1 xs) (That1 ys) = These1 xs ys
86− doIt _ _ _ = error "mergeWithKey misalligned keys"
87−
88− onlyThat :: forall x. k x -> These1 v1 v2 x -> Maybe (v x)
89− onlyThat k = \case
90− This1 xs -> f k xs
91− That1 ys -> g k ys
92− These1 xs ys -> fg k xs ys
93−{-# INLINE mergeWithKey #-}
94−
95−-- | Apply the insertions or deletions to a given 'DMap'.
96−instance (GCompare k, Has (Patches1Locally p) k) => Patch (PatchDMapWithReset k p) where
97−
98− type PatchTarget (PatchDMapWithReset k p) = DMap k (Patches1LocallyTarget p)
99−
100− apply = go
101− where
102− go :: PatchDMapWithReset k p -> DMap k (Patches1LocallyTarget p) -> Maybe (DMap k (Patches1LocallyTarget p))
103− go (PatchDMapWithReset diff) old = Just $! mergeWithKey (\_ -> Just) inserts updates old diff
104− where
105− updates :: forall x. k x -> Patches1LocallyTarget p x -> By p x -> Maybe (Patches1LocallyTarget p x)
106− updates k ys = has @(Patches1Locally p) k $ \case
107− By_Insert x -> Just x
108− By_Delete -> Nothing
109− By_Patch x -> Just $ applyAlways x ys
110−
111− inserts :: forall x. k x -> By p x -> Maybe (Patches1LocallyTarget p x)
112− inserts k = has @(Patches1Locally p) k $ \case
113− By_Insert x -> Just x
114− By_Delete -> Nothing
115− By_Patch _ -> Nothing
116−
117−deriving instance (Patch (p a), Eq (p a), Eq (PatchTarget (p a))) => Eq (By p a)
118−deriving instance (Patch (p a), Show (p a), Show (PatchTarget (p a))) => Show (By p a)
119−deriving instance (Eq (DMap k (By p))) => Eq (PatchDMapWithReset k p)
120−deriving instance (Show (DMap k (By p))) => Show (PatchDMapWithReset k p)
src/Reflex/Patch/IntMap.hsdeleted−59
@@ -1,59 +0,0 @@
1−{-# LANGUAGE DeriveFoldable #-}
2−{-# LANGUAGE DeriveFunctor #-}
3−{-# LANGUAGE DeriveTraversable #-}
4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5−{-# LANGUAGE TypeFamilies #-}
6−-- | Module containing 'PatchIntMap', a 'Patch' for 'IntMap' which allows for
7−-- insert/update or delete of associations.
8−module Reflex.Patch.IntMap where
9−
10−import Data.IntMap.Strict (IntMap)
11−import qualified Data.IntMap.Strict as IntMap
12−import Data.Maybe
13−import Data.Semigroup
14−import Reflex.Patch.Class
15−
16−-- | 'Patch' for 'IntMap' which represents insertion or deletion of keys in the mapping.
17−-- Internally represented by 'IntMap (Maybe a)', where @Just@ means insert/update
18−-- and @Nothing@ means delete.
19−newtype PatchIntMap a = PatchIntMap (IntMap (Maybe a)) deriving (Functor, Foldable, Traversable, Monoid)
20−
21−-- | Apply the insertions or deletions to a given 'IntMap'.
22−instance Patch (PatchIntMap a) where
23− type PatchTarget (PatchIntMap a) = IntMap a
24− apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $
25− let removes = IntMap.filter isNothing p
26− adds = IntMap.mapMaybe id p
27− in IntMap.union adds $ v `IntMap.difference` removes
28−
29−-- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@.
30−-- If the same key is modified by both patches, the one on the left will take
31−-- precedence.
32−instance Semigroup (PatchIntMap v) where
33− PatchIntMap a <> PatchIntMap b = PatchIntMap $ a `mappend` b --TODO: Add a semigroup instance for Map
34− -- PatchMap is idempotent, so stimes n is id for every n
35− stimes = stimesIdempotentMonoid
36−
37−-- | Map a function @Int -> a -> b@ over all @a@s in the given @'PatchIntMap' a@
38−-- (that is, all inserts/updates), producing a @PatchIntMap b@.
39−mapIntMapPatchWithKey :: (Int -> a -> b) -> PatchIntMap a -> PatchIntMap b
40−mapIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap $ IntMap.mapWithKey (\ k mv -> f k <$> mv) m
41−
42−-- | Map an effectful function @Int -> a -> f b@ over all @a@s in the given @'PatchIntMap' a@
43−-- (that is, all inserts/updates), producing a @f (PatchIntMap b)@.
44−traverseIntMapPatchWithKey :: Applicative f => (Int -> a -> f b) -> PatchIntMap a -> f (PatchIntMap b)
45−traverseIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap <$> IntMap.traverseWithKey (\k mv -> traverse (f k) mv) m
46−
47−-- | Extract all @a@s inserted/updated by the given @'PatchIntMap' a@.
48−patchIntMapNewElements :: PatchIntMap a -> [a]
49−patchIntMapNewElements (PatchIntMap m) = catMaybes $ IntMap.elems m
50−
51−-- | Convert the given @'PatchIntMap' a@ into an @'IntMap' a@ with all
52−-- the inserts/updates in the given patch.
53−patchIntMapNewElementsMap :: PatchIntMap a -> IntMap a
54−patchIntMapNewElementsMap (PatchIntMap m) = IntMap.mapMaybe id m
55−
56−-- | Subset the given @'IntMap' a@ to contain only the keys that would be
57−-- deleted by the given @'PatchIntMap' a@.
58−getDeletions :: PatchIntMap v -> IntMap v' -> IntMap v'
59−getDeletions (PatchIntMap m) v = IntMap.intersection v m
src/Reflex/Patch/Map.hsdeleted−55
@@ -1,55 +0,0 @@
1−{-# LANGUAGE LambdaCase #-}
2−{-# LANGUAGE TypeFamilies #-}
3−-- | 'Patch'es on 'Map' that consist only of insertions (including overwrites)
4−-- and deletions
5−module Reflex.Patch.Map where
6−
7−import Reflex.Patch.Class
8−
9−import Data.Map (Map)
10−import qualified Data.Map as Map
11−import Data.Maybe
12−import Data.Semigroup
13−
14−-- | A set of changes to a 'Map'. Any element may be inserted/updated or
15−-- deleted. Insertions are represented as values wrapped in 'Just', while
16−-- deletions are represented as 'Nothing's
17−newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }
18− deriving (Show, Read, Eq, Ord)
19−
20−-- | Apply the insertions or deletions to a given 'Map'.
21−instance Ord k => Patch (PatchMap k v) where
22− type PatchTarget (PatchMap k v) = Map k v
23− {-# INLINABLE apply #-}
24− 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?
25− where insertions = Map.mapMaybeWithKey (const id) p
26− deletions = Map.mapMaybeWithKey (const nothingToJust) p
27− nothingToJust = \case
28− Nothing -> Just ()
29− Just _ -> Nothing
30−
31−-- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@.
32−-- If the same key is modified by both patches, the one on the left will take
33−-- precedence.
34−instance Ord k => Semigroup (PatchMap k v) where
35− PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map
36− -- PatchMap is idempotent, so stimes n is id for every n
37− stimes = stimesIdempotentMonoid
38−
39−-- | The empty 'PatchMap' contains no insertions or deletions
40−instance Ord k => Monoid (PatchMap k v) where
41− mempty = PatchMap mempty
42− mappend = (<>)
43−
44−-- | 'fmap'ping a 'PatchMap' will alter all of the values it will insert.
45−-- Deletions are unaffected.
46−instance Functor (PatchMap k) where
47− fmap f = PatchMap . fmap (fmap f) . unPatchMap
48−
49−-- | Returns all the new elements that will be added to the 'Map'
50−patchMapNewElements :: PatchMap k v -> [v]
51−patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p
52−
53−-- | Returns all the new elements that will be added to the 'Map'
54−patchMapNewElementsMap :: PatchMap k v -> Map k v
55−patchMapNewElementsMap (PatchMap p) = Map.mapMaybe id p
src/Reflex/Patch/MapWithMove.hsdeleted−270
@@ -1,270 +0,0 @@
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/Patch/Patchable.hsdeleted−44
@@ -1,44 +0,0 @@
1−{-# LANGUAGE DeriveGeneric #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE LambdaCase #-}
4−{-# LANGUAGE StandaloneDeriving #-}
5−{-# LANGUAGE TypeFamilies #-}
6−
7−-- The derived instances are undecidable in the case of a pathological instance like
8−-- instance Patch x where
9−-- type PatchTarget x = Patchable x
10−{-# LANGUAGE UndecidableInstances #-}
11−
12−module Reflex.Patch.Patchable where
13−
14−-- import Data.Aeson
15−import GHC.Generics
16−import Reflex.Patch
17−
18−-- | Like SemiMap/PartialMap but for anything patchable
19−data Patchable p
20− = Patchable_Patch p
21− | Patchable_Complete (PatchTarget p)
22− deriving (Generic)
23−
24−completePatchable :: Patchable p -> Maybe (PatchTarget p)
25−completePatchable = \case
26− Patchable_Complete t -> Just t
27− Patchable_Patch _ -> Nothing
28−
29−deriving instance (Eq p, Eq (PatchTarget p)) => Eq (Patchable p)
30−deriving instance (Ord p, Ord (PatchTarget p)) => Ord (Patchable p)
31−deriving instance (Show p, Show (PatchTarget p)) => Show (Patchable p)
32−deriving instance (Read p, Read (PatchTarget p)) => Read (Patchable p)
33−-- instance (ToJSON p, ToJSON (PatchTarget p)) => ToJSON (Patchable p)
34−-- instance (FromJSON p, FromJSON (PatchTarget p)) => FromJSON (Patchable p)
35−
36−instance (Monoid p, Patch p) => Monoid (Patchable p) where
37− mempty = Patchable_Patch mempty
38− mappend = (<>)
39−
40−instance (Semigroup p, Patch p) => Semigroup (Patchable p) where
41− (<>) = curry $ \case
42− (Patchable_Patch a, Patchable_Patch b) -> Patchable_Patch $ a <> b
43− (Patchable_Patch a, Patchable_Complete b) -> Patchable_Complete $ applyAlways a b
44− (Patchable_Complete a, _) -> Patchable_Complete a
src/Reflex/PerformEvent/Base.hs+3−1
@@ -141,7 +141,7 @@ hostPerformEventT a = do
141141 case mToPerform of
142142 Nothing -> return [result']
143143 Just toPerform -> do
144− responses <- runHostFrame $ traverseRequesterData (Identity <$>) toPerform
144+ responses <- runHostFrame $ traverseRequesterData (fmap Identity) toPerform
145145 mrt <- readRef responseTrigger
146146 let followupEventTriggers = case mrt of
147147 Just rt -> [rt :=> Identity responses]
@@ -164,6 +164,8 @@ 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
167169
168170instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m) where
169171 type Ref (PerformEventT t m) = Ref (HostFrame t)
src/Reflex/PerformEvent/Class.hs+6−1
@@ -8,7 +8,6 @@
88{-# LANGUAGE RankNTypes #-}
99{-# LANGUAGE ScopedTypeVariables #-}
1010{-# LANGUAGE TypeFamilies #-}
11−{-# LANGUAGE TypeOperators #-}
1211{-# LANGUAGE UndecidableInstances #-}
1312#ifdef USE_REFLEX_OPTIMIZER
1413{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
@@ -22,6 +21,7 @@ import Reflex.Class
2221import Reflex.TriggerEvent.Class
2322
2423import Control.Monad.Reader
24+import Control.Monad.Trans.Maybe (MaybeT (..))
2525
2626-- | 'PerformEvent' represents actions that can trigger other actions based on
2727-- 'Event's.
@@ -61,3 +61,8 @@ instance PerformEvent t m => PerformEvent t (ReaderT r m) where
6161 performEvent e = do
6262 r <- ask
6363 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+2−1
@@ -9,7 +9,6 @@
99{-# LANGUAGE RecursiveDo #-}
1010{-# LANGUAGE ScopedTypeVariables #-}
1111{-# LANGUAGE TypeFamilies #-}
12−{-# LANGUAGE TypeOperators #-}
1312{-# LANGUAGE UndecidableInstances #-}
1413#ifdef USE_REFLEX_OPTIMIZER
1514{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
@@ -84,6 +83,8 @@ instance MonadHold t m => MonadHold t (PostBuildT t m) where
8483 buildDynamic a0 = lift . buildDynamic a0
8584 {-# INLINABLE headE #-}
8685 headE = lift . headE
86+ {-# INLINABLE now #-}
87+ now = lift now
8788
8889instance PerformEvent t m => PerformEvent t (PostBuildT t m) where
8990 type Performable (PostBuildT t m) = Performable m
src/Reflex/PostBuild/Class.hs−1
@@ -6,7 +6,6 @@
66{-# LANGUAGE FunctionalDependencies #-}
77{-# LANGUAGE ScopedTypeVariables #-}
88{-# LANGUAGE TypeFamilies #-}
9−{-# LANGUAGE TypeOperators #-}
109{-# LANGUAGE UndecidableInstances #-}
1110#ifdef USE_REFLEX_OPTIMIZER
1211{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
src/Reflex/Profiled.hs+77−15
@@ -8,6 +8,9 @@
88{-# LANGUAGE StandaloneDeriving #-}
99{-# LANGUAGE TypeFamilies #-}
1010{-# LANGUAGE UndecidableInstances #-}
11+{-# LANGUAGE PolyKinds #-}
12+{-# LANGUAGE TypeApplications #-}
13+{-# LANGUAGE RankNTypes #-}
1114-- |
1215-- Module:
1316-- Reflex.Profiled
@@ -16,7 +19,6 @@
1619-- profiling/cost-center information.
1720module Reflex.Profiled where
1821
19−import Control.Lens hiding (children)
2022import Control.Monad
2123import Control.Monad.Exception
2224import Control.Monad.Fix
@@ -24,8 +26,10 @@ import Control.Monad.Primitive
2426import Control.Monad.Reader
2527import Control.Monad.Ref
2628import Control.Monad.State.Strict (StateT, execStateT, modify)
29+import Data.Bifunctor
2730import Data.Coerce
28−import Data.Dependent.Map (DMap, GCompare)
31+import Data.Dependent.Map (DMap)
32+import Data.GADT.Compare (GCompare)
2933import Data.FastMutableIntMap
3034import Data.IORef
3135import Data.List
@@ -33,18 +37,27 @@ import Data.Map (Map)
3337import qualified Data.Map.Strict as Map
3438import Data.Monoid ((<>))
3539import Data.Ord
40+import Data.Profunctor.Unsafe ((#.))
3641import qualified Data.Semigroup as S
3742import Data.Type.Coercion
3843import Foreign.Ptr
3944import GHC.Foreign
4045import GHC.IO.Encoding
4146import GHC.Stack
47+import Reflex.Adjustable.Class
48+import Reflex.BehaviorWriter.Class
4249import Reflex.Class
50+import Reflex.DynamicWriter.Class
51+import Reflex.EventWriter.Class
4352import Reflex.Host.Class
53+import Reflex.NotReady.Class
4454import Reflex.PerformEvent.Class
55+import Reflex.PostBuild.Class
56+import Reflex.Query.Class
57+import Reflex.Requester.Class
58+import Reflex.TriggerEvent.Class
4559
4660import System.IO.Unsafe
47−import Unsafe.Coerce
4861
4962data ProfiledTimeline t
5063
@@ -133,27 +146,32 @@ instance Reflex t => Reflex (ProfiledTimeline t) where
133146 push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us
134147 pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e
135148 pull = Behavior_Profiled . pull . coerce
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)
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)
139154 switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b)
140155 coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e)
141156 current (Dynamic_Profiled d) = coerce $ current d
142157 updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d
143158 unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'
144159 unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'
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)))
160+ mergeIncrementalG nt res = Event_Profiled $ mergeIncrementalG (coerce nt) (coerce res)
161+ mergeIncrementalWithMoveG nt res = Event_Profiled $ mergeIncrementalWithMoveG (coerce nt) (coerce res)
147162 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i
148163 updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i
149164 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i
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)))
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)
157175 fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e
158176
159177deriving instance Functor (Dynamic t) => Functor (Dynamic (ProfiledTimeline t))
@@ -166,10 +184,21 @@ instance MonadHold t m => MonadHold (ProfiledTimeline t) (ProfiledM m) where
166184 holdIncremental v0 (Event_Profiled v') = ProfiledM $ Incremental_Profiled <$> holdIncremental v0 v'
167185 buildDynamic (ProfiledM v0) (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> buildDynamic v0 v'
168186 headE (Event_Profiled e) = ProfiledM $ Event_Profiled <$> headE e
187+ now = ProfiledM $ Event_Profiled <$> now
169188
170189instance MonadSample t m => MonadSample (ProfiledTimeline t) (ProfiledM m) where
171190 sample (Behavior_Profiled b) = ProfiledM $ sample b
172191
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+
173202instance MonadTrans ProfiledM where
174203 lift = ProfiledM
175204
@@ -181,6 +210,39 @@ instance PerformEvent t m => PerformEvent (ProfiledTimeline t) (ProfiledM m) whe
181210 performEvent_ = lift . performEvent_ . coerce
182211 performEvent = lift . fmap coerce . performEvent . coerce
183212
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+
184246instance MonadRef m => MonadRef (ProfiledM m) where
185247 type Ref (ProfiledM m) = Ref m
186248 newRef = lift . newRef
src/Reflex/Pure.hs+27−14
@@ -5,6 +5,9 @@
55{-# LANGUAGE MultiParamTypeClasses #-}
66{-# LANGUAGE ScopedTypeVariables #-}
77{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE RankNTypes #-}
9+{-# LANGUAGE PolyKinds #-}
10+
811#ifdef USE_REFLEX_OPTIMIZER
912{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
1013#endif
@@ -29,9 +32,9 @@ module Reflex.Pure
2932 ) where
3033
3134import Control.Monad
32−import Data.Dependent.Map (DMap, GCompare)
35+import Data.Dependent.Map (DMap)
36+import Data.GADT.Compare (GCompare)
3337import qualified Data.Dependent.Map as DMap
34−import Data.Functor.Identity
3538import Data.IntMap (IntMap)
3639import qualified Data.IntMap as IntMap
3740import Data.Maybe
@@ -39,10 +42,11 @@ import Data.MemoTrie
3942import Data.Monoid
4043import Data.Type.Coercion
4144import Reflex.Class
45+import Data.Kind (Type)
4246
4347-- | A completely pure-functional 'Reflex' timeline, identifying moments in time
4448-- with the type @/t/@.
45−data Pure t
49+data Pure (t :: Type)
4650
4751-- | The 'Enum' instance of @/t/@ must be dense: for all @/x :: t/@, there must not exist
4852-- any @/y :: t/@ such that @/'pred' x < y < x/@. The 'HasTrie' instance will be used
@@ -75,17 +79,19 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
7579 -- [UNUSED_CONSTRAINT]: The following type signature for merge will produce a
7680 -- warning because the GCompare instance is not used; however, removing the
7781 -- GCompare instance produces a different warning, due to that constraint
78− -- being present in the original class definition
82+ -- being present in the original class definition.
7983
80− --merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity)
81− merge events = Event $ memo $ \t ->
82− let currentOccurrences = DMap.mapMaybeWithKey (\_ (Event a) -> Identity <$> a t) events
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
8388 in if DMap.null currentOccurrences
8489 then Nothing
8590 else Just currentOccurrences
8691
87− fan :: GCompare k => Event (Pure t) (DMap k Identity) -> EventSelector (Pure t) k
88− fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= fmap runIdentity . DMap.lookup k
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
8995
9096 switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a
9197 switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t
@@ -108,8 +114,8 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
108114 --a) -> Incremental (Pure t) p a
109115 unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t)
110116
111− mergeIncremental = mergeIncrementalImpl
112− mergeIncrementalWithMove = mergeIncrementalImpl
117+ mergeIncrementalG = mergeIncrementalImpl
118+ mergeIncrementalWithMoveG = mergeIncrementalImpl
113119
114120 currentIncremental i = Behavior $ \t -> fst $ unIncremental i t
115121
@@ -124,14 +130,17 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
124130 behaviorCoercion Coercion = Coercion
125131 eventCoercion Coercion = Coercion
126132 dynamicCoercion Coercion = Coercion
133+ incrementalCoercion Coercion Coercion = Coercion
127134
128135 fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k
129136
130137 mergeIntIncremental = mergeIntIncrementalImpl
131138
132−mergeIncrementalImpl :: (PatchTarget p ~ DMap k (Event (Pure t)), GCompare k) => Incremental (Pure t) p -> Event (Pure t) (DMap k Identity)
133−mergeIncrementalImpl i = Event $ \t ->
134− let results = DMap.mapMaybeWithKey (\_ (Event e) -> Identity <$> e t) $ fst $ unIncremental i t
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
135144 in if DMap.null results
136145 then Nothing
137146 else Just results
@@ -202,3 +211,7 @@ instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where
202211 Just x -> fromMaybe lastValue $ apply x lastValue
203212
204213 headE = slowHeadE
214+ now t = Event $ guard . (t ==)
215+
216+
217+
src/Reflex/Query/Base.hs+15−4
@@ -16,21 +16,25 @@ module Reflex.Query.Base
1616 , mapQueryResult
1717 , dynWithQueryT
1818 , withQueryT
19+ , mapQueryT
1920 ) where
2021
2122import Control.Applicative (liftA2)
2223import Control.Monad.Exception
2324import Control.Monad.Fix
25+import Control.Monad.Morph
2426import Control.Monad.Primitive
2527import Control.Monad.Reader
2628import Control.Monad.Ref
2729import Control.Monad.State.Strict
2830import Data.Align
29−import Data.Dependent.Map (DMap, DSum (..))
31+import Data.Dependent.Map (DMap)
3032import qualified Data.Dependent.Map as DMap
33+import Data.Dependent.Sum (DSum(..))
3134import Data.Foldable
3235import Data.Functor.Compose
3336import Data.Functor.Misc
37+import Data.GADT.Compare (GCompare)
3438import Data.IntMap (IntMap)
3539import qualified Data.IntMap as IntMap
3640import Data.Map (Map)
@@ -46,7 +50,7 @@ import Reflex.DynamicWriter.Class
4650import Reflex.EventWriter.Base
4751import Reflex.EventWriter.Class
4852import Reflex.Host.Class
49−import qualified Reflex.Patch.MapWithMove as MapWithMove
53+import qualified Data.Patch.MapWithMove as MapWithMove
5054import Reflex.PerformEvent.Class
5155import Reflex.PostBuild.Class
5256import Reflex.Query.Class
@@ -134,7 +138,7 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t
134138 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
135139 return (liftedResult0, liftedResult')
136140
137− 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'))
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'))
138142 traverseDMapWithKeyWithAdjust f dm0 dm' = do
139143 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
140144 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
@@ -179,7 +183,7 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t
179183 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
180184 return (liftedResult0, liftedResult')
181185
182− 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'))
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'))
183187 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do
184188 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
185189 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
@@ -236,6 +240,9 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t
236240instance MonadTrans (QueryT t q) where
237241 lift = QueryT . lift . lift . lift
238242
243+instance MFunctor (QueryT t q) where
244+ hoist = mapQueryT
245+
239246instance PrimMonad m => PrimMonad (QueryT t q m) where
240247 type PrimState (QueryT t q m) = PrimState m
241248 primitive = lift . primitive
@@ -287,6 +294,10 @@ withQueryT f a = do
287294 (fmapCheap (AdditivePatch . mapQuery f . unAdditivePatch) $ updatedIncremental q)
288295 return result
289296
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+
290301-- | dynWithQueryT's (Dynamic t QueryMorphism) argument needs to be a group homomorphism at all times in order to behave correctly
291302dynWithQueryT :: (MonadFix m, PostBuild t m, Group q, Additive q, Group q', Additive q', Query q')
292303 => Dynamic t (QueryMorphism q q')
src/Reflex/Query/Class.hs+44−4
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE DeriveDataTypeable #-}
23{-# LANGUAGE FlexibleContexts #-}
34{-# LANGUAGE FlexibleInstances #-}
@@ -21,6 +22,7 @@ module Reflex.Query.Class
2122 , MonadQuery (..)
2223 , tellQueryDyn
2324 , queryDyn
25+ , subQuery
2426 , mapQuery
2527 , mapQueryResult
2628 ) where
@@ -35,6 +37,9 @@ import Data.Map.Monoidal (MonoidalMap)
3537import qualified Data.Map.Monoidal as MonoidalMap
3638import Data.Semigroup (Semigroup(..))
3739import Foreign.Storable
40+import Data.Void
41+import Data.Monoid hiding ((<>))
42+import Control.Applicative
3843
3944import Reflex.Class
4045
@@ -50,6 +55,37 @@ instance (Ord k, Query v) => Query (MonoidalMap k v) where
5055 type QueryResult (MonoidalMap k v) = MonoidalMap k (QueryResult v)
5156 crop q r = MonoidalMap.intersectionWith (flip crop) r q
5257
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+
5389-- | QueryMorphism's must be group homomorphisms when acting on the query type
5490-- and compatible with the query relationship when acting on the query result.
5591data QueryMorphism q q' = QueryMorphism
@@ -89,7 +125,7 @@ instance Group SelectedCount where
89125
90126instance Additive SelectedCount
91127
92−-- | The Semigroup/Monoid/Group instances for a Query containing 'SelectedCount's should use
128+-- | The Semigroup\/Monoid\/Group instances for a Query containing 'SelectedCount's should use
93129-- this function which returns Nothing if the result is 0. This allows the pruning of leaves
94130-- of the 'Query' that are no longer wanted.
95131combineSelectedCounts :: SelectedCount -> SelectedCount -> Maybe SelectedCount
@@ -97,12 +133,12 @@ combineSelectedCounts (SelectedCount i) (SelectedCount j) = if i == negate j the
97133
98134-- | A class that allows sending of 'Query's and retrieval of 'QueryResult's. See 'queryDyn' for a commonly
99135-- used interface.
100−class (Group q, Additive q, Query q) => MonadQuery t q m | m -> q t where
136+class (Group q, Additive q, Query q, Monad m) => MonadQuery t q m | m -> q t where
101137 tellQueryIncremental :: Incremental t (AdditivePatch q) -> m ()
102138 askQueryResult :: m (Dynamic t (QueryResult q))
103139 queryIncremental :: Incremental t (AdditivePatch q) -> m (Dynamic t (QueryResult q))
104140
105−instance (Monad m, MonadQuery t q m) => MonadQuery t q (ReaderT r m) where
141+instance MonadQuery t q m => MonadQuery t q (ReaderT r m) where
106142 tellQueryIncremental = lift . tellQueryIncremental
107143 askQueryResult = lift askQueryResult
108144 queryIncremental = lift . queryIncremental
@@ -112,7 +148,11 @@ tellQueryDyn :: (Reflex t, MonadQuery t q m) => Dynamic t q -> m ()
112148tellQueryDyn d = tellQueryIncremental $ unsafeBuildIncremental (sample (current d)) $ attachWith (\old new -> AdditivePatch $ new ~~ old) (current d) (updated d)
113149
114150-- | Retrieve 'Dynamic'ally updating 'QueryResult's for a 'Dynamic'ally updating 'Query'.
115−queryDyn :: (Reflex t, Monad m, MonadQuery t q m) => Dynamic t q -> m (Dynamic t (QueryResult q))
151+queryDyn :: (Reflex t, MonadQuery t q m) => Dynamic t q -> m (Dynamic t (QueryResult q))
116152queryDyn q = do
117153 tellQueryDyn q
118154 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+97−27
@@ -1,6 +1,7 @@
11-- | This module provides 'RequesterT', the standard implementation of
22-- 'Requester'.
33{-# LANGUAGE AllowAmbiguousTypes #-}
4+{-# LANGUAGE ApplicativeDo #-}
45{-# LANGUAGE CPP #-}
56{-# LANGUAGE EmptyDataDecls #-}
67{-# LANGUAGE ExistentialQuantification #-}
@@ -32,6 +33,7 @@ module Reflex.Requester.Base
3233 , requesterDataToList
3334 , singletonRequesterData
3435 , matchResponsesWithRequests
36+ , matchResponseMapWithRequests
3537 , multiEntry
3638 , unMultiEntry
3739 , requesting'
@@ -49,14 +51,17 @@ import Reflex.TriggerEvent.Class
4951import Control.Applicative (liftA2)
5052import Control.Monad.Exception
5153import Control.Monad.Identity
54+import Control.Monad.Morph
5255import Control.Monad.Primitive
5356import Control.Monad.Reader
5457import Control.Monad.Ref
5558import Control.Monad.State.Strict
5659import Data.Bits
5760import Data.Coerce
58−import Data.Dependent.Map (DMap, DSum (..))
61+import Data.Constraint
62+import Data.Dependent.Map (DMap)
5963import qualified Data.Dependent.Map as DMap
64+import Data.Dependent.Sum (DSum (..))
6065import Data.Functor.Compose
6166import Data.Functor.Misc
6267import Data.IntMap.Strict (IntMap)
@@ -79,19 +84,51 @@ newtype TagMap (f :: * -> *) = TagMap (IntMap Any)
7984
8085newtype RequesterData f = RequesterData (TagMap (Entry f))
8186
87+emptyRequesterData :: RequesterData f
88+emptyRequesterData = RequesterData $ TagMap IntMap.empty
89+
8290data RequesterDataKey a where
8391 RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a
8492 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
85− RequesterDataKey_Multi2 :: {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
93+ RequesterDataKey_Multi2 :: GCompare k => {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
8694 RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
8795
8896singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f
8997singletonRequesterData rdk v = case rdk of
9098 RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v
9199 RequesterDataKey_Multi k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v
92− RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Map.singleton k' $ 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+ }
93104 RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
94105
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+
95132requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]
96133requesterDataToList (RequesterData m) = do
97134 k :=> Entry e <- tagMapToList m
@@ -101,11 +138,12 @@ requesterDataToList (RequesterData m) = do
101138 (k', e') <- IntMap.toList e
102139 k'' :=> e'' <- requesterDataToList e'
103140 return $ RequesterDataKey_Multi k k' k'' :=> e''
104− MyTagType_Multi2 -> do
105− (k', e') <- Map.toList e
106− (k'', e'') <- IntMap.toList e'
107− k''' :=> e''' <- requesterDataToList e''
108− return $ RequesterDataKey_Multi2 k 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'''
109147 MyTagType_Multi3 -> do
110148 (k', e') <- IntMap.toList e
111149 (k'', e'') <- IntMap.toList e'
@@ -133,7 +171,13 @@ traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWith
133171 go k (Entry request) = Entry <$> case myKeyType k of
134172 MyTagType_Single -> f request
135173 MyTagType_Multi -> traverse (traverseRequesterData f) request
136− MyTagType_Multi2 -> traverse (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+ }
137181 MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request
138182
139183-- | 'traverseRequesterData' with its arguments flipped
@@ -177,9 +221,14 @@ instance MyTagTypeOffset Multi3 where
177221type family EntryContents request a where
178222 EntryContents request (Single a) = request a
179223 EntryContents request Multi = IntMap (RequesterData request)
180− EntryContents request (Multi2 k) = Map (Some k) (IntMap (RequesterData request))
224+ EntryContents request (Multi2 k) = Multi2Contents k request
181225 EntryContents request Multi3 = IntMap (IntMap (RequesterData request))
182226
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+
183232newtype Entry request x = Entry { unEntry :: EntryContents request x }
184233
185234{-# INLINE singleEntry #-}
@@ -308,7 +357,7 @@ tagRequest req = do
308357 return t
309358
310359{-# INLINE responseFromTag #-}
311−responseFromTag :: Monad m => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))
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))
312361responseFromTag (MyTagWrap t) = do
313362 responses :: EventSelectorInt t Any <- RequesterT ask
314363 return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t
@@ -316,6 +365,9 @@ responseFromTag (MyTagWrap t) = do
316365instance MonadTrans (RequesterT t request response) where
317366 lift = RequesterT . lift . lift
318367
368+instance MFunctor (RequesterT t request response) where
369+ hoist f = RequesterT . hoist (hoist f) . unRequesterT
370+
319371instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where
320372 type Performable (RequesterT t request response m) = Performable m
321373 performEvent_ = lift . performEvent_
@@ -435,9 +487,9 @@ traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchN
435487 let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))
436488 responses = fanMap $ fmapCheap unpack response
437489 unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))
438− unpack = unEntry
490+ unpack = _multi2Contents_values . unEntry
439491 pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)
440− pack = Entry
492+ pack m = Entry $ Multi2Contents { _multi2Contents_values = m, _multi2Contents_dict = Dict }
441493 f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)
442494 f' k (Compose (n, v)) = do
443495 (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some k))
@@ -458,9 +510,6 @@ traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchN
458510data Decoder rawResponse response =
459511 forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)
460512
461−-- | Matches incoming responses with previously-sent requests
462−-- and uses the provided request "decoder" function to process
463−-- incoming responses.
464513matchResponsesWithRequests
465514 :: forall t rawRequest rawResponse request response m.
466515 ( MonadFix m
@@ -479,7 +528,30 @@ matchResponsesWithRequests
479528 )
480529 -- ^ A map of outgoing wire-format requests and an event of responses keyed
481530 -- by the 'RequesterData' key of the associated outgoing request
482−matchResponsesWithRequests f send recv = do
531+matchResponsesWithRequests f send recv = matchResponseMapWithRequests f send $ uncurry Map.singleton <$> recv
532+
533+-- | Matches incoming responses with previously-sent requests
534+-- and uses the provided request "decoder" function to process
535+-- incoming responses.
536+matchResponseMapWithRequests
537+ :: forall t rawRequest rawResponse request response m.
538+ ( MonadFix m
539+ , MonadHold t m
540+ , Reflex t
541+ )
542+ => (forall a. request a -> (rawRequest, rawResponse -> response a))
543+ -- ^ Given a request (from 'Requester'), produces the wire format of the
544+ -- request and a function used to process the associated response
545+ -> Event t (RequesterData request)
546+ -- ^ The outgoing requests
547+ -> Event t (Map Int rawResponse)
548+ -- ^ A map of incoming responses, tagged by an identifying key
549+ -> m ( Event t (Map Int rawRequest)
550+ , Event t (RequesterData response)
551+ )
552+ -- ^ A map of outgoing wire-format requests and an event of responses keyed
553+ -- by the 'RequesterData' key of the associated outgoing request
554+matchResponseMapWithRequests f send recv = do
483555 rec nextId <- hold 1 $ fmap (\(next, _, _) -> next) outgoing
484556 waitingFor :: Incremental t (PatchMap Int (Decoder rawResponse response)) <-
485557 holdIncremental mempty $ leftmost
@@ -521,17 +593,15 @@ matchResponsesWithRequests f send recv = do
521593 processIncoming
522594 :: Incremental t (PatchMap Int (Decoder rawResponse response))
523595 -- A map of outstanding expected responses
524− -> Event t (Int, rawResponse)
596+ -> Event t (Map Int rawResponse)
525597 -- A incoming response paired with its identifying key
526598 -> Event t (RequesterData response, PatchMap Int v)
527599 -- The decoded response and a patch that clears the outstanding responses queue
528− processIncoming waitingFor inc = flip push inc $ \(n, rawRsp) -> do
600+ processIncoming waitingFor inc = flip push inc $ \rspMap -> do
529601 wf <- sample $ currentIncremental waitingFor
530− case Map.lookup n wf of
531− Nothing -> return Nothing -- TODO How should lookup failures be handled here? They shouldn't ever happen..
532− Just (Decoder k rspF) -> do
533− let rsp = rspF rawRsp
534− return $ Just
535− ( singletonRequesterData k rsp
536− , PatchMap $ Map.singleton n Nothing
537− )
602+ let match rawRsp (Decoder k rspF) =
603+ let rsp = rspF rawRsp
604+ in singletonRequesterData k rsp
605+ matches = Map.intersectionWith match rspMap wf
606+ pure $ if Map.null matches then Nothing else Just
607+ (Map.foldl' mergeRequesterData emptyRequesterData matches, PatchMap $ Nothing <$ matches)
src/Reflex/Spider/Internal.hs+695−420
@@ -9,16 +9,22 @@
99{-# LANGUAGE GADTs #-}
1010{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1111{-# LANGUAGE LambdaCase #-}
12−{-# LANGUAGE MultiWayIf #-}
1312{-# LANGUAGE RankNTypes #-}
1413{-# LANGUAGE RoleAnnotations #-}
1514{-# LANGUAGE ScopedTypeVariables #-}
1615{-# LANGUAGE TypeFamilies #-}
1716{-# LANGUAGE TypeOperators #-}
1817{-# LANGUAGE UndecidableInstances #-}
18+{-# LANGUAGE PolyKinds #-}
19+{-# LANGUAGE DeriveFunctor #-}
20+{-# LANGUAGE StandaloneDeriving #-}
21+{-# LANGUAGE InstanceSigs #-}
22+{-# LANGUAGE MultiWayIf #-}
23+
1924#ifdef USE_REFLEX_OPTIMIZER
2025{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
2126#endif
27+{-# OPTIONS_GHC -Wunused-binds #-}
2228-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
2329-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
2430module Reflex.Spider.Internal (module Reflex.Spider.Internal) where
@@ -32,12 +38,17 @@ import Control.Monad hiding (forM, forM_, mapM, mapM_)
3238import Control.Monad.Exception
3339import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)
3440import Control.Monad.Primitive
35−import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_)
41+import Control.Monad.Reader.Class
42+import Control.Monad.IO.Class
43+import Control.Monad.ReaderIO
3644import Control.Monad.Ref
45+import Control.Monad.Fail (MonadFail)
46+import qualified Control.Monad.Fail as MonadFail
3747import Data.Align
3848import Data.Coerce
39−import Data.Dependent.Map (DMap, DSum (..))
49+import Data.Dependent.Map (DMap)
4050import qualified Data.Dependent.Map as DMap
51+import Data.Dependent.Sum (DSum (..))
4152import Data.FastMutableIntMap (FastMutableIntMap, PatchIntMap (..))
4253import qualified Data.FastMutableIntMap as FastMutableIntMap
4354import Data.Foldable hiding (concat, elem, sequence_)
@@ -48,13 +59,15 @@ import Data.GADT.Compare
4859import Data.IntMap.Strict (IntMap)
4960import qualified Data.IntMap.Strict as IntMap
5061import Data.IORef
62+import Data.Kind (Type)
5163import Data.Maybe hiding (mapMaybe)
52−import Data.Monoid ((<>))
64+import Data.Monoid (mempty, (<>))
5365import Data.Proxy
5466import Data.These
5567import Data.Traversable
68+import Data.Type.Equality ((:~:)(Refl))
5669import Data.Witherable (Filterable, mapMaybe)
57−import GHC.Exts
70+import GHC.Exts hiding (toList)
5871import GHC.IORef (IORef (..))
5972import GHC.Stack
6073import Reflex.FastWeak
@@ -73,37 +86,46 @@ import Data.Zip (Zip (..))
7386
7487#ifdef DEBUG_CYCLES
7588import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)
89+#endif
90+
7691import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
7792import qualified Data.List.NonEmpty as NonEmpty
78−import Data.Monoid (mempty)
7993import Data.Tree (Forest, Tree (..), drawForest)
80−#endif
94+import Data.List (isPrefixOf)
8195
82−import Data.FastWeakBag (FastWeakBag)
96+import Data.FastWeakBag (FastWeakBag, FastWeakBagTicket)
8397import qualified Data.FastWeakBag as FastWeakBag
98+
8499import Data.Reflection
85100import Data.Some (Some(Some))
86101import Data.Type.Coercion
102+import Data.Profunctor.Unsafe ((#.), (.#))
87103import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)
88104import qualified Data.WeakBag as WeakBag
89105import qualified Reflex.Class
90106import qualified Reflex.Class as R
91107import qualified Reflex.Host.Class
92108import Reflex.NotReady.Class
93−import Reflex.Patch
94−import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
109+import Data.Patch
110+import qualified Data.Patch.DMapWithMove as PatchDMapWithMove
111+import Reflex.PerformEvent.Base (PerformEventT)
95112
96113#ifdef DEBUG_TRACE_EVENTS
97114import qualified Data.ByteString.Char8 as BS8
98115import System.IO (stderr)
116+import Data.List (isPrefixOf)
99117#endif
100118
101−#ifdef DEBUG_TRACE_EVENTS
119+-- TODO stdout might not be the best channel for debug output
120+debugStrLn :: String -> IO ()
121+debugStrLn = putStrLn
102122
123+#ifdef DEBUG_TRACE_EVENTS
103124withStackOneLine :: (BS8.ByteString -> a) -> a
104125withStackOneLine expr = unsafePerformIO $ do
105126 stack <- currentCallStack
106− return (expr (BS8.pack (unwords (reverse stack))))
127+ return (expr . BS8.pack . unwords . dropInternal . reverse $ stack)
128+ where dropInternal = filterStack "Reflex.Spider.Internal"
107129
108130#endif
109131
@@ -114,28 +136,42 @@ debugInvalidateHeight :: Bool
114136debugInvalidate :: Bool
115137
116138#ifdef DEBUG
117−
118139#define DEBUG_NODEIDS
119140
141+#ifdef DEBUG_TRACE_PROPAGATION
120142debugPropagate = True
143+#else
144+debugPropagate = False
145+#endif
121146
147+#ifdef DEBUG_TRACE_HEIGHT
148+debugInvalidateHeight = True
149+#else
122150debugInvalidateHeight = False
151+#endif
123152
153+#ifdef DEBUG_TRACE_INVALIDATION
124154debugInvalidate = True
155+#else
156+debugInvalidate = False
157+#endif
125158
126159class HasNodeId a where
127160 getNodeId :: a -> Int
128161
129−instance HasNodeId (Hold x p a) where
130− getNodeId = holdNodeId
162+instance HasNodeId (CacheSubscribed x a) where
163+ getNodeId = _cacheSubscribed_nodeId
131164
132−instance HasNodeId (PushSubscribed x a b) where
133− getNodeId = pushSubscribedNodeId
165+instance HasNodeId (FanInt x a) where
166+ getNodeId = _fanInt_nodeId
167+
168+instance HasNodeId (Hold x p) where
169+ getNodeId = holdNodeId
134170
135171instance HasNodeId (SwitchSubscribed x a) where
136172 getNodeId = switchSubscribedNodeId
137173
138−instance HasNodeId (FanSubscribed x a) where
174+instance HasNodeId (FanSubscribed x v a) where
139175 getNodeId = fanSubscribedNodeId
140176
141177instance HasNodeId (CoincidenceSubscribed x a) where
@@ -149,41 +185,16 @@ instance HasNodeId (Pull x a) where
149185
150186{-# INLINE showNodeId #-}
151187showNodeId :: HasNodeId a => a -> String
152−showNodeId = ("#"<>) . show . getNodeId
153−
154−showSubscriberType :: Subscriber x a -> String
155−showSubscriberType = \case
156− SubscriberPush _ _ -> "SubscriberPush"
157− SubscriberMerge _ _ -> "SubscriberMerge"
158− SubscriberFan _ -> "SubscriberFan"
159− SubscriberMergeChange _ -> "SubscriberMergeChange"
160− SubscriberHold _ -> "SubscriberHold"
161− SubscriberHoldIdentity _ -> "SubscriberHoldIdentity"
162− SubscriberSwitch _ -> "SubscriberSwitch"
163− SubscriberCoincidenceOuter _ -> "SubscriberCoincidenceOuter"
164− SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"
165− SubscriberHandle -> "SubscriberHandle"
166−
167−showEventType :: Event x a -> String
168−showEventType = \case
169− EventRoot _ _ -> "EventRoot"
170− EventNever -> "EventNever"
171− EventPush _ -> "EventPush"
172− EventMerge _ -> "EventMerge"
173− EventFan _ _ -> "EventFan"
174− EventSwitch _ -> "EventSwitch"
175− EventCoincidence _ -> "EventCoincidence"
176− EventHold _ -> "EventHold"
177− EventDyn _ -> "EventDyn"
178− EventHoldIdentity _ -> "EventHoldIdentity"
179− EventDynIdentity _ -> "EventDynIdentity"
188+showNodeId = showNodeId' . getNodeId
189+
190+showNodeId' :: Int -> String
191+showNodeId' = ("#"<>) . show
192+
180193
181194#else
182195
183196debugPropagate = False
184−
185197debugInvalidateHeight = False
186−
187198debugInvalidate = False
188199
189200-- This must be inline, or error messages will cause memory leaks due to retaining the node in question
@@ -191,6 +202,10 @@ debugInvalidate = False
191202showNodeId :: a -> String
192203showNodeId _ = ""
193204
205+{-# INLINE showNodeId' #-}
206+showNodeId' :: Int -> String
207+showNodeId' _ = ""
208+
194209#endif
195210
196211#ifdef DEBUG_NODEIDS
@@ -200,12 +215,6 @@ nextNodeIdRef = unsafePerformIO $ newIORef 1
200215
201216newNodeId :: IO Int
202217newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
203−
204−{-# NOINLINE unsafeNodeId #-}
205−unsafeNodeId :: a -> Int
206−unsafeNodeId a = unsafePerformIO $ do
207− touch a
208− newNodeId
209218#endif
210219
211220--------------------------------------------------------------------------------
@@ -242,9 +251,9 @@ subscribeAndRead = unEvent
242251-- caching; if the computation function is very cheap, this is (much) more
243252-- efficient than 'push'
244253{-# INLINE [1] pushCheap #-}
245−pushCheap :: (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
254+pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
246255pushCheap !f e = Event $ \sub -> do
247− (subscription, occ) <- subscribeAndRead e $ sub
256+ (subscription, occ) <- subscribeAndRead e $ debugSubscriber' "push" $ sub
248257 { subscriberPropagate = \a -> do
249258 mb <- f a
250259 mapM_ (subscriberPropagate sub) mb
@@ -263,10 +272,10 @@ terminalSubscriber p = Subscriber
263272
264273-- | Subscribe to an Event only for the duration of one occurrence
265274{-# INLINE subscribeAndReadHead #-}
266−subscribeAndReadHead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)
275+subscribeAndReadHead :: HasSpiderTimeline x => Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)
267276subscribeAndReadHead e sub = do
268277 subscriptionRef <- liftIO $ newIORef $ error "subscribeAndReadHead: not initialized"
269− (subscription, occ) <- subscribeAndRead e $ sub
278+ (subscription, occ) <- subscribeAndRead e $ debugSubscriber' "head" $ sub
270279 { subscriberPropagate = \a -> do
271280 liftIO $ unsubscribe =<< readIORef subscriptionRef
272281 subscriberPropagate sub a
@@ -277,24 +286,42 @@ subscribeAndReadHead e sub = do
277286 return (subscription, occ)
278287
279288--TODO: Make this lazy in its input event
280−headE :: (MonadIO m, Defer (SomeMergeInit x) m) => Event x a -> m (Event x a)
289+headE :: (MonadIO m, Defer (SomeMergeInit x) m, HasSpiderTimeline x) => Event x a -> m (Event x a)
281290headE originalE = do
282291 parent <- liftIO $ newIORef $ Just originalE
283292 defer $ SomeMergeInit $ do --TODO: Rename SomeMergeInit appropriately
284293 let clearParent = liftIO $ writeIORef parent Nothing
285− (_, occ) <- subscribeAndReadHead originalE $ terminalSubscriber $ \_ -> clearParent
294+ (_, occ) <- subscribeAndReadHead originalE $ terminalSubscriber $ const clearParent
286295 when (isJust occ) clearParent
287− return $ Event $ \sub -> do
296+ return $ Event $ \sub ->
288297 liftIO (readIORef parent) >>= \case
289− Nothing -> return (EventSubscription (return ()) $ EventSubscribed zeroRef $ toAny (), Nothing)
298+ Nothing -> subscribeAndReadNever
290299 Just e -> subscribeAndReadHead e sub
291300
292301data CacheSubscribed x a
293302 = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(FastWeakBag (Subscriber x a))
294303 , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)
295304 , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))
305+#ifdef DEBUG_NODEIDS
306+ , _cacheSubscribed_nodeId :: {-# UNPACK #-} !Int
307+#endif
296308 }
297309
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+
298325-- | Construct an 'Event' whose value is guaranteed not to be recomputed
299326-- repeatedly
300327--
@@ -309,27 +336,33 @@ cacheEvent e =
309336#else
310337 Event $
311338#endif
312− let mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))
313− !mSubscribedRef = unsafeNewIORef e emptyFastWeak
314− in \sub -> {-# SCC "cacheEvent" #-} do
339+ unsafePerformIO $ do
340+ mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))
341+ <- newIORef emptyFastWeak
342+ pure $ \sub -> {-# SCC "cacheEvent" #-} do
315343#ifdef DEBUG_TRACE_EVENTS
316344 unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite
317345#endif
318346 subscribedTicket <- liftIO (readIORef mSubscribedRef >>= getFastWeakTicket) >>= \case
319347 Just subscribedTicket -> return subscribedTicket
320348 Nothing -> do
349+#ifdef DEBUG_NODEIDS
350+ nodeId <- liftIO newNodeId
351+#endif
321352 subscribers <- liftIO FastWeakBag.empty
322353 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
323357 (parentSub, occ) <- subscribeAndRead e $ Subscriber
324− { subscriberPropagate = \a -> do
325− liftIO $ writeIORef occRef $ Just a
326− scheduleClear occRef
327− propagateFast a subscribers
328− , subscriberInvalidateHeight = \old -> do
329− FastWeakBag.traverse subscribers $ invalidateSubscriberHeight old
330− , subscriberRecalculateHeight = \new -> do
331− FastWeakBag.traverse subscribers $ recalculateSubscriberHeight new
332− }
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+ }
333366 when (isJust occ) $ do
334367 liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing
335368 scheduleClear occRef
@@ -337,29 +370,45 @@ cacheEvent e =
337370 { _cacheSubscribed_subscribers = subscribers
338371 , _cacheSubscribed_parent = parentSub
339372 , _cacheSubscribed_occurrence = occRef
373+#ifdef DEBUG_NODEIDS
374+ , _cacheSubscribed_nodeId = nodeId
375+#endif
340376 }
341377 subscribedTicket <- liftIO $ mkFastWeakTicket subscribed
342378 liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket
343379 return subscribedTicket
344− liftIO $ do
345− subscribed <- getFastWeakTicketValue subscribedTicket
346− ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed
347− occ <- readIORef $ _cacheSubscribed_occurrence subscribed
348− let es = EventSubscription
349− { _eventSubscription_unsubscribe = do
350− FastWeakBag.remove ticket
351− isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed
352− when isEmpty $ do
353− writeIORef mSubscribedRef emptyFastWeak
354− unsubscribe $ _cacheSubscribed_parent subscribed
355− touch ticket
356− touch subscribedTicket
357− , _eventSubscription_subscribed = EventSubscribed
358− { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed
359− , eventSubscribedRetained = toAny subscribedTicket
360− }
361− }
362− return (es, occ)
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+
363412
364413subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)
365414subscribe e s = fst <$> subscribeAndRead e s
@@ -371,13 +420,16 @@ wrap tag getSpecificSubscribed sub = do
371420 let es = tag subd
372421 return (EventSubscription (WeakBag.remove sln >> touch sln) es, occ)
373422
374−eventRoot :: GCompare k => k a -> Root x k -> Event x a
423+eventRoot :: (GCompare k, HasSpiderTimeline x) => k a -> Root x k -> Event x a
375424eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r
376425
426+subscribeAndReadNever :: EventM x (EventSubscription x, Maybe a)
427+subscribeAndReadNever = return (EventSubscription (return ()) eventSubscribedNever, Nothing)
428+
377429eventNever :: Event x a
378−eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
430+eventNever = Event $ const subscribeAndReadNever
379431
380−eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k -> Event x a
432+eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k v -> Event x (v a)
381433eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
382434
383435eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a
@@ -412,16 +464,6 @@ data Subscriber x a = Subscriber
412464 , subscriberRecalculateHeight :: !(Height -> IO ())
413465 }
414466
415−--TODO: Move this comment to WeakBag
416−-- These function are constructor functions that are marked NOINLINE so they are
417−-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away
418−-- so any weak references that are attached to the constructors will have their
419−-- finalizer run. Using the opaque constructor, does not see the
420−-- constructor application, so it behaves like an IORef and cannot be fused away.
421−--
422−-- The result is also evaluated to WHNF, since forcing a thunk invalidates
423−-- the weak pointer to it in some cases.
424−
425467newSubscriberHold :: (HasSpiderTimeline x, Patch p) => Hold x p -> IO (Subscriber x p)
426468newSubscriberHold h = return $ Subscriber
427469 { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h
@@ -429,85 +471,68 @@ newSubscriberHold h = return $ Subscriber
429471 , subscriberRecalculateHeight = \_ -> return ()
430472 }
431473
432−newSubscriberFan :: forall x k. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k -> IO (Subscriber x (DMap k Identity))
433−newSubscriberFan subscribed = return $ Subscriber
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
434476 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
435477 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
436− tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
478+ tracePropagate (Proxy :: Proxy x) $ show (DMap.size subs) <> " keys subscribed, " <> show (DMap.size a) <> " keys firing"
437479 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
438480 scheduleClear $ fanSubscribedOccurrence subscribed
439− let f _ (Pair (Identity v) subsubs) = do
481+ let f _ (Pair v subsubs) = do
440482 propagate v $ _fanSubscribedChildren_list subsubs
441483 return $ Constant ()
442484 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
443485 return ()
444486 , subscriberInvalidateHeight = \old -> do
445− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
446487 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
447− forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old
448− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
488+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old
449489 , subscriberRecalculateHeight = \new -> do
450− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
451490 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
452− forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new
453− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
491+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new
454492 }
455493
456494newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)
457−newSubscriberSwitch subscribed = return $ Subscriber
495+newSubscriberSwitch subscribed = debugSubscriber ("SubscriberCoincidenceOuter" <> showNodeId subscribed) $ Subscriber
458496 { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do
459− tracePropagate (Proxy :: Proxy x) $ "SubscriberSwitch" <> showNodeId subscribed
460497 liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a
461498 scheduleClear $ switchSubscribedOccurrence subscribed
462499 propagate a $ switchSubscribedSubscribers subscribed
463500 , subscriberInvalidateHeight = \_ -> do
464− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
465501 oldHeight <- readIORef $ switchSubscribedHeight subscribed
466502 when (oldHeight /= invalidHeight) $ do
467503 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
468− WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
469− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
470− , subscriberRecalculateHeight = \new -> do
471− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
472− updateSwitchHeight new subscribed
473− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
474− }
504+ WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
505+ , subscriberRecalculateHeight = (`updateSwitchHeight` subscribed)
506+ }
475507
476508newSubscriberCoincidenceOuter :: forall x b. HasSpiderTimeline x => CoincidenceSubscribed x b -> IO (Subscriber x (Event x b))
477−newSubscriberCoincidenceOuter subscribed = return $ Subscriber
509+newSubscriberCoincidenceOuter subscribed = debugSubscriber ("SubscriberCoincidenceOuter" <> showNodeId subscribed) $ Subscriber
478510 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do
479− tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceOuter" <> showNodeId subscribed
480511 outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed
481512 tracePropagate (Proxy :: Proxy x) $ " outerHeight = " <> show outerHeight
482513 (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed
483514 tracePropagate (Proxy :: Proxy x) $ " isJust occ = " <> show (isJust occ)
484515 tracePropagate (Proxy :: Proxy x) $ " innerHeight = " <> show innerHeight
516+
485517 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd
486518 scheduleClear $ coincidenceSubscribedInnerParent subscribed
487519 case occ of
488− Nothing -> do
520+ Nothing ->
489521 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
490522 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight
491− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight
492− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight
523+ WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight
524+ WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight
493525 Just o -> do -- Since it's already firing, no need to adjust height
494526 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
495527 scheduleClear $ coincidenceSubscribedOccurrence subscribed
496528 propagate o $ coincidenceSubscribedSubscribers subscribed
497− , subscriberInvalidateHeight = \_ -> do
498− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
499− invalidateCoincidenceHeight subscribed
500− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
501− , subscriberRecalculateHeight = \_ -> do
502− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
503− recalculateCoincidenceHeight subscribed
504− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
529+ , subscriberInvalidateHeight = \_ -> invalidateCoincidenceHeight subscribed
530+ , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed
505531 }
506532
507533newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)
508−newSubscriberCoincidenceInner subscribed = return $ Subscriber
534+newSubscriberCoincidenceInner subscribed = debugSubscriber ("SubscriberCoincidenceInner" <> showNodeId subscribed) $ Subscriber
509535 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do
510− tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceInner" <> showNodeId subscribed
511536 occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed
512537 case occ of
513538 Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event
@@ -515,14 +540,8 @@ newSubscriberCoincidenceInner subscribed = return $ Subscriber
515540 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a
516541 scheduleClear $ coincidenceSubscribedOccurrence subscribed
517542 propagate a $ coincidenceSubscribedSubscribers subscribed
518− , subscriberInvalidateHeight = \_ -> do
519− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
520− invalidateCoincidenceHeight subscribed
521− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
522− , subscriberRecalculateHeight = \_ -> do
523− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
524− recalculateCoincidenceHeight subscribed
525− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
543+ , subscriberInvalidateHeight = \_ -> invalidateCoincidenceHeight subscribed
544+ , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed
526545 }
527546
528547invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()
@@ -532,18 +551,18 @@ recalculateSubscriberHeight :: Height -> Subscriber x a -> IO ()
532551recalculateSubscriberHeight = flip subscriberRecalculateHeight
533552
534553-- | Propagate everything at the current height
535−propagate :: a -> WeakBag (Subscriber x a) -> EventM x ()
536−propagate a subscribers = withIncreasedDepth $ do
554+propagate :: forall x a. HasSpiderTimeline x => a -> WeakBag (Subscriber x a) -> EventM x ()
555+propagate a subscribers = withIncreasedDepth (Proxy::Proxy x) $
537556 -- 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
538557 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
539− WeakBag.traverse subscribers $ \s -> subscriberPropagate s a
558+ WeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a
540559
541560-- | Propagate everything at the current height
542−propagateFast :: a -> FastWeakBag (Subscriber x a) -> EventM x ()
543−propagateFast a subscribers = withIncreasedDepth $ do
561+propagateFast :: forall x a. HasSpiderTimeline x => a -> FastWeakBag (Subscriber x a) -> EventM x ()
562+propagateFast a subscribers = withIncreasedDepth (Proxy::Proxy x) $
544563 -- 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
545564 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
546− FastWeakBag.traverse subscribers $ \s -> subscriberPropagate s a
565+ FastWeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a
547566
548567--------------------------------------------------------------------------------
549568-- EventSubscribed
@@ -552,11 +571,16 @@ propagateFast a subscribers = withIncreasedDepth $ do
552571toAny :: a -> Any
553572toAny = unsafeCoerce
554573
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.
555579data EventSubscribed x = EventSubscribed
556580 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
557581 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
558582#ifdef DEBUG_CYCLES
559− , eventSubscribedGetParents :: !(IO [Some (EventSubscribed x)]) -- For debugging loops
583+ , eventSubscribedGetParents :: !(IO [EventSubscribed x]) -- For debugging loops
560584 , eventSubscribedHasOwnHeightRef :: !Bool
561585 , eventSubscribedWhoCreated :: !(IO [String])
562586#endif
@@ -583,13 +607,23 @@ eventSubscribedNever = EventSubscribed
583607 , eventSubscribedWhoCreated = return ["never"]
584608#endif
585609 }
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+ }
586620
587−eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x
621+eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x
588622eventSubscribedFan !subscribed = EventSubscribed
589623 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
590624 , eventSubscribedRetained = toAny subscribed
591625#ifdef DEBUG_CYCLES
592− , eventSubscribedGetParents = return [Some $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
626+ , eventSubscribedGetParents = return [_eventSubscription_subscribed $ fanSubscribedParent subscribed]
593627 , eventSubscribedHasOwnHeightRef = False
594628 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
595629#endif
@@ -602,7 +636,7 @@ eventSubscribedSwitch !subscribed = EventSubscribed
602636#ifdef DEBUG_CYCLES
603637 , eventSubscribedGetParents = do
604638 s <- readIORef $ switchSubscribedCurrentParent subscribed
605− return [Some $ _eventSubscription_subscribed s]
639+ return [_eventSubscription_subscribed s]
606640 , eventSubscribedHasOwnHeightRef = True
607641 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
608642#endif
@@ -615,8 +649,8 @@ eventSubscribedCoincidence !subscribed = EventSubscribed
615649#ifdef DEBUG_CYCLES
616650 , eventSubscribedGetParents = do
617651 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
618− let outerParent = Some $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
619− innerParents = maybeToList $ fmap Some innerSubscription
652+ let outerParent = _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
653+ innerParents = maybeToList $ innerSubscription
620654 return $ outerParent : innerParents
621655 , eventSubscribedHasOwnHeightRef = True
622656 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
@@ -630,15 +664,15 @@ getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es
630664whoCreatedEventSubscribed :: EventSubscribed x -> IO [String]
631665whoCreatedEventSubscribed = eventSubscribedWhoCreated
632666
633−walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)]
667+walkInvalidHeightParents :: EventSubscribed x -> IO [EventSubscribed x]
634668walkInvalidHeightParents s0 = do
635− subscribers <- flip execStateT mempty $ ($ Some s0) $ fix $ \loop (Some s) -> do
669+ subscribers <- flip execStateT mempty $ ($ s0) $ fix $ \loop s -> do
636670 h <- liftIO $ readIORef $ eventSubscribedHeightRef s
637671 when (h == invalidHeight) $ do
638672 when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed
639− modify (Some s :)
673+ modify (s :)
640674 mapM_ loop =<< liftIO (eventSubscribedGetParents s)
641− forM_ subscribers $ \(Some s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
675+ forM_ subscribers $ \s -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
642676 return subscribers
643677#endif
644678
@@ -675,7 +709,7 @@ behaviorPull !p = Behavior $ do
675709 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
676710 parentsRef <- liftIO $ newIORef []
677711 holdInits <- askBehaviorHoldInits
678− a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
712+ a <- liftIO $ runReaderIO (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
679713 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
680714 parents <- liftIO $ readIORef parentsRef
681715 let subscribed = PullSubscribed
@@ -710,42 +744,46 @@ readBehaviorUntracked b = do
710744-- Dynamic
711745--------------------------------------------------------------------------------
712746
713−data Dynamic x p = Dynamic
714− { dynamicCurrent :: !(Behavior x (PatchTarget p))
747+type DynamicS x p = Dynamic x (PatchTarget p) p
748+
749+data Dynamic x target p = Dynamic
750+ { dynamicCurrent :: !(Behavior x target)
715751 , dynamicUpdated :: Event x p -- This must be lazy; see the comment on holdEvent --TODO: Would this let us eliminate `Dyn`?
716752 }
717753
718−dynamicHold :: Hold x p -> Dynamic x p
754+deriving instance (HasSpiderTimeline x) => Functor (Dynamic x target)
755+
756+
757+
758+
759+dynamicHold :: Hold x p -> DynamicS x p
719760dynamicHold !h = Dynamic
720761 { dynamicCurrent = behaviorHold h
721762 , dynamicUpdated = eventHold h
722763 }
723764
724−dynamicHoldIdentity :: Hold x (Identity a) -> Dynamic x (Identity a)
765+dynamicHoldIdentity :: Hold x (Identity a) -> DynamicS x (Identity a)
725766dynamicHoldIdentity = dynamicHold
726767
727−dynamicConst :: PatchTarget p -> Dynamic x p
768+dynamicConst :: PatchTarget p -> DynamicS x p
728769dynamicConst !a = Dynamic
729770 { dynamicCurrent = behaviorConst a
730771 , dynamicUpdated = eventNever
731772 }
732773
733−dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p
774+dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> DynamicS x p
734775dynamicDyn !d = Dynamic
735776 { dynamicCurrent = behaviorDyn d
736777 , dynamicUpdated = eventDyn d
737778 }
738779
739−dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a)
780+dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> DynamicS x (Identity a)
740781dynamicDynIdentity = dynamicDyn
741782
742783--------------------------------------------------------------------------------
743784-- Combinators
744785--------------------------------------------------------------------------------
745786
746−--TODO: Figure out why certain things are not 'representational', then make them
747−--representational so we can use coerce
748−
749787--type role Hold representational
750788data Hold x p
751789 = Hold { holdValue :: !(IORef (PatchTarget p))
@@ -766,20 +804,25 @@ globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv
766804
767805-- | Stores all global data relevant to a particular Spider timeline; only one
768806-- value should exist for each type @x@
769−data SpiderTimelineEnv x = SpiderTimelineEnv
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
770813 { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
771814 , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
772815#ifdef DEBUG
773816 , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
774817#endif
775818 }
776−type role SpiderTimelineEnv nominal
819+type role SpiderTimelineEnv' phantom
777820
778821instance Eq (SpiderTimelineEnv x) where
779822 _ == _ = True -- Since only one exists of each type
780823
781824instance GEq SpiderTimelineEnv where
782− a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b
825+ a `geq` b = if _spiderTimeline_lock (unSTE a) == _spiderTimeline_lock (unSTE b)
783826 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
784827 else Nothing
785828
@@ -802,7 +845,7 @@ runEventM :: EventM x a -> IO a
802845runEventM = unEventM
803846
804847asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a
805−asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
848+asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (unSTE (spiderTimeline :: SpiderTimelineEnv x))
806849
807850class MonadIO m => Defer a m where
808851 getDeferralQueue :: m (IORef [a])
@@ -940,9 +983,9 @@ getHoldEventSubscription h = do
940983
941984type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
942985
943−--type role BehaviorM representational
944986-- BehaviorM can sample behaviors
945−newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderT (BehaviorEnv x) IO a } deriving (Functor, Applicative, MonadIO, MonadFix)
987+newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderIO (BehaviorEnv x) a }
988+ deriving (Functor, Applicative, MonadIO, MonadFix, MonadReader (BehaviorEnv x))
946989
947990instance Monad (BehaviorM x) where
948991 {-# INLINE (>>=) #-}
@@ -951,8 +994,10 @@ instance Monad (BehaviorM x) where
951994 BehaviorM x >> BehaviorM y = BehaviorM $ x >> y
952995 {-# INLINE return #-}
953996 return x = BehaviorM $ return x
997+#if !MIN_VERSION_base(4,13,0)
954998 {-# INLINE fail #-}
955999 fail s = BehaviorM $ fail s
1000+#endif
9561001
9571002data BehaviorSubscribed x a
9581003 = forall p. BehaviorSubscribedHold (Hold x p)
@@ -993,7 +1038,7 @@ data RootSubscribed x a = forall k. GCompare k => RootSubscribed
9931038#endif
9941039 }
9951040
996−data Root x (k :: * -> *)
1041+data Root x k
9971042 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
9981043 , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))
9991044 , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))
@@ -1012,7 +1057,7 @@ data SomeMergeUpdate x = SomeMergeUpdate
10121057newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }
10131058
10141059-- EventM can do everything BehaviorM can, plus create holds
1015−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
1060+newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException)
10161061
10171062newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }
10181063
@@ -1037,7 +1082,8 @@ heightBagFromList :: [Height] -> HeightBag
10371082heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights
10381083
10391084heightBagAdd :: Height -> HeightBag -> HeightBag
1040−heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $ IntMap.insertWithKey (\_ _ old -> succ old) h 0 c
1085+heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $
1086+ IntMap.insertWithKey (\_ _ old -> succ old) h 0 c
10411087
10421088heightBagRemove :: Height -> HeightBag -> HeightBag
10431089heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of
@@ -1046,6 +1092,13 @@ heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.loo
10461092 0 -> IntMap.delete h c
10471093 _ -> IntMap.insert h (pred old) c
10481094
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+
10491102heightBagMax :: HeightBag -> Height
10501103heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of
10511104 Just ((h, _), _) -> Height h
@@ -1063,25 +1116,25 @@ heightBagVerify b@(HeightBag s c) = if
10631116heightBagVerify = id
10641117#endif
10651118
1066−data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren
1067− { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a))
1068− , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k)
1069− , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k)))
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)))
10701123 }
10711124
1072−data FanSubscribed (x :: *) k
1073− = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1074− , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
1075− , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty
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
10761129 , fanSubscribedParent :: !(EventSubscription x)
10771130#ifdef DEBUG_NODEIDS
10781131 , fanSubscribedNodeId :: Int
10791132#endif
10801133 }
10811134
1082−data Fan x k
1083− = Fan { fanParent :: !(Event x (DMap k Identity))
1084− , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1135+data Fan x k v
1136+ = Fan { fanParent :: !(Event x (DMap k v))
1137+ , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))
10851138 }
10861139
10871140data SwitchSubscribed x a
@@ -1143,7 +1196,8 @@ instance HasSpiderTimeline x => Align (Event x) where
11431196#if MIN_VERSION_these(0, 8, 0)
11441197instance HasSpiderTimeline x => Semialign (Event x) where
11451198#endif
1146− align ea eb = mapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
1199+ align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $
1200+ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
11471201
11481202#ifdef MIN_VERSION_semialign
11491203#if MIN_VERSION_semialign(1,1,0)
@@ -1156,13 +1210,13 @@ data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)
11561210 | BuildDyn !(EventM x (PatchTarget p), Event x p)
11571211 | HoldDyn !(Hold x p)
11581212
1159−newtype Dyn x p = Dyn { unDyn :: IORef (DynType x p) }
1213+newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }
11601214
1161−newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)
1215+newMapDyn :: HasSpiderTimeline x => (a -> b) -> DynamicS x (Identity a) -> DynamicS x (Identity b)
11621216newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
11631217
11641218--TODO: Avoid the duplication between this and R.zipDynWith
1165−zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c)
1219+zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> DynamicS x (Identity a) -> DynamicS x (Identity b) -> DynamicS x (Identity c)
11661220zipDynWith f da db =
11671221 let eab = align (dynamicUpdated da) (dynamicUpdated db)
11681222 ec = flip push eab $ \o -> do
@@ -1185,18 +1239,12 @@ buildDynamic readV0 v' = do
11851239 return d
11861240
11871241unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
1188−unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ UnsafeDyn x
1189− where x = (readV0, v')
1242+unsafeBuildDynamic readV0 v' =
1243+ Dyn $ unsafePerformIO $ newIORef $ UnsafeDyn (readV0, v')
11901244
11911245-- ResultM can read behaviors and events
11921246type ResultM = EventM
11931247
1194−{-# NOINLINE unsafeNewIORef #-}
1195−unsafeNewIORef :: a -> b -> IORef b
1196−unsafeNewIORef a b = unsafePerformIO $ do
1197− touch a
1198− newIORef b
1199−
12001248instance HasSpiderTimeline x => Functor (Event x) where
12011249 fmap f = push $ return . Just . f
12021250
@@ -1209,33 +1257,42 @@ push f e = cacheEvent (pushCheap f e)
12091257
12101258{-# INLINABLE pull #-}
12111259pull :: BehaviorM x a -> Behavior x a
1212−pull a = behaviorPull $ Pull
1213− { pullCompute = a
1214− , pullValue = unsafeNewIORef a Nothing
1260+pull a = unsafePerformIO $ do
1261+ ref <- newIORef Nothing
12151262#ifdef DEBUG_NODEIDS
1216− , pullNodeId = unsafeNodeId a
1263+ nid <- newNodeId
12171264#endif
1218− }
1265+ pure $ behaviorPull $ Pull
1266+ { pullCompute = a
1267+ , pullValue = ref
1268+#ifdef DEBUG_NODEIDS
1269+ , pullNodeId = nid
1270+#endif
1271+ }
12191272
12201273{-# INLINABLE switch #-}
12211274switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a
1222−switch a = eventSwitch $ Switch
1223− { switchParent = a
1224− , switchSubscribed = unsafeNewIORef a Nothing
1225− }
1275+switch a = unsafePerformIO $ do
1276+ ref <- newIORef Nothing
1277+ pure $ eventSwitch $ Switch
1278+ { switchParent = a
1279+ , switchSubscribed = ref
1280+ }
12261281
12271282coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a
1228−coincidence a = eventCoincidence $ Coincidence
1229− { coincidenceParent = a
1230− , coincidenceSubscribed = unsafeNewIORef a Nothing
1231− }
1283+coincidence a = unsafePerformIO $ do
1284+ ref <- newIORef Nothing
1285+ pure $ eventCoincidence $ Coincidence
1286+ { coincidenceParent = a
1287+ , coincidenceSubscribed = ref
1288+ }
12321289
12331290-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
12341291run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
12351292run roots after = do
12361293 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
12371294 let t = spiderTimeline :: SpiderTimelineEnv x
1238− result <- SpiderHost $ withMVar (_spiderTimeline_lock t) $ \_ -> unSpiderHost $ runFrame $ do
1295+ result <- SpiderHost $ withMVar (_spiderTimeline_lock (unSTE t)) $ \_ -> unSpiderHost $ runFrame $ do
12391296 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
12401297 occBefore <- liftIO $ do
12411298 occBefore <- readIORef occRef
@@ -1289,55 +1346,110 @@ mkWeakPtrWithDebug x debugNote = do
12891346 x' <- evaluate x
12901347 mkWeakPtr x' $
12911348 if debugFinalize
1292− then Just $ putStrLn $ "finalizing: " ++ debugNote
1349+ then Just $ debugStrLn $ "finalizing: " ++ debugNote
12931350 else Nothing
12941351
12951352type WeakList a = [Weak a]
12961353
1297−{-# INLINE withIncreasedDepth #-}
1354+type CanTrace x m = (HasSpiderTimeline x, MonadIO m)
1355+
1356+
1357+
1358+
12981359#ifdef DEBUG
1299−withIncreasedDepth :: CanTrace x m => m a -> m a
1300−withIncreasedDepth a = do
1301− spiderTimeline <- askSpiderTimelineEnv
1302− liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ
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+
1381+{-# 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
13031385 result <- a
1304− liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred
1386+ liftIO $ modifyIORef' (_spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)) pred
13051387 return result
1306−#else
1307−withIncreasedDepth :: m a -> m a
1308−withIncreasedDepth = id
1309−#endif
1310−
1311−type CanTrace x m = (HasSpiderTimeline x, MonadIO m)
13121388
13131389{-# INLINE tracePropagate #-}
13141390tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1315−tracePropagate p = traceWhen p debugPropagate
1391+tracePropagate p = when debugPropagate . trace p
13161392
13171393{-# INLINE traceInvalidate #-}
13181394traceInvalidate :: String -> IO ()
1319−traceInvalidate = when debugInvalidate . liftIO . putStrLn
1395+traceInvalidate = when debugInvalidate . liftIO . debugStrLn
1396+
1397+{-# INLINE traceInvalidateHeight #-}
1398+traceInvalidateHeight :: String -> IO ()
1399+traceInvalidateHeight = when debugInvalidateHeight . liftIO . debugStrLn
13201400
1321−{-# INLINE traceWhen #-}
1322−traceWhen :: (CanTrace x m) => proxy x -> Bool -> String -> m ()
1323−traceWhen p b message = traceMWhen p b $ return message
1401+{-# INLINE trace #-}
1402+trace :: (CanTrace x m) => proxy x -> String -> m ()
1403+trace p message = traceM p $ return message
13241404
1325−{-# INLINE traceMWhen #-}
1326−traceMWhen :: (CanTrace x m) => proxy x -> Bool -> m String -> m ()
1327−traceMWhen _ b getMessage = when b $ do
1405+{-# INLINE traceM #-}
1406+traceM :: forall x proxy m. (CanTrace x m) => proxy x -> m String -> m ()
1407+traceM _ getMessage = do
13281408 message <- getMessage
1329−#ifdef DEBUG
1330− spiderTimeline <- askSpiderTimelineEnv
1331− d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline
1409+ d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)
1410+ liftIO $ debugStrLn $ replicate d ' ' <> message
1411+
13321412#else
1333− let d = 0
1413+
1414+{-# INLINE withIncreasedDepth #-}
1415+withIncreasedDepth :: proxy x -> m a -> m a
1416+withIncreasedDepth _ = id
1417+
1418+{-# INLINE tracePropagate #-}
1419+tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1420+tracePropagate _ _ = return ()
1421+
1422+{-# INLINE traceInvalidate #-}
1423+traceInvalidate :: String -> IO ()
1424+traceInvalidate _ = return ()
1425+
1426+{-# INLINE traceInvalidateHeight #-}
1427+traceInvalidateHeight :: String -> IO ()
1428+traceInvalidateHeight _ = return ()
1429+
1430+{-# INLINE debugSubscriber #-}
1431+debugSubscriber :: String -> Subscriber x a -> IO (Subscriber x a)
1432+debugSubscriber _ = return
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 ()
1447+
13341448#endif
1335− liftIO $ putStrLn $ replicate d ' ' <> message
13361449
13371450whoCreatedIORef :: IORef a -> IO [String]
13381451whoCreatedIORef (IORef a) = whoCreated $! a
13391452
1340−#ifdef DEBUG_CYCLES
13411453groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
13421454groupByHead = \case
13431455 [] -> []
@@ -1348,20 +1460,54 @@ groupByHead = \case
13481460 | otherwise -> (x, xs :| []) : l
13491461
13501462listsToForest :: Eq a => [[a]] -> Forest a
1351−listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l
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+
13521495#endif
13531496
1497+
13541498{-# INLINE propagateSubscriberHold #-}
13551499propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()
13561500propagateSubscriberHold h a = do
1357− {-# SCC "trace" #-} traceMWhen (Proxy :: Proxy x) debugPropagate $ liftIO $ do
1501+ {-# SCC "trace" #-} when debugPropagate $ traceM (Proxy :: Proxy x) $ liftIO $ do
13581502 invalidators <- liftIO $ readIORef $ holdInvalidators h
13591503 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
1504+
13601505 v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h
13611506 case {-# SCC "apply" #-} apply a v of
13621507 Nothing -> return ()
13631508 Just v' -> do
1364− {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate (Proxy :: Proxy x) $ "propagateSubscriberHold: assigning Hold" <> showNodeId h
1509+ {-# SCC "trace2" #-} withIncreasedDepth (Proxy :: Proxy x) $
1510+ tracePropagate (Proxy :: Proxy x) ("propagateSubscriberHold: assigning Hold" <> showNodeId h)
13651511 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
13661512 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
13671513 defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'
@@ -1369,25 +1515,25 @@ propagateSubscriberHold h a = do
13691515data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
13701516
13711517runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a
1372−runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)
1518+runBehaviorM a mwi holdInits = runReaderIO (unBehaviorM a) (mwi, holdInits)
13731519
13741520askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
13751521askInvalidator = do
1376− (!m, _) <- BehaviorM ask
1522+ (!m, _) <- ask
13771523 case m of
13781524 Nothing -> return Nothing
13791525 Just (!wi, _) -> return $ Just wi
13801526
13811527askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
13821528askParentsRef = do
1383− (!m, _) <- BehaviorM ask
1529+ (!m, _) <- ask
13841530 case m of
13851531 Nothing -> return Nothing
13861532 Just (_, !p) -> return $ Just p
13871533
13881534askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
13891535askBehaviorHoldInits = do
1390− (_, !his) <- BehaviorM ask
1536+ (_, !his) <- ask
13911537 return his
13921538
13931539{-# INLINE getDynHold #-}
@@ -1415,7 +1561,7 @@ getDynHold d = do
14151561zeroRef :: IORef Height
14161562zeroRef = unsafePerformIO $ newIORef zeroHeight
14171563
1418−getRootSubscribed :: GCompare k => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)
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)
14191565getRootSubscribed k r sub = do
14201566 mSubscribed <- readIORef $ rootSubscribed r
14211567 let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r
@@ -1429,9 +1575,14 @@ getRootSubscribed k r sub = do
14291575 let !cached = rootSubscribed r
14301576 uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"
14311577 (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed
1432− when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"
1578+
1579+ tracePropagate (Proxy::Proxy x) $ "getRootSubscribed: calling rootInit"
1580+
14331581 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
14341582 writeIORef uninitRef $! uninit
1583+#ifdef DEBUG_NODEIDS
1584+ nid <- newNodeId
1585+#endif
14351586 let !subscribed = RootSubscribed
14361587 { rootSubscribedKey = k
14371588 , rootSubscribedCachedSubscribed = cached
@@ -1440,7 +1591,7 @@ getRootSubscribed k r sub = do
14401591 , rootSubscribedUninit = uninit
14411592 , rootSubscribedWeakSelf = weakSelf
14421593#ifdef DEBUG_NODEIDS
1443− , rootSubscribedNodeId = unsafeNodeId (k, r, subs)
1594+ , rootSubscribedNodeId = nid
14441595#endif
14451596 }
14461597 -- If we die at the same moment that all our children die, they will
@@ -1476,6 +1627,9 @@ data FanInt x a = FanInt
14761627 { _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
14771628 , _fanInt_subscriptionRef :: {-# UNPACK #-} !(IORef (EventSubscription x)) -- This should have a valid subscription iff subscribers is non-empty
14781629 , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a))
1630+#ifdef DEBUG_NODEIDS
1631+ , _fanInt_nodeId :: {-# UNPACK #-} !Int
1632+#endif
14791633 }
14801634
14811635newFanInt :: IO (FanInt x a)
@@ -1483,38 +1637,39 @@ newFanInt = do
14831637 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
14841638 subscriptionRef <- newIORef $ error "fanInt: no subscription"
14851639 occRef <- newIORef $ error "fanInt: no occurrence"
1640+#ifdef DEBUG_NODEIDS
1641+ nodeId <- newNodeId
1642+#endif
14861643 return $ FanInt
14871644 { _fanInt_subscribers = subscribers
14881645 , _fanInt_subscriptionRef = subscriptionRef
14891646 , _fanInt_occRef = occRef
1647+#ifdef DEBUG_NODEIDS
1648+ , _fanInt_nodeId = nodeId
1649+#endif
14901650 }
14911651
1492−{-# NOINLINE unsafeNewFanInt #-}
1493−unsafeNewFanInt :: b -> FanInt x a
1494−unsafeNewFanInt b = unsafePerformIO $ do
1495− touch b
1496− newFanInt
1497−
14981652fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a
1499−fanInt p =
1500− let self = unsafeNewFanInt p
1501− in EventSelectorInt $ \k -> Event $ \sub -> do
1653+fanInt p = unsafePerformIO $ do
1654+ self <- newFanInt
1655+ pure $ EventSelectorInt $ \k -> Event $ \sub -> do
15021656 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)
15031657 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input
1504− (subscription, parentOcc) <- subscribeAndRead p $ Subscriber
1658+ let desc = "fanInt" <> showNodeId self <> ", k = " <> show k
1659+ (subscription, parentOcc) <- subscribeAndRead p $ debugSubscriber' desc $ Subscriber
15051660 { subscriberPropagate = \m -> do
15061661 liftIO $ writeIORef (_fanInt_occRef self) m
15071662 scheduleIntClear $ _fanInt_occRef self
1508− FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> do --TODO: Do we need to know that no subscribers are being added as we traverse?
1509− FastWeakBag.traverse b $ \s -> do
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 ->
15101665 subscriberPropagate s v
1511− , subscriberInvalidateHeight = \old -> do
1512− FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1513− FastWeakBag.traverse b $ \s -> do
1666+ , subscriberInvalidateHeight = \old ->
1667+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->
1668+ FastWeakBag.traverse_ b $ \s ->
15141669 subscriberInvalidateHeight s old
1515− , subscriberRecalculateHeight = \new -> do
1516− FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1517− FastWeakBag.traverse b $ \s -> do
1670+ , subscriberRecalculateHeight = \new ->
1671+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->
1672+ FastWeakBag.traverse_ b $ \s ->
15181673 subscriberRecalculateHeight s new
15191674 }
15201675 liftIO $ do
@@ -1528,13 +1683,28 @@ fanInt p =
15281683 FastMutableIntMap.insert (_fanInt_subscribers self) k b
15291684 return b
15301685 Just b -> return b
1531− t <- liftIO $ FastWeakBag.insert sub b
1686+ ticket <- liftIO $ FastWeakBag.insert sub b
15321687 currentOcc <- readIORef (_fanInt_occRef self)
1533− (EventSubscription _ (EventSubscribed !heightRef _)) <- readIORef (_fanInt_subscriptionRef self)
1534− return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)
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+
15351705
15361706{-# INLINABLE getFanSubscribed #-}
1537−getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket, FanSubscribed x k, Maybe a)
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))
15381708getFanSubscribed k f sub = do
15391709 mSubscribed <- liftIO $ readIORef $ fanSubscribed f
15401710 case mSubscribed of
@@ -1552,13 +1722,16 @@ getFanSubscribed k f sub = do
15521722 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
15531723 occRef <- liftIO $ newIORef parentOcc
15541724 when (isJust parentOcc) $ scheduleClear occRef
1725+#ifdef DEBUG_NODEIDS
1726+ nid <- liftIO newNodeId
1727+#endif
15551728 let subscribed = FanSubscribed
15561729 { fanSubscribedCachedSubscribed = fanSubscribed f
15571730 , fanSubscribedOccurrence = occRef
15581731 , fanSubscribedParent = subscription
15591732 , fanSubscribedSubscribers = subscribersRef
15601733#ifdef DEBUG_NODEIDS
1561− , fanSubscribedNodeId = unsafeNodeId f
1734+ , fanSubscribedNodeId = nid
15621735#endif
15631736 }
15641737 let !self = (k, subscribed)
@@ -1568,7 +1741,7 @@ getFanSubscribed k f sub = do
15681741 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
15691742 return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)
15701743
1571−cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO ()
1744+cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k v) -> IO ()
15721745cleanupFanSubscribed (k, subscribed) = do
15731746 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
15741747 let reducedSubscribers = DMap.delete k subscribers
@@ -1580,7 +1753,7 @@ cleanupFanSubscribed (k, subscribed) = do
15801753 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
15811754
15821755{-# INLINE subscribeFanSubscribed #-}
1583−subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO WeakBagTicket
1756+subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k v -> Subscriber x (v a) -> IO WeakBagTicket
15841757subscribeFanSubscribed k subscribed sub = do
15851758 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
15861759 case DMap.lookup k subscribers of
@@ -1618,6 +1791,9 @@ getSwitchSubscribed s sub = do
16181791 when (isJust parentOcc) $ scheduleClear occRef
16191792 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
16201793 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1794+#ifdef DEBUG_NODEIDS
1795+ nid <- liftIO newNodeId
1796+#endif
16211797 let !subscribed = SwitchSubscribed
16221798 { switchSubscribedCachedSubscribed = switchSubscribed s
16231799 , switchSubscribedOccurrence = occRef
@@ -1630,7 +1806,7 @@ getSwitchSubscribed s sub = do
16301806 , switchSubscribedCurrentParent = subscriptionRef
16311807 , switchSubscribedWeakSelf = weakSelf
16321808#ifdef DEBUG_NODEIDS
1633− , switchSubscribedNodeId = unsafeNodeId s
1809+ , switchSubscribedNodeId = nid
16341810#endif
16351811 }
16361812 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
@@ -1675,6 +1851,9 @@ getCoincidenceSubscribed c sub = do
16751851 scheduleClear innerSubdRef
16761852 weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
16771853 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
1854+#ifdef DEBUG_NODEIDS
1855+ nid <- liftIO newNodeId
1856+#endif
16781857 let subscribed = CoincidenceSubscribed
16791858 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
16801859 , coincidenceSubscribedOccurrence = occRef
@@ -1685,7 +1864,7 @@ getCoincidenceSubscribed c sub = do
16851864 , coincidenceSubscribedInnerParent = innerSubdRef
16861865 , coincidenceSubscribedWeakSelf = weakSelf
16871866#ifdef DEBUG_NODEIDS
1688− , coincidenceSubscribedNodeId = unsafeNodeId c
1867+ , coincidenceSubscribedNodeId = nid
16891868#endif
16901869 }
16911870 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
@@ -1702,57 +1881,72 @@ cleanupCoincidenceSubscribed subscribed = do
17021881subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket
17031882subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
17041883
1705−{-# INLINE merge #-}
1706−merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1707−merge d = cacheEvent (mergeCheap d)
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)
17081889
17091890{-# INLINE mergeWithMove #-}
1710−mergeWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1711−mergeWithMove d = cacheEvent (mergeCheapWithMove d)
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)
17121895
17131896{-# INLINE [1] mergeCheap #-}
1714−mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1715−mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy
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
17161903 where
1717− updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)
1904+ updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)
17181905 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
17191906 let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do
17201907 (mOldSubd, newPs) <- case me of
17211908 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
17221909 Just e -> do
17231910 let s = subscriber $ return k
1724− subscription@(EventSubscription _ subd) <- subscribe e s
1911+ subscription@(EventSubscription _ subd) <- subscribe (nt e) s
17251912 newParentHeight <- liftIO $ getEventSubscribedHeight subd
17261913 let newParent = MergeSubscribedParent subscription
17271914 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
17281915 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
17291916 forM_ mOldSubd $ \oldSubd -> do
1730− oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd
1917+ oldHeight <- liftIO $ getEventSubscribedHeight $
1918+ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd
1919+
17311920 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
17321921 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
17331922 foldM f ([], oldParents) $ DMap.toList p
1734− getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParent x)
1923+
1924+ getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParent x)
17351925 getInitialSubscribers initialParents subscriber = do
17361926 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
17371927 let s = subscriber $ return k
1738− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1928+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s
17391929 height <- liftIO $ getEventSubscribedHeight parentSubd
1740− return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription)
1930+ return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParent subscription)
17411931 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
17421932 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
17431933 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
17441934 )
1935+
17451936 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)
17461937 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub
17471938
17481939{-# INLINE [1] mergeCheapWithMove #-}
1749−mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1750−mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
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
17511945 where
1752− updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)
1946+ updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)
17531947 updateMe subscriber heightBagRef oldParents p = do
17541948 -- Prepare new parents for insertion
1755− let subscribeParent :: forall a. k a -> Event x a -> EventM x (MergeSubscribedParentWithMove x k a)
1949+ let subscribeParent :: forall a. k a -> Event x (v a) -> EventM x (MergeSubscribedParentWithMove x k a)
17561950 subscribeParent k e = do
17571951 keyRef <- liftIO $ newIORef k
17581952 let s = subscriber $ liftIO $ readIORef keyRef
@@ -1761,73 +1955,82 @@ mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
17611955 newParentHeight <- getEventSubscribedHeight subd
17621956 modifyIORef' heightBagRef $ heightBagAdd newParentHeight
17631957 return $ MergeSubscribedParentWithMove subscription keyRef
1764− p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey subscribeParent p
1958+ p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey (\k q -> subscribeParent k (nt q)) p
17651959 -- Collect old parents for deletion and update the keys of moved parents
1766− let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Event x) a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
1960+ let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
17671961 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
17681962 Nothing -> do
1769− oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent
1963+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $
1964+ _mergeSubscribedParentWithMove_subscription parent
1965+
17701966 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
17711967 return $ Just $ _mergeSubscribedParentWithMove_subscription parent
17721968 Just toKey -> do
17731969 liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey
17741970 return Nothing
1775− toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
1971+ toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $
1972+ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
1973+
17761974 return (toDelete, applyAlways p' oldParents)
1777− getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k)
1975+ getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)
17781976 getInitialSubscribers initialParents subscriber = do
17791977 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
17801978 keyRef <- liftIO $ newIORef k
17811979 let s = subscriber $ liftIO $ readIORef keyRef
1782− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1980+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s
17831981 height <- liftIO $ getEventSubscribedHeight parentSubd
1784− return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
1982+ return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
17851983 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
17861984 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
17871985 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
17881986 )
1987+
17891988 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)
17901989 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub
17911990
1792−type MergeUpdateFunc k x p s
1793− = (forall a. EventM x (k a) -> Subscriber x a)
1991+type MergeUpdateFunc k v x p s
1992+ = (forall a. EventM x (k a) -> Subscriber x (v a))
17941993 -> IORef HeightBag
17951994 -> DMap k s
17961995 -> p
17971996 -> EventM x ([EventSubscription x], DMap k s)
17981997
1799−type MergeInitFunc k x s
1800− = DMap k (Event x)
1801− -> (forall a. EventM x (k a) -> Subscriber x a)
1802− -> EventM x (DMap k Identity, [Height], DMap k s)
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)
18032004
18042005type MergeDestroyFunc k s
18052006 = DMap k s
18062007 -> IO ()
18072008
1808−data Merge x k s = Merge
2009+data Merge x k v s = Merge
18092010 { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))
18102011 , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)
18112012 , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)
1812− , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k Identity))
1813− , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k Identity))
2013+ , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k v))
2014+ , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k v))
18142015 }
18152016
1816−invalidateMergeHeight :: Merge x k s -> IO ()
2017+invalidateMergeHeight :: Merge x k v s -> IO ()
18172018invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)
18182019
18192020invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
18202021invalidateMergeHeight' heightRef sub = do
18212022 oldHeight <- readIORef heightRef
1822− 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
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
18232025 writeIORef heightRef $! invalidHeight
18242026 subscriberInvalidateHeight sub oldHeight
18252027
1826−
1827−revalidateMergeHeight :: Merge x k s -> IO ()
2028+revalidateMergeHeight :: Merge x k v s -> IO ()
18282029revalidateMergeHeight m = do
18292030 currentHeight <- readIORef $ _merge_heightRef m
1830− when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
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
18312034 heights <- readIORef $ _merge_heightBagRef m
18322035 parents <- readIORef $ _merge_parentsRef m
18332036 -- When the number of heights in the bag reaches the number of parents, we should have a valid height
@@ -1835,44 +2038,53 @@ revalidateMergeHeight m = do
18352038 LT -> return ()
18362039 EQ -> do
18372040 let height = succHeight $ heightBagMax heights
1838− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
2041+ traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height
18392042 writeIORef (_merge_heightRef m) $! height
18402043 subscriberRecalculateHeight (_merge_sub m) height
18412044 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
18422045
1843−scheduleMergeSelf :: HasSpiderTimeline x => Merge x k s -> Height -> EventM x ()
2046+scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()
18442047scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
18452048 vals <- liftIO $ readIORef $ _merge_accumRef m
1846− 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
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
18472052 --TODO: Assert that m is not empty
18482053 subscriberPropagate (_merge_sub m) vals
18492054
1850−mergeSubscriber :: forall x k s a. (HasSpiderTimeline x, GCompare k) => Merge x k s -> EventM x (k a) -> Subscriber x a
1851−mergeSubscriber m getKey = Subscriber
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
18522078 { subscriberPropagate = \a -> do
18532079 oldM <- liftIO $ readIORef $ _merge_accumRef m
18542080 k <- getKey
1855− let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM
2081+ let newM = DMap.insertWith (error "Same key fired multiple times for Merge") k a oldM
18562082 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
18572083 liftIO $ writeIORef (_merge_accumRef m) $! newM
18582084 when (DMap.null oldM) $ do -- Only schedule the firing once
18592085 height <- liftIO $ readIORef $ _merge_heightRef m
1860− --TODO: assertions about height
1861− currentHeight <- getCurrentHeight
1862− when (height <= currentHeight) $ do
1863− if height /= invalidHeight
1864− then do
1865− myStack <- liftIO $ whoCreatedIORef undefined --TODO
1866− error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
1867− else liftIO $ do
1868−#ifdef DEBUG_CYCLES
1869− nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
1870− stacks <- forM nodesInvolvedInCycle $ \(Some es) -> whoCreatedEventSubscribed es
1871− let cycleInfo = ":\n" <> drawForest (listsToForest stacks)
1872−#else
1873− let cycleInfo = ""
1874−#endif
1875− error $ "Causality loop found" <> cycleInfo
2086+ checkCycle subscribed
2087+
18762088 scheduleMergeSelf m height
18772089 , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating
18782090 modifyIORef' (_merge_heightBagRef m) $ heightBagRemove old
@@ -1883,30 +2095,45 @@ mergeSubscriber m getKey = Subscriber
18832095 }
18842096
18852097--TODO: Be able to run as much of this as possible promptly
1886−updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k s -> MergeUpdateFunc k x p s -> p -> SomeMergeUpdate x
1887−updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)
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)
18882100 where updateMe = do
18892101 oldParents <- liftIO $ readIORef $ _merge_parentsRef m
1890− (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber m) (_merge_heightBagRef m) oldParents p
2102+ (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber subscribed m) (_merge_heightBagRef m) oldParents p
18912103 liftIO $ writeIORef (_merge_parentsRef m) $! newParents
18922104 return subscriptionsToKill
18932105
1894−{-# INLINE mergeCheap' #-}
1895−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)
1896−mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
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
18972110 initialParents <- readBehaviorUntracked $ dynamicCurrent d
18982111 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
18992112 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
19002113 heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"
19012114 parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"
1902− let m = Merge
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
19032130 { _merge_parentsRef = parentsRef
19042131 , _merge_heightBagRef = heightBagRef
19052132 , _merge_heightRef = heightRef
19062133 , _merge_sub = sub
19072134 , _merge_accumRef = accumRef
19082135 }
1909− (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber m
2136+ (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber subscribed m
19102137 let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights
19112138 myHeight = if invalidHeight `elem` heights
19122139 then invalidHeight
@@ -1915,50 +2142,57 @@ mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
19152142 let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now
19162143 then (if DMap.null dm then Nothing else Just dm, DMap.empty)
19172144 else (Nothing, dm)
1918− unless (DMap.null accum) $ do
1919− scheduleMergeSelf m myHeight
2145+ unless (DMap.null accum) $ scheduleMergeSelf m myHeight
19202146 liftIO $ writeIORef accumRef $! accum
19212147 liftIO $ writeIORef heightRef $! myHeight
19222148 liftIO $ writeIORef heightBagRef $! myHeightBag
1923− changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
19242149 liftIO $ writeIORef parentsRef $! initialParentState
19252150 defer $ SomeMergeInit $ do
1926− let s = Subscriber
2151+ let changeSubscriber = Subscriber
19272152 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
1928− tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change"
1929− defer $ updateMerge m updateFunc a
2153+ tracePropagate (Proxy :: Proxy x) "SubscriberMerge/Change"
2154+ defer $ updateMerge subscribed m updateFunc a
19302155 , subscriberInvalidateHeight = \_ -> return ()
19312156 , subscriberRecalculateHeight = \_ -> return ()
19322157 }
1933− (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s
1934− forM_ change $ \c -> defer $ updateMerge m updateFunc c
2158+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) changeSubscriber
2159+ forM_ change $ \c -> defer $ updateMerge subscribed m updateFunc c
19352160 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
19362161 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
19372162 -- its subscription.
1938− liftIO $ writeIORef changeSubdRef (s, changeSubscription)
2163+ liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)
19392164 let unsubscribeAll = destroy =<< readIORef parentsRef
1940− return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parentsRef, changeSubdRef)
1941− , occ
1942− )
19432165
1944−mergeInt :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)
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)
19452170mergeInt = cacheEvent . mergeIntCheap
19462171
19472172{-# INLINABLE mergeIntCheap #-}
1948−mergeIntCheap :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)
2173+mergeIntCheap :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)
19492174mergeIntCheap d = Event $ \sub -> do
19502175 initialParents <- readBehaviorUntracked $ dynamicCurrent d
19512176 accum <- liftIO $ FastMutableIntMap.newEmpty
19522177 heightRef <- liftIO $ newIORef zeroHeight
19532178 heightBagRef <- liftIO $ newIORef heightBagEmpty
19542179 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+ }
19552190 let scheduleSelf = do
19562191 height <- liftIO $ readIORef $ heightRef
19572192 scheduleMerge' height heightRef $ do
19582193 vals <- liftIO $ FastMutableIntMap.getFrozenAndClear accum
19592194 subscriberPropagate sub vals
1960− invalidateMyHeight = do
1961− invalidateMergeHeight' heightRef sub
2195+ invalidateMyHeight = invalidateMergeHeight' heightRef sub
19622196 recalculateMyHeight = do
19632197 currentHeight <- readIORef heightRef
19642198 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?
@@ -1968,12 +2202,14 @@ mergeIntCheap d = Event $ \sub -> do
19682202 LT -> return ()
19692203 EQ -> do
19702204 let height = succHeight $ heightBagMax heights
1971− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
2205+ traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height
19722206 writeIORef heightRef $! height
19732207 subscriberRecalculateHeight sub height
19742208 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"
19752209 mySubscriber k = Subscriber
19762210 { subscriberPropagate = \a -> do
2211+ checkCycle subscribed
2212+
19772213 wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum
19782214 liftIO $ FastMutableIntMap.insert accum k a
19792215 when wasEmpty scheduleSelf
@@ -2007,7 +2243,6 @@ mergeIntCheap d = Event $ \sub -> do
20072243 else liftIO $ Just <$> FastMutableIntMap.getFrozenAndClear accum
20082244 else do when (not isEmpty) scheduleSelf -- We have things accumulated, but we shouldn't have fired them yet
20092245 return Nothing
2010− changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
20112246 defer $ SomeMergeInit $ do
20122247 let updateMe a = SomeMergeUpdate u invalidateMyHeight recalculateMyHeight
20132248 where
@@ -2021,35 +2256,39 @@ mergeIntCheap d = Event $ \sub -> do
20212256 oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions
20222257 liftIO $ for_ oldParents $ \oldParent -> do
20232258 oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent
2259+
2260+ print ("updateMe", oldParentHeight)
20242261 modifyIORef' heightBagRef $ heightBagRemove oldParentHeight
20252262 return $ IntMap.elems oldParents
2026− let s = Subscriber
2263+ let changeSubscriber = Subscriber
20272264 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
20282265 tracePropagate (Proxy :: Proxy x) $ "SubscriberMergeInt/Change"
20292266 defer $ updateMe a
20302267 , subscriberInvalidateHeight = \_ -> return ()
20312268 , subscriberRecalculateHeight = \_ -> return ()
20322269 }
2033− (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s
2270+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) changeSubscriber
20342271 forM_ change $ \c -> defer $ updateMe c
20352272 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
20362273 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
20372274 -- its subscription.
2038− liftIO $ writeIORef changeSubdRef (s, changeSubscription)
2275+ liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)
20392276 let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents
2040− return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parents, changeSubdRef)
2041− , occ
2042− )
2277+
2278+
2279+ return (EventSubscription unsubscribeAll subscribed, occ)
20432280
20442281newtype 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) }
20452283
2046−fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k
2047−fan e =
2284+fanG :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k v) -> EventSelectorG x k v
2285+fanG e = unsafePerformIO $ do
2286+ ref <- newIORef Nothing
20482287 let f = Fan
20492288 { fanParent = e
2050− , fanSubscribed = unsafeNewIORef e Nothing
2289+ , fanSubscribed = ref
20512290 }
2052− in EventSelector $ \k -> eventFan k f
2291+ pure $ EventSelectorG $ \k -> eventFan k f
20532292
20542293runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()
20552294runHoldInits holdInitRef dynInitRef mergeInitRef = do
@@ -2103,7 +2342,7 @@ clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeI
21032342-- | Run an event action outside of a frame
21042343runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
21052344runFrame a = SpiderHost $ do
2106− let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
2345+ let env = _spiderTimeline_eventEnv $ unSTE (spiderTimeline :: SpiderTimelineEnv x)
21072346 let go = do
21082347 result <- a
21092348 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
@@ -2120,19 +2359,19 @@ runFrame a = SpiderHost $ do
21202359 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env
21212360 forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do
21222361 writeIORef vRef v
2123− when debugInvalidate $ putStrLn $ "Invalidating Hold"
2362+ traceInvalidate $ "Invalidating Hold"
21242363 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef
21252364 mergeUpdates <- readIORef $ eventEnvMergeUpdates env
21262365 writeIORef (eventEnvMergeUpdates env) []
2127− when debugPropagate $ putStrLn "Updating merges"
2366+ tracePropagate (Proxy::Proxy x) $ "Updating merges"
21282367 mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates
2129− when debugPropagate $ putStrLn "Updating merges done"
2368+ tracePropagate (Proxy::Proxy x) $ "Updating merges done"
21302369 toReconnect <- readIORef toReconnectRef
21312370 clearEventEnv env
21322371 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
21332372 oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed
21342373 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed
2135− when debugInvalidate $ putStrLn $ "Finalizing invalidator for Switch" <> showNodeId subscribed
2374+ traceInvalidate $ "Finalizing invalidator for Switch" <> showNodeId subscribed
21362375 finalize wi
21372376 i <- evaluate $ switchSubscribedOwnInvalidator subscribed
21382377 wi' <- mkWeakPtrWithDebug i "wi'"
@@ -2146,7 +2385,7 @@ runFrame a = SpiderHost $ do
21462385 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
21472386 {-
21482387 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
2149− liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
2388+ liftIO $ debugStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
21502389 EventRoot _ -> "EventRoot"
21512390 EventNever -> "EventNever"
21522391 _ -> "something else"
@@ -2161,7 +2400,7 @@ runFrame a = SpiderHost $ do
21612400 myHeight <- readIORef $ switchSubscribedHeight subscribed
21622401 when (parentHeight /= myHeight) $ do
21632402 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
2164− WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight
2403+ WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight
21652404 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
21662405 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
21672406 unsubscribe subscription
@@ -2202,7 +2441,7 @@ invalidateCoincidenceHeight subscribed = do
22022441 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
22032442 when (oldHeight /= invalidHeight) $ do
22042443 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight
2205− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
2444+ WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
22062445
22072446updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()
22082447updateSwitchHeight new subscribed = do
@@ -2210,7 +2449,7 @@ updateSwitchHeight new subscribed = do
22102449 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
22112450 when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion
22122451 writeIORef (switchSubscribedHeight subscribed) $! new
2213− WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new
2452+ WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new
22142453
22152454recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
22162455recalculateCoincidenceHeight subscribed = do
@@ -2219,7 +2458,7 @@ recalculateCoincidenceHeight subscribed = do
22192458 height <- calculateCoincidenceHeight subscribed
22202459 when (height /= invalidHeight) $ do
22212460 writeIORef (coincidenceSubscribedHeight subscribed) $! height
2222− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
2461+ WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
22232462
22242463calculateSwitchHeight :: SwitchSubscribed x a -> IO Height
22252464calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)
@@ -2281,6 +2520,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Event
22812520 {-# INLINABLE headE #-}
22822521 headE = R.slowHeadE
22832522-- headE (SpiderEvent e) = SpiderEvent <$> Reflex.Spider.Internal.headE e
2523+ {-# INLINABLE now #-}
2524+ now = nowSpiderEventM
22842525
22852526instance Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where
22862527 {-# INLINABLE sample #-}
@@ -2302,6 +2543,9 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide
23022543 {-# INLINABLE headE #-}
23032544 headE = R.slowHeadE
23042545-- headE (SpiderEvent e) = SpiderPushM $ SpiderEvent <$> Reflex.Spider.Internal.headE e
2546+ {-# INLINABLE now #-}
2547+ now = SpiderPushM nowSpiderEventM
2548+
23052549
23062550instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where
23072551 {-# INLINE return #-}
@@ -2310,11 +2554,13 @@ instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x))
23102554 x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x
23112555 {-# INLINE (>>) #-}
23122556 (>>) = (*>)
2557+#if !MIN_VERSION_base(4,13,0)
23132558 {-# INLINE fail #-}
23142559 fail _ = error "Dynamic does not support 'fail'"
2560+#endif
23152561
23162562{-# INLINABLE newJoinDyn #-}
2317−newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)
2563+newJoinDyn :: HasSpiderTimeline x => DynamicS x (Identity (DynamicS x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)
23182564newJoinDyn d =
23192565 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)
23202566 eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d
@@ -2363,6 +2609,9 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide
23632609 buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e
23642610 {-# INLINABLE headE #-}
23652611 headE e = runFrame . runSpiderHostFrame $ Reflex.Class.headE e
2612+ {-# INLINABLE now #-}
2613+ now = runFrame . runSpiderHostFrame $ Reflex.Class.now
2614+
23662615
23672616instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where
23682617 sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can
@@ -2379,6 +2628,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide
23792628 {-# INLINABLE headE #-}
23802629 headE = R.slowHeadE
23812630-- headE (SpiderEvent e) = SpiderHostFrame $ SpiderEvent <$> Reflex.Spider.Internal.headE e
2631+ {-# INLINABLE now #-}
2632+ now = SpiderHostFrame Reflex.Class.now
23822633
23832634instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where
23842635 {-# INLINABLE sample #-}
@@ -2399,6 +2650,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Refle
23992650 buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e
24002651 {-# INLINABLE headE #-}
24012652 headE e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.headE e
2653+ {-# INLINABLE now #-}
2654+ now = Reflex.Spider.Internal.ReadPhase Reflex.Class.now
24022655
24032656--------------------------------------------------------------------------------
24042657-- Deprecated items
@@ -2436,13 +2689,13 @@ instance HasSpiderTimeline x => Reflex.Host.Class.MonadReadEvent (SpiderTimeline
24362689 touch h
24372690 return result
24382691
2439−instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where
2692+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where
24402693 newEventWithTrigger = SpiderHost . fmap SpiderEvent . newEventWithTriggerIO
24412694 newFanEventWithTrigger f = SpiderHost $ do
24422695 es <- newFanEventWithTriggerIO f
24432696 return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es
24442697
2445−instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where
2698+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where
24462699 newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO
24472700 newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do
24482701 es <- newFanEventWithTriggerIO f
@@ -2464,7 +2717,7 @@ unsafeNewSpiderTimelineEnv = do
24642717#ifdef DEBUG
24652718 depthRef <- newIORef 0
24662719#endif
2467− return $ SpiderTimelineEnv
2720+ return $ STE $ SpiderTimelineEnv
24682721 { _spiderTimeline_lock = lock
24692722 , _spiderTimeline_eventEnv = env
24702723#ifdef DEBUG
@@ -2476,17 +2729,17 @@ unsafeNewSpiderTimelineEnv = do
24762729newSpiderTimeline :: IO (Some SpiderTimelineEnv)
24772730newSpiderTimeline = withSpiderTimeline (pure . Some)
24782731
2479−data LocalSpiderTimeline x s
2732+data LocalSpiderTimeline (x :: Type) s
24802733
24812734instance Reifies s (SpiderTimelineEnv x) =>
24822735 HasSpiderTimeline (LocalSpiderTimeline x s) where
2483− spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s)
2736+ spiderTimeline = localSpiderTimeline Proxy $ reflect (Proxy :: Proxy s)
24842737
24852738localSpiderTimeline
2486− :: Proxy s
2739+ :: proxy s
24872740 -> SpiderTimelineEnv x
24882741 -> SpiderTimelineEnv (LocalSpiderTimeline x s)
2489−localSpiderTimeline _ = unsafeCoerce
2742+localSpiderTimeline _ = coerce
24902743
24912744-- | Pass a new timeline to the given function.
24922745withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r
@@ -2494,18 +2747,18 @@ withSpiderTimeline k = do
24942747 env <- unsafeNewSpiderTimelineEnv
24952748 reify env $ \s -> k $ localSpiderTimeline s env
24962749
2497−newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2750+newtype SpiderPullM (x :: Type) a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
24982751
24992752type ComputeM = EventM
25002753
2501−newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2754+newtype SpiderPushM (x :: Type) a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
25022755
25032756instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
25042757 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
25052758 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
25062759 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }
2507− newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad)
2508− newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }
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 }
25092762 type PullM (SpiderTimeline x) = SpiderPullM x
25102763 type PushM (SpiderTimeline x) = SpiderPushM x
25112764 {-# INLINABLE never #-}
@@ -2518,10 +2771,15 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
25182771 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
25192772 {-# INLINABLE pull #-}
25202773 pull = SpiderBehavior . pull . coerce
2521− {-# INLINABLE merge #-}
2522− merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x))
2523− {-# INLINABLE fan #-}
2524− fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
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
25252783 {-# INLINABLE switch #-}
25262784 switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior
25272785 {-# INLINABLE coincidence #-}
@@ -2529,15 +2787,15 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
25292787 {-# INLINABLE current #-}
25302788 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
25312789 {-# INLINABLE updated #-}
2532− updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic
2790+ updated = SpiderEvent #. dynamicUpdated .# fmap coerce . unSpiderDynamic
25332791 {-# INLINABLE unsafeBuildDynamic #-}
25342792 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
25352793 {-# INLINABLE unsafeBuildIncremental #-}
25362794 unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv
2537− {-# INLINABLE mergeIncremental #-}
2538− mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental
2539− {-# INLINABLE mergeIncrementalWithMove #-}
2540− mergeIncrementalWithMove = SpiderEvent . mergeWithMove . (unsafeCoerce :: Dynamic x (PatchDMapWithMove k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMapWithMove k (Event x))) . unSpiderIncremental
2795+ {-# INLINABLE mergeIncrementalG #-}
2796+ mergeIncrementalG nt = SpiderEvent #. mergeG (coerce #. nt) .# unSpiderIncremental
2797+ {-# INLINABLE mergeIncrementalWithMoveG #-}
2798+ mergeIncrementalWithMoveG nt = SpiderEvent #. mergeWithMove (coerce #. nt) .# unSpiderIncremental
25412799 {-# INLINABLE currentIncremental #-}
25422800 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
25432801 {-# INLINABLE updatedIncremental #-}
@@ -2548,9 +2806,10 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
25482806 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'
25492807 eventCoercion Coercion = Coercion
25502808 behaviorCoercion Coercion = Coercion
2551− dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance
2809+ dynamicCoercion Coercion = Coercion
2810+ incrementalCoercion Coercion Coercion = Coercion
25522811 {-# INLINABLE mergeIntIncremental #-}
2553− mergeIntIncremental = SpiderEvent . mergeInt . (unsafeCoerce :: Dynamic x (PatchIntMap (R.Event (SpiderTimeline x) a)) -> Dynamic x (PatchIntMap (Event x a))) . unSpiderIncremental
2812+ mergeIntIncremental = SpiderEvent . mergeInt . coerce
25542813 {-# INLINABLE fanInt #-}
25552814 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))
25562815
@@ -2575,7 +2834,7 @@ instance MonadAtomicRef (EventM x) where
25752834 atomicModifyRef r f = liftIO $ atomicModifyRef r f
25762835
25772836-- | The monad for actions that manipulate a Spider timeline identified by @x@
2578−newtype SpiderHost x a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2837+newtype SpiderHost (x :: Type) a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
25792838
25802839instance Monad (SpiderHost x) where
25812840 {-# INLINABLE (>>=) #-}
@@ -2584,8 +2843,14 @@ instance Monad (SpiderHost x) where
25842843 SpiderHost x >> SpiderHost y = SpiderHost $ x >> y
25852844 {-# INLINABLE return #-}
25862845 return x = SpiderHost $ return x
2846+#if !MIN_VERSION_base(4,13,0)
25872847 {-# INLINABLE fail #-}
2588− fail s = SpiderHost $ fail s
2848+ fail = MonadFail.fail
2849+#endif
2850+
2851+instance MonadFail (SpiderHost x) where
2852+ {-# INLINABLE fail #-}
2853+ fail s = SpiderHost $ MonadFail.fail s
25892854
25902855-- | Run an action affecting the global Spider timeline; this will be guarded by
25912856-- a mutex for that timeline
@@ -2597,7 +2862,7 @@ runSpiderHost (SpiderHost a) = a
25972862runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
25982863runSpiderHostForTimeline (SpiderHost a) _ = a
25992864
2600−newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }
2865+newtype SpiderHostFrame (x :: Type) a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }
26012866 deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
26022867
26032868instance Monad (SpiderHostFrame x) where
@@ -2607,19 +2872,21 @@ instance Monad (SpiderHostFrame x) where
26072872 SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y
26082873 {-# INLINABLE return #-}
26092874 return x = SpiderHostFrame $ return x
2875+#if !MIN_VERSION_base(4,13,0)
26102876 {-# INLINABLE fail #-}
26112877 fail s = SpiderHostFrame $ fail s
2878+#endif
26122879
26132880instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where
26142881 notReadyUntil _ = pure ()
26152882 notReady = pure ()
26162883
2617−newEventWithTriggerIO :: (RootTrigger x a -> IO (IO ())) -> IO (Event x a)
2884+newEventWithTriggerIO :: forall x a. HasSpiderTimeline x => (RootTrigger x a -> IO (IO ())) -> IO (Event x a)
26182885newEventWithTriggerIO f = do
26192886 es <- newFanEventWithTriggerIO $ \Refl -> f
26202887 return $ select es Refl
26212888
2622−newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)
2889+newFanEventWithTriggerIO :: (HasSpiderTimeline x, GCompare k) => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)
26232890newFanEventWithTriggerIO f = do
26242891 occRef <- newIORef DMap.empty
26252892 subscribedRef <- newIORef DMap.empty
@@ -2653,3 +2920,11 @@ instance MonadAtomicRef (SpiderHostFrame x) where
26532920instance PrimMonad (SpiderHostFrame x) where
26542921 type PrimState (SpiderHostFrame x) = PrimState IO
26552922 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,6 +122,8 @@ 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
125127
126128instance Adjustable t m => Adjustable t (TriggerEventT t m) where
127129 {-# INLINABLE runWithReplace #-}
src/Reflex/TriggerEvent/Class.hs+6
@@ -12,6 +12,7 @@ import Reflex.Class
1212import Control.Monad.Reader
1313import Control.Monad.State
1414import qualified Control.Monad.State.Strict as Strict
15+import Control.Monad.Trans.Maybe (MaybeT)
1516
1617--TODO: Shouldn't have IO hard-coded
1718-- | 'TriggerEvent' represents actions that can create 'Event's that can be
@@ -47,3 +48,8 @@ instance TriggerEvent t m => TriggerEvent t (Strict.StateT s m) where
4748 newTriggerEvent = lift newTriggerEvent
4849 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
4950 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 Reflex.Patch.MapWithMove
16+import Data.Patch.MapWithMove
1717
1818
1919-- | Build sortable content in such a way that re-sorting it can cause minimal
src/Reflex/Workflow.hs+1−1
@@ -34,7 +34,7 @@ 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 whenever the current 'Workflow' is replaced by the next 'Workflow'.
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'.
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
test/Adjustable.hsnew file+62
@@ -0,0 +1,62 @@
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.hsnew file+171
@@ -0,0 +1,171 @@
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/GC.hs+6−5
@@ -18,15 +18,17 @@ import Data.GADT.Compare
1818import Data.IORef
1919import Data.Semigroup
2020import Data.These
21+import Data.Type.Equality ((:~:)(Refl))
2122
2223import Data.Functor.Misc
23−import Reflex.Patch
24+import Data.Patch
2425
2526import qualified Reflex.Host.Class as Host
2627import qualified Reflex.Spider.Internal as S
2728
2829import System.Exit
2930import System.Mem
31+import Data.Coerce
3032
3133main :: IO ()
3234main = do
@@ -46,7 +48,7 @@ hostPerf ref = S.runSpiderHost $ do
4648 eventToPerform <- Host.runHostFrame $ do
4749 (reqMap :: S.Event S.Global (DMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) Identity))
4850 <- S.SpiderHostFrame
49− $ fmap ( S.merge
51+ $ fmap ( S.mergeG coerce
5052 . S.dynamicHold)
5153 $ S.hold DMap.empty
5254 -- Construct a new heap object for the subscriber, invalidating any weak references to the subscriber if they are not retained
@@ -55,8 +57,8 @@ hostPerf ref = S.runSpiderHost $ do
5557 { S.subscriberPropagate = S.subscriberPropagate sub
5658 }
5759 return (s, o))
58− $ runIdentity <$> S.select
59− (S.fan $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response)
60+ $ runIdentity . runIdentity <$> S.selectG
61+ (S.fanG $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response)
6062 (WrapArg Request)
6163 return $ alignWith (mergeThese (<>))
6264 (flip S.pushCheap eadd $ \_ -> return $ Just $ DMap.singleton Request $ do
@@ -82,7 +84,6 @@ hostPerf ref = S.runSpiderHost $ do
8284 Nothing -> []
8385 Host.fireEventsAndRead followupEventTriggers $ return ()
8486 return ()
85− return ()
8687
8788data Tell a where
8889 Action :: Tell ()
test/Headless.hsnew file+10
@@ -0,0 +1,10 @@
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−1
@@ -24,7 +24,7 @@ import Data.These.Lens
2424#endif
2525
2626import Reflex
27−import Reflex.Patch.MapWithMove
27+import Data.Patch.MapWithMove
2828import Test.Run
2929
3030newtype MyQuery = MyQuery SelectedCount
test/Reflex/Bench/Focused.hs+12
@@ -130,6 +130,16 @@ 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+
133143combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
134144combineDynChain = iterM (\d -> return $ zipDynWith (+) d d)
135145
@@ -308,6 +318,8 @@ dynamics :: Word -> [(String, TestCase)]
308318dynamics n =
309319 [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d
310320 , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d
321+ , testE "holdDynChain" $ fmap updated $ holdDynChain n =<< d
322+ , testE "buildDynChain" $ fmap updated $ buildDynChain n =<< d
311323 , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d
312324 , testE "dense mergeTree" $ fmap (updated . mergeTreeDyn 8) dense
313325 , testE "sparse mergeTree" $ fmap (updated . mergeTreeDyn 8) sparse
test/Reflex/Plan/Pure.hs+1
@@ -41,6 +41,7 @@ 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
4445
4546instance MonadSample (Pure Int) PurePlan where
4647 sample = liftPlan . sample
test/Reflex/Test/CrossImpl.hs+13−8
@@ -21,11 +21,12 @@ 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
2425
2526import Control.Arrow (second, (&&&))
2627import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
2728import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
28−import Data.Dependent.Map (DSum (..))
29+import Data.Dependent.Sum (DSum (..))
2930import Data.Foldable
3031import Data.Map.Strict (Map)
3132import qualified Data.Map.Strict as Map
@@ -35,8 +36,6 @@ import Data.Traversable
3536import System.Exit
3637import System.Mem
3738
38−import System.IO.Unsafe
39−
4039mapToPureBehavior :: Map Int a -> Behavior PureReflexDomain a
4140mapToPureBehavior m = P.Behavior $ \t -> case Map.lookupLE t m of
4241 Nothing -> error $ "mapToPureBehavior: no value for time " <> show t
@@ -73,11 +72,14 @@ instance MapMSignals (Event t a) (Event t' a) t t' where
7372instance (MapMSignals a a' t t', MapMSignals b b' t t') => MapMSignals (a, b) (a', b') t t' where
7473 mapMSignals fb fe (a, b) = liftM2 (,) (mapMSignals fb fe a) (mapMSignals fb fe b)
7574
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
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
7880 (re, reTrigger) <- newEventWithTriggerRef
7981 (rb, rbTrigger) <- newEventWithTriggerRef
80− b <- runHostFrame $ hold (error "testSpider: No value for input behavior yet") rb
82+ b <- runHostFrame $ hold (error "testTimeline: No value for input behavior yet") rb
8183 (b', e') <- runHostFrame $ builder (b, re)
8284 e'Handle <- subscribeEvent e' --TODO: This should be unnecessary
8385 let times = relevantTestingTimes (bMap, eMap)
@@ -102,9 +104,11 @@ testAgreement :: (Eq c, Eq d, Show c, Show d) => (forall m t. TestCaseConstraint
102104testAgreement builder inputs = do
103105 let identityResult = testPure builder inputs
104106 tracePerf "---------" $ return ()
105− let spiderResult = testSpider builder inputs
107+ spiderResult <- S.runSpiderHost $ testTimeline builder inputs
108+ tracePerf "---------" $ return ()
109+ profiledResult <- S.runSpiderHost $ Prof.runProfiledM $ testTimeline builder inputs
106110 tracePerf "---------" $ return ()
107− let resultsAgree = identityResult == spiderResult
111+ let resultsAgree = identityResult == spiderResult && identityResult == profiledResult
108112 if resultsAgree
109113 then do --putStrLn "Success:"
110114 --print identityResult
@@ -112,6 +116,7 @@ testAgreement builder inputs = do
112116 else do putStrLn "Failure:"
113117 putStrLn $ "Pure result: " <> show identityResult
114118 putStrLn $ "Spider result: " <> show spiderResult
119+ putStrLn $ "Profiled result: " <> show profiledResult
115120 return resultsAgree
116121
117122type TestCaseConstraint t m = (Reflex t, MonadSample t m, MonadHold t m, MonadFix m, MonadFix (PushM t))
test/Reflex/Test/Micro.hs+8−2
@@ -322,8 +322,14 @@ testCases =
322322 let e = never <$ switch b
323323 return $ void e
324324 lazyHold
325−
326−
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
327333 ] where
328334
329335 events1, events2, events3 :: TestPlan t m => m (Event t String)
test/RequesterT.hs+63−2
@@ -1,20 +1,36 @@
11{-# LANGUAGE CPP #-}
22{-# LANGUAGE BangPatterns #-}
33{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
45{-# LANGUAGE GADTs #-}
5−{-# LANGUAGE RankNTypes #-}
6+{-# LANGUAGE LambdaCase #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
68{-# LANGUAGE RecursiveDo #-}
79{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TemplateHaskell #-}
11+{-# LANGUAGE TypeApplications #-}
12+{-# LANGUAGE TypeFamilies #-}
813module Main where
914
10−import Control.Lens
15+import Control.Lens hiding (has)
1116import Control.Monad
1217import 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
1322import qualified Data.Dependent.Map as DMap
1423import Data.Dependent.Sum
1524import Data.Functor.Misc
25+import Data.List (words)
26+import Data.Map (Map)
1627import qualified Data.Map as M
28+#if !MIN_VERSION_these(4,11,0)
29+import Data.Semigroup ((<>))
30+#endif
31+import Data.Text (Text)
1732import Data.These
33+import Text.Read (readMaybe)
1834
1935#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))
2036import Data.These.Lens
@@ -49,12 +65,19 @@ main = do
4965 print os5
5066 os6 <- runApp' (unwrapApp delayedPulse) [Just ()]
5167 print os6
68+ os7 <- runApp' testMatchRequestsWithResponses [ Just $ TestRequest_Increment 1 ]
69+ print os7
70+ os8 <- runApp' testMatchRequestsWithResponses [ Just $ TestRequest_Reverse "yoyo" ]
71+ print os8
5272 let ![[Just [1,2,3,4,5,6,7,8,9,10]]] = os1 -- The order is reversed here: see the documentation for 'runRequesterT'
5373 let ![[Just [9,7,5,3,1]],[Nothing,Nothing],[Just [10,8,6,4,2]],[Just [10,8,6,4,2],Nothing]] = os2
5474 let ![[Nothing, Just [2]]] = os3
5575 let ![[Nothing, Just [2]]] = os4
5676 let ![[Nothing, Just [1, 2]]] = os5
5777 -- 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+
5881 return ()
5982
6083unwrapRequest :: DSum tag RequestInt -> Int
@@ -172,3 +195,41 @@ delayedPulse pulse = void $ flip runWithReplace (pure () <$ pulse) $ do
172195 -- This has the effect of delaying pulse' from pulse
173196 (_, pulse') <- runWithReplace (pure ()) $ pure (RequestInt 1) <$ pulse
174197 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+2−8
@@ -1,7 +1,7 @@
11module Main where
22
33import Control.Monad
4−import Language.Haskell.HLint3 (hlint)
4+import Language.Haskell.HLint (hlint)
55import System.Directory
66import System.Exit (exitFailure, exitSuccess)
77import System.FilePath
@@ -22,6 +22,7 @@ main = do
2222 , "--ignore=Use unless"
2323 , "--ignore=Reduce duplication"
2424 , "--cpp-define=USE_TEMPLATE_HASKELL"
25+ , "--cpp-define=DEBUG"
2526 , "--ignore=Use tuple-section"
2627 ]
2728 recurseInto = and <$> sequence
@@ -30,16 +31,9 @@ main = do
3031 ]
3132 matchFile = and <$> sequence
3233 [ extension ==? ".hs"
33− , let notElem' = liftOp notElem
34− in filePath `notElem'` filePathExceptions pwd
3534 ]
3635 files <- find recurseInto matchFile (pwd </> "src") --TODO: Someday fix all hints in tests, etc.
3736 ideas <- fmap concat $ forM files $ \f -> do
3837 putStr $ "linting file " ++ drop (length pwd + 1) f ++ "... "
3938 runHlint f
4039 if null ideas then exitSuccess else exitFailure
41−
42−filePathExceptions :: FilePath -> [FilePath]
43−filePathExceptions pwd = map (pwd </>) $
44− [ "src/Data/AppendMap.hs" -- parse error when hlint runs
45− ]