git.iko.soy/reflex
on develop help sign in
swap
90891e1265 ahead, 0 behind
53 files changed+1132−1708
since splitsnapshots
unifiedsplit
.github/workflows/haskell.yml+41 .travis.yml−175 ChangeLog.md+74−4 Quickref.md+1 README.md+15−17 cabal.haskell-ci+1 dep/reflex-platform/github.json+2−2 reflex.cabal+96−39 release.nix+5−2 src/Data/AppendMap.hs+2−2 src/Data/FastMutableIntMap.hs+3−3 src/Data/Functor/Misc.hs−234 src/Data/Map/Misc.hs+1−1 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+32−8 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/Patch.hs−46 src/Reflex/Patch/Class.hs−34 src/Reflex/Patch/DMap.hs−82 src/Reflex/Patch/DMapWithMove.hs−363 src/Reflex/Patch/IntMap.hs−59 src/Reflex/Patch/Map.hs−55 src/Reflex/Patch/MapWithMove.hs−270 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+59−5 src/Reflex/Pure.hs+6−1 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+188−121 src/Reflex/TriggerEvent/Base.hs+2 src/Reflex/TriggerEvent/Class.hs+6 src/Reflex/Widget/Basic.hs+1−1 test/Adjustable.hs+62 test/DebugCycles.hs+53−96 test/GC.hs+2−1 test/Headless.hs+10 test/QueryT.hs+1−1 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−175
@@ -1,175 +0,0 @@
1−# This Travis job script has been generated by a script via
2−#
3−# haskell-ci 'reflex.cabal' '--config' 'cabal.haskell-ci'
4−#
5−# For more information, see https://github.com/haskell-CI/haskell-ci
6−#
7−# version: 0.3.20190815
8−#
9−language: c
10−dist: xenial
11−git:
12− # whether to recursively clone submodules
13− submodules: false
14−cache:
15− directories:
16− - $HOME/.cabal/packages
17− - $HOME/.cabal/store
18−before_cache:
19− - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log
20− # remove files that are regenerated by 'cabal update'
21− - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*
22− - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json
23− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache
24− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar
25− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx
26− - rm -rfv $CABALHOME/packages/head.hackage
27−matrix:
28− include:
29− - compiler: ghcjs-8.4
30− addons: {"apt":{"sources":["hvr-ghc"],"packages":["cabal-install-3.0"]}}
31− - compiler: ghc-8.6.5
32− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-2.4"]}}
33− - compiler: ghc-8.4.4
34− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-2.4"]}}
35− - compiler: ghc-8.2.2
36− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-2.4"]}}
37− - compiler: ghc-8.0.2
38− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-2.4"]}}
39−before_install:
40− - |
41− if echo $CC | grep -q ghcjs; then
42− GHCJS=true;
43− else
44− GHCJS=false;
45− fi
46− - |
47− if [ "$TRAVIS_OS_NAME" = "linux" ]; then
48− if $GHCJS ; then sudo add-apt-repository -y ppa:hvr/ghcjs ; fi;
49− if $GHCJS ; then curl -s https://deb.nodesource.com/gpgkey/nodesource.gpg.key | sudo apt-key add - ; fi;
50− if $GHCJS ; then sudo apt-add-repository 'https://deb.nodesource.com/node_8.x xenial main' ; fi;
51− if $GHCJS ; then sudo apt-get update ; fi;
52− sudo apt-get install $CC;
53− if $GHCJS ; then sudo apt-get install -y nodejs cabal-install-3.0 ; fi;
54− fi
55− - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')
56− - WITHCOMPILER="-w $HC"
57− - if $GHCJS ; then HC=${HC}js ; fi
58− - if $GHCJS ; then WITHCOMPILER="--ghcjs ${WITHCOMPILER}js" ; 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− # Constraint set debug-propagation
170− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='reflex +debug-propagation' all | color_cabal_output
171− # Constraint set debug-cycles
172− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='reflex +debug-cycles' all | color_cabal_output
173−
174−# REGENDATA ["reflex.cabal","--config","cabal.haskell-ci"]
175−# EOF
ChangeLog.md+74−4
@@ -1,10 +1,80 @@
11# Revision history for reflex
22
3−## Unreleased
3+## 0.8.2.0
44
5−* Data.WeakBag.traverse and Data.FastWeakBag.traverse have been
6− renamed to Data.WeakBag.traverse_ and Data.FastWeakBag.traverse_
7− respectively.
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.
878
979* Fixes a bug in `Reflex.Patch.MapWithMove.patchThatSortsMapWith` that was producing invalid `PatchMapWithMove`.
1080
Quickref.md+1
@@ -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)
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+1
@@ -10,6 +10,7 @@ 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
dep/reflex-platform/github.json+2−2
@@ -2,6 +2,6 @@
22 "owner": "reflex-frp",
33 "repo": "reflex-platform",
44 "branch": "develop",
5− "rev": "e7b76dd552a10916c7d8702c11292dac4f4299ea",
6− "sha256": "0s1183arrwldcs50qhzgnv94v24n9bgq6dfq64wp0a3q2nzyvgwh"
5+ "rev": "f628398d076243a0851b27e625b37f65dff9b89b",
6+ "sha256": "0sl0hf1glgyb1vmf2mhw4r9ipmcqk1y19d3wsic7dix2jwywzrh9"
77}
reflex.cabal+96−39
@@ -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.
@@ -51,44 +61,46 @@ flag debug-cycles
5161 default: False
5262 manual: True
5363
54−
5564flag split-these
5665 description: Use split these/semialign packages
5766 manual: False
58− default: False
67+ default: True
5968
6069library
70+ default-language: Haskell2010
6171 hs-source-dirs: src
6272 build-depends:
6373 MemoTrie == 0.6.*,
64− base >= 4.9 && < 4.13,
74+ base >= 4.11 && < 4.15,
6575 bifunctors >= 5.2 && < 5.6,
6676 comonad >= 5.0.4 && < 5.1,
77+ constraints >= 0.10 && <0.14,
6778 constraints-extras >= 0.3 && < 0.4,
6879 containers >= 0.6 && < 0.7,
6980 data-default >= 0.5 && < 0.8,
70− dependent-map >= 0.3 && < 0.4,
81+ dependent-map >= 0.3 && < 0.5,
7182 exception-transformers == 0.4.*,
72− profunctors >= 5.0 && < 5.5,
7383 lens >= 4.7 && < 5,
84+ mmorph >= 1.0 && < 1.2,
7485 monad-control >= 1.0.1 && < 1.1,
7586 mtl >= 2.1 && < 2.3,
76− prim-uniq >= 0.1.0.1 && < 0.2,
87+ patch >= 0.0.1 && < 0.1,
88+ prim-uniq >= 0.1.0.1 && < 0.3,
7789 primitive >= 0.5 && < 0.8,
78− profunctors,
90+ profunctors >= 5.3 && < 5.7,
7991 random == 1.1.*,
8092 ref-tf == 0.4.*,
8193 reflection == 2.1.*,
8294 semigroupoids >= 4.0 && < 6,
8395 stm >= 2.4 && < 2.6,
8496 syb >= 0.5 && < 0.8,
85− time >= 1.4 && < 1.9,
97+ time >= 1.4 && < 1.10,
8698 transformers >= 0.5.6.0 && < 0.6,
8799 unbounded-delays >= 0.1.0.0 && < 0.2,
88− witherable >= 0.3 && < 0.3.2
100+ witherable >= 0.3 && < 0.5
89101
90102 if flag(split-these)
91− build-depends: these >= 1 && <1.1,
103+ build-depends: these >= 1 && <1.2,
92104 semialign >=1 && <1.2,
93105 monoidal-containers >= 0.6 && < 0.7
94106 else
@@ -100,7 +112,6 @@ library
100112 Data.AppendMap,
101113 Data.FastMutableIntMap,
102114 Data.FastWeakBag,
103− Data.Functor.Misc,
104115 Data.Map.Misc,
105116 Data.WeakBag,
106117 Reflex,
@@ -120,15 +131,9 @@ library
120131 Reflex.FastWeak,
121132 Reflex.FunctorMaybe,
122133 Reflex.Host.Class,
134+ Reflex.Host.Headless,
123135 Reflex.Network,
124136 Reflex.NotReady.Class,
125− Reflex.Patch,
126− Reflex.Patch.Class,
127− Reflex.Patch.DMap,
128− Reflex.Patch.DMapWithMove,
129− Reflex.Patch.IntMap,
130− Reflex.Patch.Map,
131− Reflex.Patch.MapWithMove,
132137 Reflex.PerformEvent.Base,
133138 Reflex.PerformEvent.Class,
134139 Reflex.PostBuild.Base,
@@ -147,12 +152,22 @@ library
147152 Reflex.Widget.Basic,
148153 Reflex.Workflow
149154
150− -- ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively
151− ghc-options: -O0
155+ reexported-modules:
156+ patch:Data.Functor.Misc,
157+ patch:Data.Patch as Reflex.Patch,
158+ patch:Data.Patch.Class as Reflex.Patch.Class,
159+ patch:Data.Patch.DMap as Reflex.Patch.DMap,
160+ patch:Data.Patch.DMapWithMove as Reflex.Patch.DMapWithMove,
161+ patch:Data.Patch.IntMap as Reflex.Patch.IntMap,
162+ patch:Data.Patch.Map as Reflex.Patch.Map,
163+ patch:Data.Patch.MapWithMove as Reflex.Patch.MapWithMove
164+
165+ ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively
152166
153167 if flag(debug-trace-events)
154168 cpp-options: -DDEBUG_TRACE_EVENTS
155− build-depends: bytestring
169+ build-depends:
170+ bytestring >= 0.10.8 && < 0.11
156171
157172 if flag(use-reflex-optimizer)
158173 cpp-options: -DUSE_REFLEX_OPTIMIZER
@@ -160,7 +175,7 @@ library
160175 exposed-modules: Reflex.Optimizer
161176
162177 if flag(debug-propagation)
163− cpp-options: -DDEBUG
178+ cpp-options: -DDEBUG -DDEBUG_TRACE_PROPAGATION -DDEBUG_TRACE_INVALIDATION
164179
165180 if flag(debug-cycles)
166181 cpp-options: -DDEBUG_CYCLES
@@ -168,26 +183,26 @@ library
168183 if flag(use-template-haskell)
169184 cpp-options: -DUSE_TEMPLATE_HASKELL
170185 build-depends:
171− dependent-sum >= 0.6 && < 0.7,
172− haskell-src-exts >= 1.16 && < 1.22,
186+ dependent-sum >= 0.6 && < 0.8,
187+ haskell-src-exts >= 1.16 && < 1.24,
173188 haskell-src-meta >= 0.6 && < 0.9,
174− template-haskell >= 2.9 && < 2.15
189+ template-haskell >= 2.9 && < 2.17
175190 exposed-modules:
176191 Reflex.Dynamic.TH
177192 other-extensions: TemplateHaskell
178193 else
179194 build-depends:
180− dependent-sum >= 0.6 && < 0.7
195+ dependent-sum >= 0.6 && < 0.8
181196
182197 if flag(fast-weak) && impl(ghcjs)
183198 cpp-options: -DGHCJS_FAST_WEAK
184199
185200 if impl(ghcjs)
186− build-depends: ghcjs-base
187−
188−
201+ build-depends:
202+ ghcjs-base == 0.2.*
189203
190204test-suite semantics
205+ default-language: Haskell2010
191206 type: exitcode-stdio-1.0
192207 main-is: semantics.hs
193208 hs-source-dirs: test
@@ -213,6 +228,7 @@ test-suite semantics
213228 Reflex.TestPlan
214229
215230test-suite CrossImpl
231+ default-language: Haskell2010
216232 type: exitcode-stdio-1.0
217233 main-is: Reflex/Test/CrossImpl.hs
218234 hs-source-dirs: test
@@ -234,6 +250,7 @@ test-suite CrossImpl
234250 Reflex.Plan.Pure
235251
236252test-suite hlint
253+ default-language: Haskell2010
237254 type: exitcode-stdio-1.0
238255 main-is: hlint.hs
239256 hs-source-dirs: test
@@ -241,11 +258,15 @@ test-suite hlint
241258 , directory
242259 , filepath
243260 , filemanip
244− , 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
245265 if impl(ghcjs)
246266 buildable: False
247267
248268test-suite EventWriterT
269+ default-language: Haskell2010
249270 type: exitcode-stdio-1.0
250271 main-is: EventWriterT.hs
251272 hs-source-dirs: test
@@ -269,6 +290,7 @@ test-suite EventWriterT
269290
270291
271292test-suite DebugCycles
293+ default-language: Haskell2010
272294 type: exitcode-stdio-1.0
273295 main-is: DebugCycles.hs
274296 hs-source-dirs: test
@@ -278,6 +300,7 @@ test-suite DebugCycles
278300 , deepseq
279301 , dependent-map
280302 , dependent-sum
303+ , hspec
281304 , lens
282305 , mtl
283306 , these
@@ -292,24 +315,28 @@ test-suite DebugCycles
292315 build-depends: these-lens, semialign
293316
294317 other-modules:
295− Test.Run
318+ Test.Run
296319
297320
298321test-suite RequesterT
322+ default-language: Haskell2010
299323 type: exitcode-stdio-1.0
300324 main-is: RequesterT.hs
301325 hs-source-dirs: test
302326 build-depends: base
327+ , constraints
328+ , constraints-extras
303329 , containers
304330 , deepseq
305− , dependent-sum
306331 , dependent-map
332+ , dependent-sum
307333 , lens
308334 , mtl
335+ , ref-tf
336+ , reflex
337+ , text
309338 , these
310339 , transformers
311− , reflex
312− , ref-tf
313340
314341 if flag(split-these)
315342 build-depends: these-lens
@@ -319,7 +346,31 @@ test-suite RequesterT
319346 Reflex.Plan.Pure
320347 Test.Run
321348
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+
322372test-suite QueryT
373+ default-language: Haskell2010
323374 type: exitcode-stdio-1.0
324375 main-is: QueryT.hs
325376 hs-source-dirs: test
@@ -331,6 +382,7 @@ test-suite QueryT
331382 , lens
332383 , monoidal-containers
333384 , mtl
385+ , patch
334386 , ref-tf
335387 , reflex
336388 , these
@@ -346,6 +398,7 @@ test-suite QueryT
346398 Reflex.Plan.Pure
347399
348400test-suite GC-Semantics
401+ default-language: Haskell2010
349402 type: exitcode-stdio-1.0
350403 main-is: GC.hs
351404 hs-source-dirs: test
@@ -355,6 +408,7 @@ test-suite GC-Semantics
355408 , dependent-map
356409 , deepseq
357410 , mtl
411+ , patch
358412 , these
359413 , transformers
360414 , reflex
@@ -370,6 +424,7 @@ test-suite GC-Semantics
370424 Test.Run
371425
372426test-suite rootCleanup
427+ default-language: Haskell2010
373428 type: exitcode-stdio-1.0
374429 main-is: rootCleanup.hs
375430 hs-source-dirs: test
@@ -387,6 +442,7 @@ test-suite rootCleanup
387442 Test.Run
388443
389444benchmark spider-bench
445+ default-language: Haskell2010
390446 type: exitcode-stdio-1.0
391447 hs-source-dirs: bench test
392448 main-is: Main.hs
@@ -411,6 +467,7 @@ benchmark spider-bench
411467 Reflex.Bench.Focused
412468
413469benchmark saulzar-bench
470+ default-language: Haskell2010
414471 type: exitcode-stdio-1.0
415472 hs-source-dirs: bench test
416473 c-sources: bench-cbits/checkCapability.c
release.nix+5−2
@@ -1,12 +1,12 @@
11{ reflex-platform-fun ? import ./dep/reflex-platform
2+, supportedSystems ? ["x86_64-linux" "x86_64-darwin"]
23}:
34
45let
56 native-reflex-platform = reflex-platform-fun {};
67 inherit (native-reflex-platform.nixpkgs) lib;
7− systems = ["x86_64-linux" "x86_64-darwin"];
88
9− perPlatform = lib.genAttrs systems (system: let
9+ perPlatform = lib.genAttrs supportedSystems (system: let
1010 reflex-platform = reflex-platform-fun { inherit system; };
1111 compilers = [
1212 "ghc"
@@ -34,6 +34,9 @@ let
3434 "release.nix"
3535 ".git"
3636 "dist"
37+ "cabal.haskell-ci"
38+ "cabal.project"
39+ ".travis.yml"
3740 ])) ./.;
3841 };
3942 })
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+3−3
@@ -35,8 +35,8 @@ import Data.Foldable (traverse_)
3535import Data.IntMap.Strict (IntMap)
3636import qualified Data.IntMap.Strict as IntMap
3737import Data.IORef
38−import Reflex.Patch.Class
39−import Reflex.Patch.IntMap
38+import Data.Patch.Class
39+import Data.Patch.IntMap
4040
4141-- | A 'FastMutableIntMap' holds a map of values of type @a@ and allows low-overhead modifications via IO.
4242-- Operations on 'FastMutableIntMap' run in IO.
@@ -85,7 +85,7 @@ getFrozenAndClear (FastMutableIntMap r) = do
8585 writeIORef r IntMap.empty
8686 return result
8787
88−-- | 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'),
8989-- and returns an 'IntMap' with the modified keys and values.
9090applyPatch :: FastMutableIntMap a -> PatchIntMap a -> IO (IntMap a)
9191applyPatch (FastMutableIntMap r) p@(PatchIntMap m) = do
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/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+32−8
@@ -29,7 +29,7 @@
2929-- convenience functions for working with 'Event's, 'Behavior's, and other
3030-- signals.
3131module Reflex.Class
32− ( module Reflex.Patch
32+ ( module Data.Patch
3333 -- * Primitives
3434 , Reflex (..)
3535 , mergeInt
@@ -180,7 +180,7 @@ import Prelude hiding (zip, zipWith)
180180import Data.These.Combinators (justThese)
181181#endif
182182#if MIN_VERSION_semialign(1,1,0)
183−import Data.Zip (Zip (..))
183+import Data.Zip (Zip (..), Unzip (..))
184184#endif
185185#endif
186186
@@ -196,11 +196,12 @@ import Data.Align
196196import Data.Bifunctor
197197import Data.Coerce
198198import Data.Default
199−import Data.Dependent.Map (DMap, DSum (..))
199+import Data.Dependent.Map (DMap)
200+import Data.Dependent.Sum (DSum (..))
200201import qualified Data.Dependent.Map as DMap
201202import Data.Functor.Compose
202203import Data.Functor.Product
203−import Data.GADT.Compare (GEq (..), GCompare (..), (:~:) (..))
204+import Data.GADT.Compare (GEq (..), GCompare (..))
204205import Data.FastMutableIntMap (PatchIntMap)
205206import Data.Foldable
206207import Data.Functor.Bind
@@ -210,17 +211,18 @@ import Data.IntMap.Strict (IntMap)
210211import qualified Data.IntMap.Strict as IntMap
211212import Data.List.NonEmpty (NonEmpty (..))
212213import Data.Map (Map)
213−import Data.Semigroup (Semigroup, sconcat, stimes, (<>))
214+import Data.Semigroup (Semigroup (..))
214215import Data.Some (Some(Some))
215216import Data.String
216217import Data.These
217218import Data.Type.Coercion
219+import Data.Type.Equality ((:~:) (..))
218220import Data.Witherable (Filterable(..))
219221import qualified Data.Witherable as W
220222import Reflex.FunctorMaybe (FunctorMaybe)
221223import qualified Reflex.FunctorMaybe
222−import Reflex.Patch
223−import qualified Reflex.Patch.MapWithMove as PatchMapWithMove
224+import Data.Patch
225+import qualified Data.Patch.MapWithMove as PatchMapWithMove
224226
225227import Debug.Trace (trace)
226228
@@ -286,7 +288,8 @@ class ( MonadHold t (PushM t)
286288 -- | Create an 'Event' that will occur whenever the currently-selected input
287289 -- 'Event' occurs
288290 switch :: Behavior t (Event t a) -> Event t a
289− -- | 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.
290293 coincidence :: Event t (Event t a) -> Event t a
291294 -- | Extract the 'Behavior' of a 'Dynamic'.
292295 current :: Dynamic t a -> Behavior t a
@@ -418,6 +421,13 @@ class MonadSample t m => MonadHold t m where
418421 -- | Create a new 'Event' that only occurs only once, on the first occurrence of
419422 -- the supplied 'Event'.
420423 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
421431
422432-- | Accumulate an 'Incremental' with the supplied initial value and the firings of the provided 'Event',
423433-- using the combining function to produce a patch.
@@ -563,6 +573,7 @@ instance MonadHold t m => MonadHold t (ReaderT r m) where
563573 holdIncremental a0 = lift . holdIncremental a0
564574 buildDynamic a0 = lift . buildDynamic a0
565575 headE = lift . headE
576+ now = lift now
566577
567578instance (MonadSample t m, Monoid r) => MonadSample t (WriterT r m) where
568579 sample = lift . sample
@@ -573,6 +584,7 @@ instance (MonadHold t m, Monoid r) => MonadHold t (WriterT r m) where
573584 holdIncremental a0 = lift . holdIncremental a0
574585 buildDynamic a0 = lift . buildDynamic a0
575586 headE = lift . headE
587+ now = lift now
576588
577589instance MonadSample t m => MonadSample t (StateT s m) where
578590 sample = lift . sample
@@ -583,6 +595,7 @@ instance MonadHold t m => MonadHold t (StateT s m) where
583595 holdIncremental a0 = lift . holdIncremental a0
584596 buildDynamic a0 = lift . buildDynamic a0
585597 headE = lift . headE
598+ now = lift now
586599
587600instance MonadSample t m => MonadSample t (ExceptT e m) where
588601 sample = lift . sample
@@ -593,6 +606,7 @@ instance MonadHold t m => MonadHold t (ExceptT e m) where
593606 holdIncremental a0 = lift . holdIncremental a0
594607 buildDynamic a0 = lift . buildDynamic a0
595608 headE = lift . headE
609+ now = lift now
596610
597611instance (MonadSample t m, Monoid w) => MonadSample t (RWST r w s m) where
598612 sample = lift . sample
@@ -603,6 +617,7 @@ instance (MonadHold t m, Monoid w) => MonadHold t (RWST r w s m) where
603617 holdIncremental a0 = lift . holdIncremental a0
604618 buildDynamic a0 = lift . buildDynamic a0
605619 headE = lift . headE
620+ now = lift now
606621
607622instance MonadSample t m => MonadSample t (ContT r m) where
608623 sample = lift . sample
@@ -613,6 +628,7 @@ instance MonadHold t m => MonadHold t (ContT r m) where
613628 holdIncremental a0 = lift . holdIncremental a0
614629 buildDynamic a0 = lift . buildDynamic a0
615630 headE = lift . headE
631+ now = lift now
616632
617633--------------------------------------------------------------------------------
618634-- Convenience functions
@@ -662,7 +678,9 @@ instance Reflex t => Monad (Behavior t) where
662678 a >>= f = pull $ sample a >>= sample . f
663679 -- 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.
664680 return = constant
681+#if !MIN_VERSION_base(4,13,0)
665682 fail = error "Monad (Behavior t) does not support fail"
683+#endif
666684
667685instance (Reflex t, Monoid a) => Monoid (Behavior t a) where
668686 mempty = constant mempty
@@ -1087,6 +1105,12 @@ instance Reflex t => Zip (Event t) where
10871105 zip x y = mapMaybe justThese $ align x y
10881106#endif
10891107
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
10901114
10911115-- | Create a new 'Event' that only occurs if the supplied 'Event' occurs and
10921116-- the 'Behavior' is true at the time of occurrence.
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/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/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 to reverseMapping
159− in Just (to, NodeInfo (From_Move from) $ Just movingTo)
160−
161−-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
162−-- will produce a 'Map' with the same values as the second 'Map' but with the
163−-- values sorted with the given ordering function.
164−patchThatChangesAndSortsMapWith :: forall k v. (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
165−patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
166− where newList = Map.toList newByIndexUnsorted
167− newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
168−
169−-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
170−-- will produce the second 'Map'.
171−patchThatChangesMap :: (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v
172−patchThatChangesMap oldByIndex newByIndex = patch
173− where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
174− (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
175− let f k v = do
176− remainingValues <- get
177− let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
178− then Map.delete v remainingValues
179− else Map.insert v remainingKeys remainingValues
180− case Map.lookup v remainingValues of
181− Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
182− Just fromKs ->
183− if k `Set.member` fromKs
184− then do
185− putRemainingKeys $ Set.delete k fromKs
186− return $ NodeInfo (From_Move k) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
187− else do
188− (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
189− putRemainingKeys remainingKeys
190− return $ NodeInfo (From_Move fromK) $ Just undefined
191− Map.traverseWithKey f newByIndex
192− unusedOldKeys = fold unusedValuesByValue
193− pointlessMove k = \case
194− From_Move k' | k == k' -> True
195− _ -> False
196− keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
197− then Just undefined
198− else Nothing
199− patch = unsafePatchMapWithMove $ Map.filterWithKey (\k -> not . pointlessMove k . _nodeInfo_from) $ Map.mergeWithKey (\k a _ -> Just $ nodeInfoSetTo (keyWasMoved k) a) (Map.mapWithKey $ \k -> nodeInfoSetTo $ keyWasMoved k) (Map.mapWithKey $ \k _ -> NodeInfo From_Delete $ keyWasMoved k) insertsAndMoves oldByIndex
200−
201−-- | Change the 'From' value of a 'NodeInfo'
202−nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
203−nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
204−
205−-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
206−-- 'Applicative', 'Monad', etc.) action to get the new value
207−nodeInfoMapMFrom :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
208−nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
209−
210−-- | Set the 'To' field of a 'NodeInfo'
211−nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v
212−nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
213−
214−-- |Helper data structure used for composing patches using the monoid instance.
215−data Fixup k v
216− = Fixup_Delete
217− | Fixup_Update (These (From k v) (To k))
218−
219−-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
220−instance Ord k => Semigroup (PatchMapWithMove k v) where
221− PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m
222− where
223− connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb
224− h :: (k, (Maybe k, From k v)) -> [(k, Fixup k v)]
225− h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of
226− (Just toAfter, From_Move fromBefore)
227− | fromBefore == toAfter
228− -> [(toAfter, Fixup_Delete)]
229− | otherwise
230− -> [ (toAfter, Fixup_Update (This editBefore))
231− , (fromBefore, Fixup_Update (That mToAfter))
232− ]
233− (Nothing, From_Move fromBefore) -> [(fromBefore, Fixup_Update (That mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map
234− (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]
235− (Nothing, _) -> []
236− mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
237− mergeFixups _ (Fixup_Update a) (Fixup_Update b)
238− | This x <- a, That y <- b
239− = Fixup_Update $ These x y
240− | That y <- a, This x <- b
241− = Fixup_Update $ These x y
242− mergeFixups _ _ _ = error "PatchMapWithMove: incompatible fixups"
243− fixups = Map.fromListWithKey mergeFixups $ concatMap h connections
244− combineNodeInfos _ nia nib = NodeInfo
245− { _nodeInfo_from = _nodeInfo_from nia
246− , _nodeInfo_to = _nodeInfo_to nib
247− }
248− applyFixup _ ni = \case
249− Fixup_Delete -> Nothing
250− Fixup_Update u -> Just $ NodeInfo
251− { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u
252− , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
253− }
254− m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups
255− getHere :: These a b -> Maybe a
256− getHere = \case
257− This a -> Just a
258− These a _ -> Just a
259− That _ -> Nothing
260− getThere :: These a b -> Maybe b
261− getThere = \case
262− This _ -> Nothing
263− These _ b -> Just b
264− That b -> Just b
265−
266−--TODO: Figure out how to implement this in terms of PatchDMapWithMove rather than duplicating it here
267−-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
268−instance Ord k => Monoid (PatchMapWithMove k v) where
269− mempty = PatchMapWithMove mempty
270− mappend = (<>)
src/Reflex/PerformEvent/Base.hs+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+59−5
@@ -26,8 +26,10 @@ import Control.Monad.Primitive
2626import Control.Monad.Reader
2727import Control.Monad.Ref
2828import Control.Monad.State.Strict (StateT, execStateT, modify)
29+import Data.Bifunctor
2930import Data.Coerce
30−import Data.Dependent.Map (DMap, GCompare)
31+import Data.Dependent.Map (DMap)
32+import Data.GADT.Compare (GCompare)
3133import Data.FastMutableIntMap
3234import Data.IORef
3335import Data.List
@@ -42,12 +44,20 @@ import Foreign.Ptr
4244import GHC.Foreign
4345import GHC.IO.Encoding
4446import GHC.Stack
47+import Reflex.Adjustable.Class
48+import Reflex.BehaviorWriter.Class
4549import Reflex.Class
50+import Reflex.DynamicWriter.Class
51+import Reflex.EventWriter.Class
4652import Reflex.Host.Class
53+import Reflex.NotReady.Class
4754import Reflex.PerformEvent.Class
55+import Reflex.PostBuild.Class
56+import Reflex.Query.Class
57+import Reflex.Requester.Class
58+import Reflex.TriggerEvent.Class
4859
4960import System.IO.Unsafe
50−import Unsafe.Coerce
5161
5262data ProfiledTimeline t
5363
@@ -137,7 +147,7 @@ instance Reflex t => Reflex (ProfiledTimeline t) where
137147 pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e
138148 pull = Behavior_Profiled . pull . coerce
139149 fanG (Event_Profiled e) = EventSelectorG $ coerce $ selectG (fanG $ profileEvent e)
140− mergeG :: forall (k :: z -> *) q v. GCompare k
150+ mergeG :: forall z (k :: z -> *) q v. GCompare k
141151 => (forall a. q a -> Event (ProfiledTimeline t) (v a))
142152 -> DMap k q -> Event (ProfiledTimeline t) (DMap k v)
143153 mergeG nt = Event_Profiled #. mergeG (coerce nt)
@@ -147,8 +157,8 @@ instance Reflex t => Reflex (ProfiledTimeline t) where
147157 updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d
148158 unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'
149159 unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'
150− mergeIncrementalG nt = (Event_Profiled . coerce) #. mergeIncrementalG nt
151− mergeIncrementalWithMoveG nt = (Event_Profiled . coerce) #. mergeIncrementalWithMoveG nt
160+ mergeIncrementalG nt res = Event_Profiled $ mergeIncrementalG (coerce nt) (coerce res)
161+ mergeIncrementalWithMoveG nt res = Event_Profiled $ mergeIncrementalWithMoveG (coerce nt) (coerce res)
152162 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i
153163 updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i
154164 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i
@@ -174,10 +184,21 @@ instance MonadHold t m => MonadHold (ProfiledTimeline t) (ProfiledM m) where
174184 holdIncremental v0 (Event_Profiled v') = ProfiledM $ Incremental_Profiled <$> holdIncremental v0 v'
175185 buildDynamic (ProfiledM v0) (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> buildDynamic v0 v'
176186 headE (Event_Profiled e) = ProfiledM $ Event_Profiled <$> headE e
187+ now = ProfiledM $ Event_Profiled <$> now
177188
178189instance MonadSample t m => MonadSample (ProfiledTimeline t) (ProfiledM m) where
179190 sample (Behavior_Profiled b) = ProfiledM $ sample b
180191
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+
181202instance MonadTrans ProfiledM where
182203 lift = ProfiledM
183204
@@ -189,6 +210,39 @@ instance PerformEvent t m => PerformEvent (ProfiledTimeline t) (ProfiledM m) whe
189210 performEvent_ = lift . performEvent_ . coerce
190211 performEvent = lift . fmap coerce . performEvent . coerce
191212
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+
192246instance MonadRef m => MonadRef (ProfiledM m) where
193247 type Ref (ProfiledM m) = Ref m
194248 newRef = lift . newRef
src/Reflex/Pure.hs+6−1
@@ -32,7 +32,8 @@ module Reflex.Pure
3232 ) where
3333
3434import Control.Monad
35−import Data.Dependent.Map (DMap, GCompare)
35+import Data.Dependent.Map (DMap)
36+import Data.GADT.Compare (GCompare)
3637import qualified Data.Dependent.Map as DMap
3738import Data.IntMap (IntMap)
3839import qualified Data.IntMap as IntMap
@@ -210,3 +211,7 @@ instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where
210211 Just x -> fromMaybe lastValue $ apply x lastValue
211212
212213 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+188−121
@@ -9,7 +9,6 @@
99{-# LANGUAGE GADTs #-}
1010{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1111{-# LANGUAGE LambdaCase #-}
12−{-# LANGUAGE MultiWayIf #-}
1312{-# LANGUAGE RankNTypes #-}
1413{-# LANGUAGE RoleAnnotations #-}
1514{-# LANGUAGE ScopedTypeVariables #-}
@@ -20,7 +19,7 @@
2019{-# LANGUAGE DeriveFunctor #-}
2120{-# LANGUAGE StandaloneDeriving #-}
2221{-# LANGUAGE InstanceSigs #-}
23−{-# LANGUAGE RecursiveDo #-}
22+{-# LANGUAGE MultiWayIf #-}
2423
2524#ifdef USE_REFLEX_OPTIMIZER
2625{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
@@ -39,15 +38,17 @@ import Control.Monad hiding (forM, forM_, mapM, mapM_)
3938import Control.Monad.Exception
4039import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)
4140import Control.Monad.Primitive
42−--import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_)
4341import Control.Monad.Reader.Class
4442import Control.Monad.IO.Class
4543import Control.Monad.ReaderIO
4644import Control.Monad.Ref
45+import Control.Monad.Fail (MonadFail)
46+import qualified Control.Monad.Fail as MonadFail
4747import Data.Align
4848import Data.Coerce
49−import Data.Dependent.Map (DMap, DSum (..))
49+import Data.Dependent.Map (DMap)
5050import qualified Data.Dependent.Map as DMap
51+import Data.Dependent.Sum (DSum (..))
5152import Data.FastMutableIntMap (FastMutableIntMap, PatchIntMap (..))
5253import qualified Data.FastMutableIntMap as FastMutableIntMap
5354import Data.Foldable hiding (concat, elem, sequence_)
@@ -64,6 +65,7 @@ import Data.Monoid (mempty, (<>))
6465import Data.Proxy
6566import Data.These
6667import Data.Traversable
68+import Data.Type.Equality ((:~:)(Refl))
6769import Data.Witherable (Filterable, mapMaybe)
6870import GHC.Exts hiding (toList)
6971import GHC.IORef (IORef (..))
@@ -84,9 +86,9 @@ import Data.Zip (Zip (..))
8486
8587#ifdef DEBUG_CYCLES
8688import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)
87−import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
8889#endif
8990
91+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
9092import qualified Data.List.NonEmpty as NonEmpty
9193import Data.Tree (Forest, Tree (..), drawForest)
9294import Data.List (isPrefixOf)
@@ -104,15 +106,21 @@ import qualified Reflex.Class
104106import qualified Reflex.Class as R
105107import qualified Reflex.Host.Class
106108import Reflex.NotReady.Class
107−import Reflex.Patch
108−import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
109+import Data.Patch
110+import qualified Data.Patch.DMapWithMove as PatchDMapWithMove
109111import Reflex.PerformEvent.Base (PerformEventT)
110112
111113#ifdef DEBUG_TRACE_EVENTS
112114import qualified Data.ByteString.Char8 as BS8
113115import System.IO (stderr)
114116import Data.List (isPrefixOf)
117+#endif
115118
119+-- TODO stdout might not be the best channel for debug output
120+debugStrLn :: String -> IO ()
121+debugStrLn = putStrLn
122+
123+#ifdef DEBUG_TRACE_EVENTS
116124withStackOneLine :: (BS8.ByteString -> a) -> a
117125withStackOneLine expr = unsafePerformIO $ do
118126 stack <- currentCallStack
@@ -121,15 +129,39 @@ withStackOneLine expr = unsafePerformIO $ do
121129
122130#endif
123131
132+debugPropagate :: Bool
133+
134+debugInvalidateHeight :: Bool
135+
136+debugInvalidate :: Bool
137+
124138#ifdef DEBUG
125139#define DEBUG_NODEIDS
126140
141+#ifdef DEBUG_TRACE_PROPAGATION
142+debugPropagate = True
143+#else
144+debugPropagate = False
145+#endif
146+
147+#ifdef DEBUG_TRACE_HEIGHT
148+debugInvalidateHeight = True
149+#else
150+debugInvalidateHeight = False
151+#endif
152+
153+#ifdef DEBUG_TRACE_INVALIDATION
154+debugInvalidate = True
155+#else
156+debugInvalidate = False
157+#endif
158+
127159class HasNodeId a where
128160 getNodeId :: a -> Int
129161
130162instance HasNodeId (CacheSubscribed x a) where
131163 getNodeId = _cacheSubscribed_nodeId
132−
164+
133165instance HasNodeId (FanInt x a) where
134166 getNodeId = _fanInt_nodeId
135167
@@ -156,16 +188,24 @@ showNodeId :: HasNodeId a => a -> String
156188showNodeId = showNodeId' . getNodeId
157189
158190showNodeId' :: Int -> String
159−showNodeId' = ("#"<>) . show
191+showNodeId' = ("#"<>) . show
160192
161193
162194#else
163195
196+debugPropagate = False
197+debugInvalidateHeight = False
198+debugInvalidate = False
199+
164200-- This must be inline, or error messages will cause memory leaks due to retaining the node in question
165201{-# INLINE showNodeId #-}
166202showNodeId :: a -> String
167203showNodeId _ = ""
168204
205+{-# INLINE showNodeId' #-}
206+showNodeId' :: Int -> String
207+showNodeId' _ = ""
208+
169209#endif
170210
171211#ifdef DEBUG_NODEIDS
@@ -213,11 +253,11 @@ subscribeAndRead = unEvent
213253{-# INLINE [1] pushCheap #-}
214254pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
215255pushCheap !f e = Event $ \sub -> do
216− (subscription, occ) <- subscribeAndRead e $ debugSubscriber' "push" (sub
256+ (subscription, occ) <- subscribeAndRead e $ debugSubscriber' "push" $ sub
217257 { subscriberPropagate = \a -> do
218258 mb <- f a
219259 mapM_ (subscriberPropagate sub) mb
220− })
260+ }
221261 occ' <- join <$> mapM f occ
222262 return (subscription, occ')
223263
@@ -253,9 +293,9 @@ headE originalE = do
253293 let clearParent = liftIO $ writeIORef parent Nothing
254294 (_, occ) <- subscribeAndReadHead originalE $ terminalSubscriber $ const clearParent
255295 when (isJust occ) clearParent
256− return $ Event $ \sub ->
296+ return $ Event $ \sub ->
257297 liftIO (readIORef parent) >>= \case
258− Nothing -> subscribeAndReadNever
298+ Nothing -> subscribeAndReadNever
259299 Just e -> subscribeAndReadHead e sub
260300
261301data CacheSubscribed x a
@@ -267,7 +307,20 @@ data CacheSubscribed x a
267307#endif
268308 }
269309
270−
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+ )
271324
272325-- | Construct an 'Event' whose value is guaranteed not to be recomputed
273326-- repeatedly
@@ -298,39 +351,18 @@ cacheEvent e =
298351#endif
299352 subscribers <- liftIO FastWeakBag.empty
300353 occRef <- liftIO $ newIORef Nothing -- This should never be read prior to being set below
301−<<<<<<< HEAD
354+#ifdef DEBUG_NODEIDS
302355 (parentSub, occ) <- subscribeAndRead e $ debugSubscriber' ("cacheEvent" <> showNodeId' nodeId) $ Subscriber
356+#else
357+ (parentSub, occ) <- subscribeAndRead e $ Subscriber
358+#endif
303359 { subscriberPropagate = \a -> do
304− -- checkCycle (_eventSubscription_subscribed parentSub)
305360 liftIO $ writeIORef occRef (Just a)
306361 scheduleClear occRef
307362 propagateFast a subscribers
308− , subscriberInvalidateHeight = FastWeakBag.traverse subscribers . invalidateSubscriberHeight
309− , subscriberRecalculateHeight = FastWeakBag.traverse subscribers . recalculateSubscriberHeight
363+ , subscriberInvalidateHeight = FastWeakBag.traverse_ subscribers . invalidateSubscriberHeight
364+ , subscriberRecalculateHeight = FastWeakBag.traverse_ subscribers . recalculateSubscriberHeight
310365 }
311−||||||| merged common ancestors
312− (parentSub, occ) <- subscribeAndRead e $ Subscriber
313− { subscriberPropagate = \a -> do
314− liftIO $ writeIORef occRef $ Just a
315− scheduleClear occRef
316− propagateFast a subscribers
317− , subscriberInvalidateHeight = \old -> do
318− FastWeakBag.traverse subscribers $ invalidateSubscriberHeight old
319− , subscriberRecalculateHeight = \new -> do
320− FastWeakBag.traverse subscribers $ recalculateSubscriberHeight new
321− }
322−=======
323− (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− }
333−>>>>>>> develop
334366 when (isJust occ) $ do
335367 liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing
336368 scheduleClear occRef
@@ -340,20 +372,20 @@ cacheEvent e =
340372 , _cacheSubscribed_occurrence = occRef
341373#ifdef DEBUG_NODEIDS
342374 , _cacheSubscribed_nodeId = nodeId
343−#endif
375+#endif
344376 }
345377 subscribedTicket <- liftIO $ mkFastWeakTicket subscribed
346378 liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket
347379 return subscribedTicket
348380 liftIO $ cacheSubscription sub mSubscribedRef subscribedTicket
349381
350−cacheSubscription :: Subscriber x a -> IORef (FastWeak (CacheSubscribed x a))
382+cacheSubscription :: Subscriber x a -> IORef (FastWeak (CacheSubscribed x a))
351383 -> FastWeakTicket (CacheSubscribed x a) -> IO (EventSubscription x, Maybe a)
352−cacheSubscription sub mSubscribedRef subscribedTicket = do
384+cacheSubscription sub mSubscribedRef subscribedTicket = do
353385 subscribed <- getFastWeakTicketValue subscribedTicket
354386 ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed
355387 occ <- readIORef $ _cacheSubscribed_occurrence subscribed
356−
388+
357389 let parentSub = _cacheSubscribed_parent subscribed
358390 es = EventSubscription
359391 { _eventSubscription_unsubscribe = do
@@ -372,9 +404,9 @@ cacheSubscription sub mSubscribedRef subscribedTicket = do
372404 , eventSubscribedGetParents = return [_eventSubscription_subscribed parentSub]
373405 , eventSubscribedHasOwnHeightRef = False
374406 , eventSubscribedWhoCreated = whoCreatedIORef mSubscribedRef
375−#endif
407+#endif
376408 }
377− }
409+ }
378410 return (es, occ)
379411
380412
@@ -432,16 +464,6 @@ data Subscriber x a = Subscriber
432464 , subscriberRecalculateHeight :: !(Height -> IO ())
433465 }
434466
435−--TODO: Move this comment to WeakBag
436−-- These function are constructor functions that are marked NOINLINE so they are
437−-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away
438−-- so any weak references that are attached to the constructors will have their
439−-- finalizer run. Using the opaque constructor, does not see the
440−-- constructor application, so it behaves like an IORef and cannot be fused away.
441−--
442−-- The result is also evaluated to WHNF, since forcing a thunk invalidates
443−-- the weak pointer to it in some cases.
444−
445467newSubscriberHold :: (HasSpiderTimeline x, Patch p) => Hold x p -> IO (Subscriber x p)
446468newSubscriberHold h = return $ Subscriber
447469 { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h
@@ -495,7 +517,7 @@ newSubscriberCoincidenceOuter subscribed = debugSubscriber ("SubscriberCoinciden
495517 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd
496518 scheduleClear $ coincidenceSubscribedInnerParent subscribed
497519 case occ of
498− Nothing ->
520+ Nothing ->
499521 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
500522 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight
501523 WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight
@@ -505,7 +527,7 @@ newSubscriberCoincidenceOuter subscribed = debugSubscriber ("SubscriberCoinciden
505527 scheduleClear $ coincidenceSubscribedOccurrence subscribed
506528 propagate o $ coincidenceSubscribedSubscribers subscribed
507529 , subscriberInvalidateHeight = \_ -> invalidateCoincidenceHeight subscribed
508− , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed
530+ , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed
509531 }
510532
511533newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)
@@ -526,18 +548,18 @@ invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()
526548invalidateSubscriberHeight = flip subscriberInvalidateHeight
527549
528550recalculateSubscriberHeight :: Height -> Subscriber x a -> IO ()
529−recalculateSubscriberHeight = flip subscriberRecalculateHeight
551+recalculateSubscriberHeight = flip subscriberRecalculateHeight
530552
531553-- | Propagate everything at the current height
532554propagate :: forall x a. HasSpiderTimeline x => a -> WeakBag (Subscriber x a) -> EventM x ()
533−propagate a subscribers = withIncreasedDepth (Proxy::Proxy x) $
555+propagate a subscribers = withIncreasedDepth (Proxy::Proxy x) $
534556 -- 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
535557 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
536558 WeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a
537559
538560-- | Propagate everything at the current height
539561propagateFast :: forall x a. HasSpiderTimeline x => a -> FastWeakBag (Subscriber x a) -> EventM x ()
540−propagateFast a subscribers = withIncreasedDepth (Proxy::Proxy x) $
562+propagateFast a subscribers = withIncreasedDepth (Proxy::Proxy x) $
541563 -- 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
542564 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
543565 FastWeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a
@@ -585,6 +607,16 @@ eventSubscribedNever = EventSubscribed
585607 , eventSubscribedWhoCreated = return ["never"]
586608#endif
587609 }
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+ }
588620
589621eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x
590622eventSubscribedFan !subscribed = EventSubscribed
@@ -962,8 +994,10 @@ instance Monad (BehaviorM x) where
962994 BehaviorM x >> BehaviorM y = BehaviorM $ x >> y
963995 {-# INLINE return #-}
964996 return x = BehaviorM $ return x
997+#if !MIN_VERSION_base(4,13,0)
965998 {-# INLINE fail #-}
966999 fail s = BehaviorM $ fail s
1000+#endif
9671001
9681002data BehaviorSubscribed x a
9691003 = forall p. BehaviorSubscribedHold (Hold x p)
@@ -1023,7 +1057,7 @@ data SomeMergeUpdate x = SomeMergeUpdate
10231057newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }
10241058
10251059-- EventM can do everything BehaviorM can, plus create holds
1026−newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException)
1060+newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException)
10271061
10281062newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }
10291063
@@ -1048,7 +1082,7 @@ heightBagFromList :: [Height] -> HeightBag
10481082heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights
10491083
10501084heightBagAdd :: Height -> HeightBag -> HeightBag
1051−heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $
1085+heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $
10521086 IntMap.insertWithKey (\_ _ old -> succ old) h 0 c
10531087
10541088heightBagRemove :: Height -> HeightBag -> HeightBag
@@ -1059,11 +1093,11 @@ heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.loo
10591093 _ -> IntMap.insert h (pred old) c
10601094
10611095heightBagRemoveMaybe :: Height -> HeightBag -> Maybe HeightBag
1062−heightBagRemoveMaybe (Height h) b@(HeightBag s c) = heightBagVerify . removed <$> IntMap.lookup h c where
1096+heightBagRemoveMaybe (Height h) b@(HeightBag s c) = heightBagVerify . removed <$> IntMap.lookup h c where
10631097 removed old = HeightBag (pred s) $ case old of
10641098 0 -> IntMap.delete h c
10651099 _ -> IntMap.insert h (pred old) c
1066−
1100+
10671101
10681102heightBagMax :: HeightBag -> Height
10691103heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of
@@ -1312,7 +1346,7 @@ mkWeakPtrWithDebug x debugNote = do
13121346 x' <- evaluate x
13131347 mkWeakPtr x' $
13141348 if debugFinalize
1315− then Just $ putStrLn $ "finalizing: " ++ debugNote
1349+ then Just $ debugStrLn $ "finalizing: " ++ debugNote
13161350 else Nothing
13171351
13181352type WeakList a = [Weak a]
@@ -1328,19 +1362,19 @@ debugSubscriber :: forall x a. HasSpiderTimeline x => String -> Subscriber x a -
13281362debugSubscriber description = return . debugSubscriber' description
13291363
13301364debugSubscriber' :: forall x a. HasSpiderTimeline x => String -> Subscriber x a -> Subscriber x a
1331−debugSubscriber' description subscribed = Subscriber
1365+debugSubscriber' description subscribed = Subscriber
13321366 {
13331367 subscriberPropagate = \m -> do
13341368 tracePropagate (Proxy :: Proxy x) ("subscriberPropagate: " <> description)
13351369 subscriberPropagate subscribed m
13361370 , subscriberInvalidateHeight = \old -> do
1337− putStrLn $ "invalidateSubscriberHeight: " <> description <> ", old = " <> show (unHeight old)
1371+ traceInvalidateHeight $ "invalidateSubscriberHeight: " <> description <> ", old = " <> show (unHeight old)
13381372 subscriberInvalidateHeight subscribed old
1339− putStrLn $ "invalidateSubscriberHeight: " <> description <> ", done"
1373+ traceInvalidateHeight $ "invalidateSubscriberHeight: " <> description <> ", done"
13401374 , subscriberRecalculateHeight = \new -> do
1341− putStrLn $ "subscriberRecalculateHeight: " <> description <> ", new = " <> show (unHeight new)
1375+ traceInvalidateHeight $ "subscriberRecalculateHeight: " <> description <> ", new = " <> show (unHeight new)
13421376 subscriberRecalculateHeight subscribed new
1343− putStrLn $ "subscriberRecalculateHeight: " <> description <> ", done"
1377+ traceInvalidateHeight $ "subscriberRecalculateHeight: " <> description <> ", done"
13441378 }
13451379
13461380
@@ -1354,11 +1388,15 @@ withIncreasedDepth _ a = do
13541388
13551389{-# INLINE tracePropagate #-}
13561390tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1357−tracePropagate p = trace p
1391+tracePropagate p = when debugPropagate . trace p
13581392
13591393{-# INLINE traceInvalidate #-}
13601394traceInvalidate :: String -> IO ()
1361−traceInvalidate = liftIO . putStrLn
1395+traceInvalidate = when debugInvalidate . liftIO . debugStrLn
1396+
1397+{-# INLINE traceInvalidateHeight #-}
1398+traceInvalidateHeight :: String -> IO ()
1399+traceInvalidateHeight = when debugInvalidateHeight . liftIO . debugStrLn
13621400
13631401{-# INLINE trace #-}
13641402trace :: (CanTrace x m) => proxy x -> String -> m ()
@@ -1369,7 +1407,7 @@ traceM :: forall x proxy m. (CanTrace x m) => proxy x -> m String -> m ()
13691407traceM _ getMessage = do
13701408 message <- getMessage
13711409 d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)
1372− liftIO $ putStrLn $ replicate d ' ' <> message
1410+ liftIO $ debugStrLn $ replicate d ' ' <> message
13731411
13741412#else
13751413
@@ -1385,6 +1423,10 @@ tracePropagate _ _ = return ()
13851423traceInvalidate :: String -> IO ()
13861424traceInvalidate _ = return ()
13871425
1426+{-# INLINE traceInvalidateHeight #-}
1427+traceInvalidateHeight :: String -> IO ()
1428+traceInvalidateHeight _ = return ()
1429+
13881430{-# INLINE debugSubscriber #-}
13891431debugSubscriber :: String -> Subscriber x a -> IO (Subscriber x a)
13901432debugSubscriber _ = return
@@ -1425,17 +1467,20 @@ showStacks :: [[String]] -> String
14251467showStacks = drawForest . listsToForest . fmap (filterStack "Reflex.Spider.Internal")
14261468
14271469filterStack :: String -> [String] -> [String]
1470+#ifdef DEBUG_HIDE_INTERNALS
14281471filterStack prefix = filter (not . (prefix `isPrefixOf`))
1429−
1472+#else
1473+filterStack prefix = id
1474+#endif
14301475
14311476#ifdef DEBUG_CYCLES
14321477
1433−data EventLoopException = EventLoopException [[String]]
1478+data EventLoopException = EventLoopException [[String]]
14341479instance Exception EventLoopException
14351480
14361481instance Show EventLoopException where
1437− show (EventLoopException stacks) = "causality loop detected:\n" <> if null stacks
1438− then "no location information, compile with profiling enabled for stack tree"
1482+ show (EventLoopException stacks) = "causality loop detected:\n" <> if null stacks
1483+ then "no location information, compile with profiling enabled for stack tree"
14391484 else showStacks stacks
14401485
14411486#else
@@ -1453,7 +1498,7 @@ instance Show EventLoopException where
14531498{-# INLINE propagateSubscriberHold #-}
14541499propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()
14551500propagateSubscriberHold h a = do
1456− traceM (Proxy :: Proxy x) $ liftIO $ do
1501+ {-# SCC "trace" #-} when debugPropagate $ traceM (Proxy :: Proxy x) $ liftIO $ do
14571502 invalidators <- liftIO $ readIORef $ holdInvalidators h
14581503 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
14591504
@@ -1461,7 +1506,7 @@ propagateSubscriberHold h a = do
14611506 case {-# SCC "apply" #-} apply a v of
14621507 Nothing -> return ()
14631508 Just v' -> do
1464− withIncreasedDepth (Proxy :: Proxy x) $
1509+ {-# SCC "trace2" #-} withIncreasedDepth (Proxy :: Proxy x) $
14651510 tracePropagate (Proxy :: Proxy x) ("propagateSubscriberHold: assigning Hold" <> showNodeId h)
14661511 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
14671512 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
@@ -1582,7 +1627,7 @@ data FanInt x a = FanInt
15821627 { _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
15831628 , _fanInt_subscriptionRef :: {-# UNPACK #-} !(IORef (EventSubscription x)) -- This should have a valid subscription iff subscribers is non-empty
15841629 , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a))
1585−#ifdef DEBUG_NODEIDS
1630+#ifdef DEBUG_NODEIDS
15861631 , _fanInt_nodeId :: {-# UNPACK #-} !Int
15871632#endif
15881633 }
@@ -1592,15 +1637,15 @@ newFanInt = do
15921637 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
15931638 subscriptionRef <- newIORef $ error "fanInt: no subscription"
15941639 occRef <- newIORef $ error "fanInt: no occurrence"
1595−#ifdef DEBUG_NODEIDS
1640+#ifdef DEBUG_NODEIDS
15961641 nodeId <- newNodeId
15971642#endif
15981643 return $ FanInt
15991644 { _fanInt_subscribers = subscribers
16001645 , _fanInt_subscriptionRef = subscriptionRef
16011646 , _fanInt_occRef = occRef
1602−#ifdef DEBUG_NODEIDS
1603− , _fanInt_nodeId = nodeId
1647+#ifdef DEBUG_NODEIDS
1648+ , _fanInt_nodeId = nodeId
16041649#endif
16051650 }
16061651
@@ -1616,15 +1661,15 @@ fanInt p = unsafePerformIO $ do
16161661 liftIO $ writeIORef (_fanInt_occRef self) m
16171662 scheduleIntClear $ _fanInt_occRef self
16181663 FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> --TODO: Do we need to know that no subscribers are being added as we traverse?
1619− FastWeakBag.traverse_ b $ \s ->
1664+ FastWeakBag.traverse_ b $ \s ->
16201665 subscriberPropagate s v
1621− , subscriberInvalidateHeight = \old ->
1622− FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->
1623− FastWeakBag.traverse_ b $ \s ->
1666+ , subscriberInvalidateHeight = \old ->
1667+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->
1668+ FastWeakBag.traverse_ b $ \s ->
16241669 subscriberInvalidateHeight s old
16251670 , subscriberRecalculateHeight = \new ->
1626− FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->
1627− FastWeakBag.traverse_ b $ \s ->
1671+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->
1672+ FastWeakBag.traverse_ b $ \s ->
16281673 subscriberRecalculateHeight s new
16291674 }
16301675 liftIO $ do
@@ -1640,14 +1685,14 @@ fanInt p = unsafePerformIO $ do
16401685 Just b -> return b
16411686 ticket <- liftIO $ FastWeakBag.insert sub b
16421687 currentOcc <- readIORef (_fanInt_occRef self)
1643−
1688+
16441689 subscribed <- fanIntSubscribed ticket self
16451690 return (EventSubscription (FastWeakBag.remove ticket) subscribed, IntMap.lookup k currentOcc)
16461691
16471692fanIntSubscribed :: FastWeakBagTicket k -> FanInt x a -> IO (EventSubscribed x)
1648−fanIntSubscribed ticket self = do
1693+fanIntSubscribed ticket self = do
16491694 subscribedParent <- _eventSubscription_subscribed <$> readIORef (_fanInt_subscriptionRef self)
1650− return $ EventSubscribed
1695+ return $ EventSubscribed
16511696 { eventSubscribedHeightRef = eventSubscribedHeightRef subscribedParent
16521697 , eventSubscribedRetained = toAny (_fanInt_subscriptionRef self, ticket)
16531698#ifdef DEBUG_CYCLES
@@ -1656,7 +1701,7 @@ fanIntSubscribed ticket self = do
16561701 , eventSubscribedWhoCreated = whoCreatedIORef $ _fanInt_subscriptionRef self
16571702#endif
16581703 }
1659−
1704+
16601705
16611706{-# INLINABLE getFanSubscribed #-}
16621707getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k v -> Subscriber x (v a) -> EventM x (WeakBagTicket, FanSubscribed x k v, Maybe (v a))
@@ -1869,7 +1914,7 @@ mergeCheap nt = mergeGCheap' unMergeSubscribedParent getInitialSubscribers updat
18691914 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
18701915 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
18711916 forM_ mOldSubd $ \oldSubd -> do
1872− oldHeight <- liftIO $ getEventSubscribedHeight $
1917+ oldHeight <- liftIO $ getEventSubscribedHeight $
18731918 _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd
18741919
18751920 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
@@ -1915,7 +1960,7 @@ mergeCheapWithMove nt = mergeGCheap' _mergeSubscribedParentWithMove_subscription
19151960 let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
19161961 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
19171962 Nothing -> do
1918− oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $
1963+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $
19191964 _mergeSubscribedParentWithMove_subscription parent
19201965
19211966 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
@@ -1923,7 +1968,7 @@ mergeCheapWithMove nt = mergeGCheap' _mergeSubscribedParentWithMove_subscription
19231968 Just toKey -> do
19241969 liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey
19251970 return Nothing
1926− toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $
1971+ toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $
19271972 DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
19281973
19291974 return (toDelete, applyAlways p' oldParents)
@@ -1976,16 +2021,16 @@ invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
19762021invalidateMergeHeight' heightRef sub = do
19772022 oldHeight <- readIORef heightRef
19782023 -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents
1979− when (oldHeight /= invalidHeight) $ do
2024+ when (oldHeight /= invalidHeight) $ do
19802025 writeIORef heightRef $! invalidHeight
19812026 subscriberInvalidateHeight sub oldHeight
19822027
19832028revalidateMergeHeight :: Merge x k v s -> IO ()
19842029revalidateMergeHeight m = do
19852030 currentHeight <- readIORef $ _merge_heightRef m
1986−
2031+
19872032 -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
1988− when (currentHeight == invalidHeight) $ do
2033+ when (currentHeight == invalidHeight) $ do
19892034 heights <- readIORef $ _merge_heightBagRef m
19902035 parents <- readIORef $ _merge_parentsRef m
19912036 -- When the number of heights in the bag reaches the number of parents, we should have a valid height
@@ -1993,7 +2038,7 @@ revalidateMergeHeight m = do
19932038 LT -> return ()
19942039 EQ -> do
19952040 let height = succHeight $ heightBagMax heights
1996− traceInvalidate $ "recalculateSubscriberHeight: height: " <> show height
2041+ traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height
19972042 writeIORef (_merge_heightRef m) $! height
19982043 subscriberRecalculateHeight (_merge_sub m) height
19992044 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
@@ -2001,22 +2046,22 @@ revalidateMergeHeight m = do
20012046scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()
20022047scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
20032048 vals <- liftIO $ readIORef $ _merge_accumRef m
2004− -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us,
2049+ -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us,
20052050 -- it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers
2006− liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty
2051+ liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty
20072052 --TODO: Assert that m is not empty
20082053 subscriberPropagate (_merge_sub m) vals
20092054
20102055checkCycle :: HasSpiderTimeline x => EventSubscribed x -> EventM x ()
20112056checkCycle subscribed = liftIO $ do
20122057 height <- readIORef (eventSubscribedHeightRef subscribed)
2013−
2058+
20142059 -- currentHeight <- getCurrentHeight
20152060 -- when (height <= currentHeight) $ if height /= invalidHeight
20162061 -- then do
20172062 -- myStack <- liftIO $ whoCreatedIORef undefined --TODO
20182063 -- error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
2019− -- else liftIO $
2064+ -- else liftIO $
20202065 when (height == invalidHeight) $
20212066#ifdef DEBUG_CYCLES
20222067 do
@@ -2069,17 +2114,17 @@ mergeGCheap' getParent getInitialSubscribers updateFunc destroy d = Event $ \sub
20692114 parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"
20702115 changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
20712116
2072− let subscribed = EventSubscribed
2073− { eventSubscribedHeightRef = heightRef
2117+ let subscribed = EventSubscribed
2118+ { eventSubscribedHeightRef = heightRef
20742119 , eventSubscribedRetained = toAny (parentsRef, changeSubdRef)
20752120#ifdef DEBUG_CYCLES
20762121 , eventSubscribedGetParents = do
20772122 let getParent' (_ :=> v) = _eventSubscription_subscribed (getParent v)
2078− fmap getParent' . DMap.toList <$> readIORef parentsRef
2123+ fmap getParent' . DMap.toList <$> readIORef parentsRef
20792124 , eventSubscribedHasOwnHeightRef = False
20802125 , eventSubscribedWhoCreated = whoCreatedIORef heightRef
2081−#endif
2082− }
2126+#endif
2127+ }
20832128
20842129 m = Merge
20852130 { _merge_parentsRef = parentsRef
@@ -2117,9 +2162,9 @@ mergeGCheap' getParent getInitialSubscribers updateFunc destroy d = Event $ \sub
21172162 -- its subscription.
21182163 liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)
21192164 let unsubscribeAll = destroy =<< readIORef parentsRef
2120−
2165+
21212166 return (EventSubscription unsubscribeAll subscribed, occ)
2122−
2167+
21232168
21242169mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)
21252170mergeInt = cacheEvent . mergeIntCheap
@@ -2133,14 +2178,14 @@ mergeIntCheap d = Event $ \sub -> do
21332178 heightBagRef <- liftIO $ newIORef heightBagEmpty
21342179 parents <- liftIO $ FastMutableIntMap.newEmpty
21352180 changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
2136− let subscribed = EventSubscribed
2137− { eventSubscribedHeightRef = heightRef
2181+ let subscribed = EventSubscribed
2182+ { eventSubscribedHeightRef = heightRef
21382183 , eventSubscribedRetained = toAny (parents, changeSubdRef)
21392184#ifdef DEBUG_CYCLES
21402185 , eventSubscribedGetParents = fmap (_eventSubscription_subscribed . snd) <$> FastMutableIntMap.toList parents
21412186 , eventSubscribedHasOwnHeightRef = False
21422187 , eventSubscribedWhoCreated = whoCreatedIORef heightRef
2143−#endif
2188+#endif
21442189 }
21452190 let scheduleSelf = do
21462191 height <- liftIO $ readIORef $ heightRef
@@ -2157,7 +2202,7 @@ mergeIntCheap d = Event $ \sub -> do
21572202 LT -> return ()
21582203 EQ -> do
21592204 let height = succHeight $ heightBagMax heights
2160− traceInvalidate $ "recalculateSubscriberHeight: height: " <> show height
2205+ traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height
21612206 writeIORef heightRef $! height
21622207 subscriberRecalculateHeight sub height
21632208 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"
@@ -2229,7 +2274,7 @@ mergeIntCheap d = Event $ \sub -> do
22292274 -- its subscription.
22302275 liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)
22312276 let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents
2232−
2277+
22332278
22342279 return (EventSubscription unsubscribeAll subscribed, occ)
22352280
@@ -2340,7 +2385,7 @@ runFrame a = SpiderHost $ do
23402385 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
23412386 {-
23422387 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
2343− liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
2388+ liftIO $ debugStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
23442389 EventRoot _ -> "EventRoot"
23452390 EventNever -> "EventNever"
23462391 _ -> "something else"
@@ -2475,6 +2520,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Event
24752520 {-# INLINABLE headE #-}
24762521 headE = R.slowHeadE
24772522-- headE (SpiderEvent e) = SpiderEvent <$> Reflex.Spider.Internal.headE e
2523+ {-# INLINABLE now #-}
2524+ now = nowSpiderEventM
24782525
24792526instance Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where
24802527 {-# INLINABLE sample #-}
@@ -2496,6 +2543,9 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide
24962543 {-# INLINABLE headE #-}
24972544 headE = R.slowHeadE
24982545-- headE (SpiderEvent e) = SpiderPushM $ SpiderEvent <$> Reflex.Spider.Internal.headE e
2546+ {-# INLINABLE now #-}
2547+ now = SpiderPushM nowSpiderEventM
2548+
24992549
25002550instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where
25012551 {-# INLINE return #-}
@@ -2504,8 +2554,10 @@ instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x))
25042554 x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x
25052555 {-# INLINE (>>) #-}
25062556 (>>) = (*>)
2557+#if !MIN_VERSION_base(4,13,0)
25072558 {-# INLINE fail #-}
25082559 fail _ = error "Dynamic does not support 'fail'"
2560+#endif
25092561
25102562{-# INLINABLE newJoinDyn #-}
25112563newJoinDyn :: HasSpiderTimeline x => DynamicS x (Identity (DynamicS x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)
@@ -2557,6 +2609,9 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide
25572609 buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e
25582610 {-# INLINABLE headE #-}
25592611 headE e = runFrame . runSpiderHostFrame $ Reflex.Class.headE e
2612+ {-# INLINABLE now #-}
2613+ now = runFrame . runSpiderHostFrame $ Reflex.Class.now
2614+
25602615
25612616instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where
25622617 sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can
@@ -2573,6 +2628,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide
25732628 {-# INLINABLE headE #-}
25742629 headE = R.slowHeadE
25752630-- headE (SpiderEvent e) = SpiderHostFrame $ SpiderEvent <$> Reflex.Spider.Internal.headE e
2631+ {-# INLINABLE now #-}
2632+ now = SpiderHostFrame Reflex.Class.now
25762633
25772634instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where
25782635 {-# INLINABLE sample #-}
@@ -2593,6 +2650,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Refle
25932650 buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e
25942651 {-# INLINABLE headE #-}
25952652 headE e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.headE e
2653+ {-# INLINABLE now #-}
2654+ now = Reflex.Spider.Internal.ReadPhase Reflex.Class.now
25962655
25972656--------------------------------------------------------------------------------
25982657-- Deprecated items
@@ -2716,7 +2775,7 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
27162775 fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))
27172776 {-# INLINABLE mergeG #-}
27182777 mergeG
2719− :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k
2778+ :: forall k2 (k :: k2 -> *) q (v :: k2 -> *). GCompare k
27202779 => (forall a. q a -> R.Event (SpiderTimeline x) (v a))
27212780 -> DMap k q
27222781 -> R.Event (SpiderTimeline x) (DMap k v)
@@ -2784,8 +2843,14 @@ instance Monad (SpiderHost x) where
27842843 SpiderHost x >> SpiderHost y = SpiderHost $ x >> y
27852844 {-# INLINABLE return #-}
27862845 return x = SpiderHost $ return x
2846+#if !MIN_VERSION_base(4,13,0)
27872847 {-# INLINABLE fail #-}
2788− 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
27892854
27902855-- | Run an action affecting the global Spider timeline; this will be guarded by
27912856-- a mutex for that timeline
@@ -2807,8 +2872,10 @@ instance Monad (SpiderHostFrame x) where
28072872 SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y
28082873 {-# INLINABLE return #-}
28092874 return x = SpiderHostFrame $ return x
2875+#if !MIN_VERSION_base(4,13,0)
28102876 {-# INLINABLE fail #-}
28112877 fail s = SpiderHostFrame $ fail s
2878+#endif
28122879
28132880instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where
28142881 notReadyUntil _ = pure ()
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
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.hs+53−96
@@ -15,43 +15,33 @@ import Control.Applicative
1515import Control.Monad
1616import Control.Monad.Fix
1717import Control.Exception
18−
1918import System.Timeout
20−
2119import Data.Maybe (isJust)
2220import Data.Functor.Misc
2321import qualified Data.Map as Map
2422import Data.Map (Map)
25−
2623import qualified Data.IntMap as IntMap
2724import Data.IntMap (IntMap)
28−
29−
3025import Data.These
3126import Data.Align
32−
3327import Reflex
3428import Reflex.EventWriter.Base
3529import Test.Run
36−
30+import Test.Hspec
3731import Reflex.Spider.Internal (EventLoopException)
38−
39−
4032import Data.Witherable (Filterable)
4133
4234#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))
4335import Data.These.Lens
4436#endif
4537
46−type Widget t m = (MonadHold t m, Reflex t, MonadFix m)
47−
38+type Widget t m = (MonadHold t m, Reflex t, MonadFix m)
4839
49−connectDyn ::Widget t m => Event t () -> (Dynamic t a, Dynamic t a) -> m (Dynamic t a)
50−connectDyn e (d, d') = do
40+connectDyn :: Widget t m => Event t () -> (Dynamic t a, Dynamic t a) -> m (Dynamic t a)
41+connectDyn e (d, d') = do
5142 dd <- holdDyn d (d' <$ e)
5243 return $ join dd
5344
54−
5545dynLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
5646dynLoop (e1, e2) = do
5747 -- "heightBagRemove: Height 2 not present in bag HeightBag {_heightBag_size = 2, _heightBag_contents = fromList [(0,1)]}"
@@ -64,7 +54,7 @@ connectOnCoincidence :: Widget t m => Event t () -> Event t a -> m (Event t a)
6454connectOnCoincidence click e = do
6555 d <- holdDyn never (e <$ click)
6656 return $ coincidence (updated d)
67−
57+
6858coincidenceLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
6959coincidenceLoop (e1, e2) = do
7060-- "heightBagRemove: Height 1 not present in bag HeightBag {_heightBag_size = 1, _heightBag_contents = fromList [(0,0)]}"
@@ -74,7 +64,6 @@ coincidenceLoop (e1, e2) = do
7464 d <- count (align e' e1)
7565 return $ updated d
7666
77−
7867addHeight :: Reflex t => Event t a -> Event t a
7968addHeight e = leftmost [e4, e4] where
8069 e1 = leftmost [e, e]
@@ -82,12 +71,10 @@ addHeight e = leftmost [e4, e4] where
8271 e3 = leftmost [e2, e2]
8372 e4 = leftmost [e3, e3]
8473
85−
86−-- Take an existing test and build it inside a
74+-- Take an existing test and build it inside a
8775buildLoop :: 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)
8876buildLoop test (e1, e2) = switchHold never buildLoop
89− where buildLoop = pushAlways (const $ test (e1, e2)) e2
90−
77+ where buildLoop = pushAlways (const $ test (e1, e2)) e2
9178
9279connectButtonPromptly :: Widget t m => Event t () -> Event t a -> m (Event t a)
9380connectButtonPromptly click e = do
@@ -99,9 +86,8 @@ connectButton click e = do
9986 d <- hold never (e <$ click)
10087 return (switch d)
10188
102−
103−switchLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
104−switchLoop (e1, e2) = do
89+switchLoop01 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
90+switchLoop01 (e1, e2) = do
10591 rec
10692 e' <- connectButton e2 (updated d)
10793 d <- count (align e' e1)
@@ -110,105 +96,76 @@ switchLoop (e1, e2) = do
11096mergeLoop :: forall t m. (Adjustable t m, Widget t m) => (Event t Int, Event t ()) -> m (Event t Int)
11197mergeLoop (e1, e2) = do
11298 rec
113− (_, e) <- runEventWriterT $
99+ (_, e) <- runEventWriterT $
114100 runWithReplace w (leftmost [w <$ e1])
115−
116101 return (sum <$> e)
117−
118102 where
119− w = do
103+ w = do
120104 c <- count e1
121105 tellEvent (updated ((pure <$> c) :: Dynamic t [Int]))
122106
123−
124−
125−
126−switchLoop' :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
127−switchLoop' (e1, e2) = do
107+switchLoop02 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
108+switchLoop02 (e1, e2) = do
128109 rec
129110 e' <- connectButton e2 (updated d)
130111 d <- count (leftmost [e', e1])
131− return $ updated d
132−
112+ return $ updated d
133113
134−switchLoop2 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
135−switchLoop2 (e1, e2) = do
114+switchLoop03 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
115+switchLoop03 (e1, e2) = do
136116 rec
137117 e' <- connectButton e2 (addHeight $ updated d)
138118 d <- count (align e' e1)
139119 return $ updated d
140−
141120
142−staticLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
143−staticLoop (e1, e2) = do
121+staticLoop01 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
122+staticLoop01 (e1, e2) = do
144123 rec
145124 d <- foldDyn (+) (0 :: Int) (1 <$ align e1 (updated d))
146125 return $ updated d
147126
148−staticLoop' :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
149−staticLoop' (e1, e2) = do
127+staticLoop02 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
128+staticLoop02 (e1, e2) = do
150129 rec
151130 d <- foldDyn (+) (0 :: Int) (leftmost [e1, updated d])
152− return $ updated d
153−
131+ return $ updated d
154132
155133buildStaticLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
156134buildStaticLoop (e1, e2) = switchHold never buildLoop
157− where buildLoop = pushAlways (const $ staticLoop (e1, e2)) e2
135+ where buildLoop = pushAlways (const $ staticLoop01 (e1, e2)) e2
158136
159137splitThese :: Filterable f => f (These a b) -> (f a, f b)
160138splitThese f = (mapMaybe (preview here) f, mapMaybe (preview there) f)
161139
162−pattern RunTestCaseFlag = "--run-test"
163−
164−runTest :: (String, TestCase) -> IO ()
165−runTest (name, TestCase test) = do
166− putStrLn ("Test: " <> name)
167− mError <- timeout (milliseconds 5) $
168− run `catch` \(e :: EventLoopException) -> pure (show e)
169−
170− case mError of
171− Just err -> putStrLn err
172− Nothing -> error "timed out (loop not detected)"
173−
174− where
175−
176− run = do
177− r <- runApp' (test . splitThese) (Just <$> occs)
178− error (name <> ": unexpected success " <> show r)
179−
180− occs = [ This 1, This 2, That (), This 3, That (), This 1 ]
181−
182− milliseconds = (*1000)
183−
184−
185−newtype TestCase = TestCase { unTest :: forall t m. (Widget t m, Adjustable t m) => (Event t Int, Event t ()) -> m (Event t Int) }
186−
187−tests :: [(String, TestCase)]
188−tests =
189− [ ("switchLoop'", TestCase switchLoop')
190− , ("switchLoop", TestCase switchLoop)
191−
192− , ("mergeLoop", TestCase mergeLoop)
193−
194−
195− -- , ("switchLoop2", TestCase switchLoop2)
196−
197− -- , ("staticLoop'", TestCase staticLoop')
198− -- , ("staticLoop", TestCase staticLoop)
199− -- ("buildStaticLoop", TestCase buildStaticLoop)
200− -- , ("buildSwitchLoop", TestCase $ buildLoop switchLoop)
201−
202− -- ("coincidenceLoop", TestCase coincidenceLoop)
203− -- , ("dynLoop", TestCase dynLoop)
204− -- , ("buildCoincidenceLoop", TestCase $ buildLoop coincidenceLoop)
205− ]
206−
207140main :: IO ()
208−main = traverse_ runTest tests
209−
210−
211−
212−
213−
214−
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+2−1
@@ -18,9 +18,10 @@ 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
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/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− ]