on bf12730 help sign in
.github/workflows/haskell.ymldeleted−41
since splitsnapshots
unifiedsplit
@@ -1,41 +0,0 @@
1−name: github-action
2−
3−on: [push, pull_request]
4−
5−jobs:
6− build:
7− strategy:
8− matrix:
9− ghc: ['8.4.4', '8.6.5', '8.8.4', '8.10.2']
10− os: ['ubuntu-latest', 'macos-latest']
11− runs-on: ${{ matrix.os }}
12−
13− name: GHC ${{ matrix.ghc }} on ${{ matrix.os }}
14− steps:
15− - uses: actions/checkout@v2
16− - uses: actions/setup-haskell@v1
17− with:
18− ghc-version: ${{ matrix.ghc }}
19− - name: Cache
20− uses: actions/cache@v1
21− env:
22− cache-name: cache-cabal
23− with:
24− path: ~/.cabal
25− key: ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }}
26− restore-keys: |
27− ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-
28− ${{ runner.os }}-${{ matrix.ghc }}-build-
29− ${{ runner.os }}-${{ matrix.ghc }}-
30− ${{ runner.os }}
31−
32− - name: Install dependencies
33− run: |
34− cabal update
35− cabal build --only-dependencies --enable-tests --enable-benchmarks
36− - name: Build
37− run: cabal build --enable-tests --enable-benchmarks all
38− - name: Run tests
39− run: cabal test all
40− - name: Build Docs
41− run: cabal haddock
.travis.ymlnew file+177
@@ -0,0 +1,177 @@
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.8.1
32+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}}
33+ - compiler: ghc-8.6.5
34+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-2.4"]}}
35+ - compiler: ghc-8.4.4
36+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-2.4"]}}
37+ - compiler: ghc-8.2.2
38+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-2.4"]}}
39+ - compiler: ghc-8.0.2
40+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-2.4"]}}
41+before_install:
42+ - |
43+ if echo $CC | grep -q ghcjs; then
44+ GHCJS=true;
45+ else
46+ GHCJS=false;
47+ fi
48+ - |
49+ if [ "$TRAVIS_OS_NAME" = "linux" ]; then
50+ if $GHCJS ; then sudo add-apt-repository -y ppa:hvr/ghcjs ; fi;
51+ if $GHCJS ; then curl -s https://deb.nodesource.com/gpgkey/nodesource.gpg.key | sudo apt-key add - ; fi;
52+ if $GHCJS ; then sudo apt-add-repository 'https://deb.nodesource.com/node_8.x xenial main' ; fi;
53+ if $GHCJS ; then sudo apt-get update ; fi;
54+ sudo apt-get install $CC;
55+ if $GHCJS ; then sudo apt-get install -y nodejs cabal-install-3.0 ; fi;
56+ fi
57+ - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')
58+ - WITHCOMPILER="-w $HC"
59+ - if $GHCJS ; then HC=${HC}js ; fi
60+ - if $GHCJS ; then WITHCOMPILER="--ghcjs ${WITHCOMPILER}js" ; fi
61+ - if $GHCJS ; then sudo apt-get install -y ghc-8.4.4 ; fi
62+ - if $GHCJS ; then PATH="/opt/ghc/8.4.4/bin:$PATH" ; fi
63+ - HCPKG="$HC-pkg"
64+ - unset CC
65+ - CABAL=/opt/ghc/bin/cabal
66+ - CABALHOME=$HOME/.cabal
67+ - export PATH="$CABALHOME/bin:$PATH"
68+ - TOP=$(pwd)
69+ - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')"
70+ - echo $HCNUMVER
71+ - CABAL="$CABAL -vnormal+nowrap+markoutput"
72+ - set -o pipefail
73+ - |
74+ echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk
75+ echo 'BEGIN { state = "output"; }' >> .colorful.awk
76+ echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk
77+ echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk
78+ echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk
79+ echo ' if (state == "cabal") {' >> .colorful.awk
80+ echo ' print blue($0)' >> .colorful.awk
81+ echo ' } else {' >> .colorful.awk
82+ echo ' print $0' >> .colorful.awk
83+ echo ' }' >> .colorful.awk
84+ echo '}' >> .colorful.awk
85+ - cat .colorful.awk
86+ - |
87+ color_cabal_output () {
88+ awk -f $TOP/.colorful.awk
89+ }
90+ - echo text | color_cabal_output
91+install:
92+ - ${CABAL} --version
93+ - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
94+ - node --version
95+ - echo $GHCJS
96+ - TEST=--enable-tests
97+ - BENCH=--enable-benchmarks
98+ - BENCH=--disable-benchmarks
99+ - HEADHACKAGE=false
100+ - rm -f $CABALHOME/config
101+ - |
102+ echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config
103+ echo "remote-build-reporting: anonymous" >> $CABALHOME/config
104+ echo "write-ghc-environment-files: always" >> $CABALHOME/config
105+ echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config
106+ echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config
107+ echo "world-file: $CABALHOME/world" >> $CABALHOME/config
108+ echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config
109+ echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config
110+ echo "installdir: $CABALHOME/bin" >> $CABALHOME/config
111+ echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config
112+ echo "store-dir: $CABALHOME/store" >> $CABALHOME/config
113+ echo "install-dirs user" >> $CABALHOME/config
114+ echo " prefix: $CABALHOME" >> $CABALHOME/config
115+ echo "repository hackage.haskell.org" >> $CABALHOME/config
116+ echo " url: http://hackage.haskell.org/" >> $CABALHOME/config
117+ - cat $CABALHOME/config
118+ - rm -fv cabal.project cabal.project.local cabal.project.freeze
119+ - travis_retry ${CABAL} v2-update -v
120+ - if $GHCJS ; then (cd /tmp && ${CABAL} v2-install -w ghc-8.4.4 happy) ; fi
121+ # Generate cabal.project
122+ - rm -rf cabal.project cabal.project.local cabal.project.freeze
123+ - touch cabal.project
124+ - |
125+ echo "packages: ." >> cabal.project
126+ - |
127+ - cat cabal.project || true
128+ - cat cabal.project.local || true
129+ - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi
130+ - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output
131+ - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"
132+ - rm cabal.project.freeze
133+script:
134+ - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
135+ # Packaging...
136+ - ${CABAL} v2-sdist all | color_cabal_output
137+ # Unpacking...
138+ - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/
139+ - cd ${DISTDIR} || false
140+ - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;
141+ - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \;
142+ - PKGDIR_reflex="$(find . -maxdepth 1 -type d -regex '.*/reflex-[0-9.]*')"
143+ # Generate cabal.project
144+ - rm -rf cabal.project cabal.project.local cabal.project.freeze
145+ - touch cabal.project
146+ - |
147+ echo "packages: ${PKGDIR_reflex}" >> cabal.project
148+ - |
149+ - cat cabal.project || true
150+ - cat cabal.project.local || true
151+ # Building...
152+ # this builds all libraries and executables (without tests/benchmarks)
153+ - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output
154+ # Building with tests and benchmarks...
155+ # build & run tests, build benchmarks
156+ - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output
157+ # Testing...
158+ - if ! $GHCJS ; then ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi
159+ # cabal check...
160+ - (cd ${PKGDIR_reflex} && ${CABAL} -vnormal check)
161+ # haddock...
162+ - if ! $GHCJS ; then ${CABAL} v2-haddock $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi
163+ # Constraint sets
164+ - rm -rf cabal.project.local
165+ # Constraint set no-th
166+ - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='reflex -use-template-haskell' all | color_cabal_output
167+ # Constraint set old-these
168+ - if $GHCJS || ! $GHCJS && [ $HCNUMVER -lt 80800 ] ; then ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='these <1' all | color_cabal_output ; fi
169+ # Constraint set old-witherable
170+ - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='witherable <0.3.2' all | color_cabal_output
171+ # Constraint set debug-propagation
172+ - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='reflex +debug-propagation' all | color_cabal_output
173+ # Constraint set debug-cycles
174+ - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='reflex +debug-cycles' all | color_cabal_output
175+
176+# REGENDATA ["reflex.cabal","--config","cabal.haskell-ci"]
177+# EOF
ChangeLog.md+1−68
@@ -1,76 +1,9 @@
1# Revision history for reflex
1# Revision history for reflex
2
2
3−## 0.8.2.0
3+## Unreleased
4−
5−* Add `matchResponseMapWithRequests`, which it similar to `matchResponsesWithRequests` but allows processing of multiple responses at once.
6−
7−## 0.8.1.1
8−
9−* Allow newer hlint for older GHCs, and add upper bound for newer GHCs
10−
11−## 0.8.1.0
12−
13−* Add support for GHC 8.10
14−* Drop support for GHC < 8.4
15−
16−## 0.8.0.0
17−
18−* Replace 0.7.2.0 with 0.8.0.0 to reflect the `MonadHold` interface change. Deprecates 0.7.2.0.
19−
20−## 0.7.2.0 -- *Deprecated*
21−
22−* ([#416](https://github.com/reflex-frp/reflex/pull/416)) Add `now :: m (Event t ())` to `MonadHold`.
23−* Extend some dependency version bounds
24−* Fix HLint 3 test
25−
26−## 0.7.1.1
27−
28−*Backport release*.
29−Changes do not carry forward to 0.7.2.0.
30−
31−* Add support for GHC 8.10
32−* Drop support for GHC < 8.4
33−* Extend some dependency version bounds
34−* Fix HLint 3 test
35−
36−## 0.7.1.0
37−
38−* ([#413](https://github.com/reflex-frp/reflex/pull/413), [#417](https://github.com/reflex-frp/reflex/pull/417)) Add `Reflex.Host.Headless` module which provides `runHeadlessApp` as an easy way to run a Reflex network in a "headless" environment.
39−* ([#420](https://github.com/reflex-frp/reflex/pull/420)) Add a [`Data.Zip.Unzip`](https://hackage.haskell.org/package/semialign-1.1/docs/Data-Zip.html#t:Unzip) instance for `Event`.
40−* ([#419](https://github.com/reflex-frp/reflex/pull/419)) Add `distributeIntMapOverDynPure` and `joinDynThroughIntMap` as convenience functions for working with `Dynamic` `IntMap`s.
41−
42−
43−## 0.7.0.0
44−
45−* Add lifting instances for most classes to `Reflex.Profiled.Profiled`. ([#398](https://github.com/reflex-frp/reflex/pull/398))
46−* Class `MonadQuery t q m` now has a `Monad m` superclass constraint. ([#400](https://github.com/reflex-frp/reflex/pull/400))
47−* **(Breaking change)** Rename class `MonadBehaviorWriter` -> `BehaviorWriter` for consistency with `EventWriter`/`DynamicWriter`. ([#401](https://github.com/reflex-frp/reflex/pull/401))
48−* Introduce deprecated alias `MonadBehaviorWriter = BehaviorWriter`. ([#401](https://github.com/reflex-frp/reflex/pull/401))
49−* Fix bug in spider where event subscriptions would be prematurely finalized due to over-aggressive inlining. ([#409](https://github.com/reflex-frp/reflex/pull/409))
50−* Add instances of `PerformEvent` and `TriggerEvent` for `MaybeT`. ([#395](https://github.com/reflex-frp/reflex/pull/395))
51−
52−## 0.6.4.1
53−
54−* Fix a bug in the Reflex Profiled transformer where
55− `Reflex.Class.mergeIncrementalG` and
56− `Reflex.Class.mergeIncrementalWithMoveG` implementations referenced
57− itself instead of the inner transformed timeline, causing an
58− infinite loop.
59−
60−## 0.6.4
61−
62−* Support GHC 8.8
63
4
64* Add `Reflex.Query.Base.mapQueryT`. See that module for documentation
5* Add `Reflex.Query.Base.mapQueryT`. See that module for documentation
65
6
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
7## 0.6.3
75
8
76* `Data.WeakBag.traverse` and `Data.FastWeakBag.traverse` have been deprecated.
9* `Data.WeakBag.traverse` and `Data.FastWeakBag.traverse` have been deprecated.
Quickref.md−1
@@ -54,7 +54,6 @@ Since MonadHold depends on MonadSample, any [S] function also runs in [H] contex
54[ ] difference :: Event a -> Event b -> Event a
54[ ] difference :: Event a -> Event b -> Event a
55[ ] align :: Event a -> Event b -> Event (These a b)
55[ ] align :: Event a -> Event b -> Event (These a b)
56[ ] alignWith :: (These a b -> c) -> Event a -> Event b -> Event c
56[ ] alignWith :: (These a b -> c) -> Event a -> Event b -> Event c
57− -- Note align functions from Data.Align in semialign package
58[ ] mergeWith :: (a -> a -> a) -> [Event a] -> Event a
57[ ] mergeWith :: (a -> a -> a) -> [Event a] -> Event a
59[ ] leftmost :: [Event a] -> Event a
58[ ] leftmost :: [Event a] -> Event a
60[ ] mergeList :: [Event a] -> Event (NonEmpty a)
59[ ] mergeList :: [Event a] -> Event (NonEmpty a)
README.md+17−15
@@ -1,23 +1,25 @@
1−# [Reflex](https://reflex-frp.org/)
1+## [Reflex](https://reflex-frp.org/)
2
2
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)
3+[![Hackage](https://img.shields.io/hackage/v/reflex.svg)](http://hackage.haskell.org/package/reflex)
4
4
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.
5+### Practical Functional Reactive Programming
6
6
7−Reflex is a fully-deterministic, higher-order Functional Reactive Programming interface and an engine that efficiently implements that interface.
7+Reflex is a fully-deterministic, higher-order Functional Reactive Programming (FRP) interface and an engine that efficiently implements that interface.
8
8
9−**Visit https://reflex-frp.org for more information, tutorials, documentation and [examples](https://examples.reflex-frp.org/).**
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.
10
10
11−## Resources
11+A summary of Reflex functions is available in the [quick reference](Quickref.md).
12
12
13−* [Official Website](https://reflex-frp.org)
13+**Visit https://reflex-frp.org/ for more information, tutorials, documentation and [examples](https://examples.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)
20
14
21−## Hacking
15+### Resources
16+[Get started with Reflex](https://github.com/reflex-frp/reflex-platform)
22
17
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.
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.
dep/reflex-platform/github.json+3−3
@@ -1,7 +1,7 @@
1{
1{
2 "owner": "reflex-frp",
2 "owner": "reflex-frp",
3 "repo": "reflex-platform",
3 "repo": "reflex-platform",
4− "branch": "develop",
4+ "branch": "master",
5− "rev": "f628398d076243a0851b27e625b37f65dff9b89b",
5+ "rev": "510b990d0b11f0626afbec5fe8575b5b2395391b",
6− "sha256": "0sl0hf1glgyb1vmf2mhw4r9ipmcqk1y19d3wsic7dix2jwywzrh9"
6+ "sha256": "09cmahsbxr0963wq171c7j139iyzz49hramr4v9nsf684wcwkngv"
7}
7}
reflex.cabal+35−93
@@ -1,17 +1,7 @@
1Name: reflex
1Name: reflex
2−Version: 0.8.2.0
2+Version: 0.6.3
3Synopsis: Higher-order Functional Reactive Programming
3Synopsis: Higher-order Functional Reactive Programming
4−Description:
5− Interactive programs without callbacks or side-effects.
6− Functional Reactive Programming (FRP) uses composable events and time-varying
7− values to describe interactive systems as pure functions.
8− Just like other pure functional code, functional reactive code is easier
9− to get right on the first try, maintain, and reuse.
10− .
11− Reflex is a fully-deterministic, higher-order Functional Reactive Programming
4+Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system
12− interface and an engine that efficiently implements that interface.
13− .
14− <https://reflex-frp.org>
15License: BSD3
5License: BSD3
16License-file: LICENSE
6License-file: LICENSE
17Author: Ryan Trinkle
7Author: Ryan Trinkle
@@ -19,7 +9,7 @@ Maintainer: ryan.trinkle@gmail.com
19Stability: Experimental
9Stability: Experimental
20Category: FRP
10Category: FRP
21Build-type: Simple
11Build-type: Simple
22−Cabal-version: 1.22
12+Cabal-version: >=1.9.2
23homepage: https://reflex-frp.org
13homepage: https://reflex-frp.org
24bug-reports: https://github.com/reflex-frp/reflex/issues
14bug-reports: https://github.com/reflex-frp/reflex/issues
25extra-source-files:
15extra-source-files:
@@ -28,8 +18,8 @@ extra-source-files:
28 ChangeLog.md
18 ChangeLog.md
29
19
30tested-with:
20tested-with:
31− GHC ==8.4.4 || ==8.6.5 || ==8.8.1 || ==8.10.2,
21+ GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.1,
32− GHCJS ==8.6
22+ GHCJS ==8.4
33
23
34flag use-reflex-optimizer
24flag use-reflex-optimizer
35 description: Use the GHC plugin Reflex.Optimizer on some of the modules in the package. This is still experimental.
25 description: Use the GHC plugin Reflex.Optimizer on some of the modules in the package. This is still experimental.
@@ -61,33 +51,30 @@ flag debug-cycles
61 default: False
51 default: False
62 manual: True
52 manual: True
63
53
54+
64flag split-these
55flag split-these
65 description: Use split these/semialign packages
56 description: Use split these/semialign packages
66 manual: False
57 manual: False
67 default: True
58 default: True
68
59
69library
60library
70− default-language: Haskell2010
71 hs-source-dirs: src
61 hs-source-dirs: src
72 build-depends:
62 build-depends:
73 MemoTrie == 0.6.*,
63 MemoTrie == 0.6.*,
74− base >= 4.11 && < 4.15,
64+ base >= 4.9 && < 4.14,
75 bifunctors >= 5.2 && < 5.6,
65 bifunctors >= 5.2 && < 5.6,
76 comonad >= 5.0.4 && < 5.1,
66 comonad >= 5.0.4 && < 5.1,
77− constraints >= 0.10 && <0.14,
78 constraints-extras >= 0.3 && < 0.4,
67 constraints-extras >= 0.3 && < 0.4,
79 containers >= 0.6 && < 0.7,
68 containers >= 0.6 && < 0.7,
80 data-default >= 0.5 && < 0.8,
69 data-default >= 0.5 && < 0.8,
81− dependent-map >= 0.3 && < 0.5,
70+ dependent-map >= 0.3 && < 0.4,
82 exception-transformers == 0.4.*,
71 exception-transformers == 0.4.*,
83 lens >= 4.7 && < 5,
72 lens >= 4.7 && < 5,
84− mmorph >= 1.0 && < 1.2,
85 monad-control >= 1.0.1 && < 1.1,
73 monad-control >= 1.0.1 && < 1.1,
86 mtl >= 2.1 && < 2.3,
74 mtl >= 2.1 && < 2.3,
87− patch >= 0.0.1 && < 0.1,
88− prim-uniq >= 0.1.0.1 && < 0.3,
75+ prim-uniq >= 0.1.0.1 && < 0.2,
89 primitive >= 0.5 && < 0.8,
76 primitive >= 0.5 && < 0.8,
90− profunctors >= 5.3 && < 5.7,
77+ profunctors >= 5.3 && < 5.6,
91 random == 1.1.*,
78 random == 1.1.*,
92 ref-tf == 0.4.*,
79 ref-tf == 0.4.*,
93 reflection == 2.1.*,
80 reflection == 2.1.*,
@@ -97,10 +84,10 @@ library
97 time >= 1.4 && < 1.10,
84 time >= 1.4 && < 1.10,
98 transformers >= 0.5.6.0 && < 0.6,
85 transformers >= 0.5.6.0 && < 0.6,
99 unbounded-delays >= 0.1.0.0 && < 0.2,
86 unbounded-delays >= 0.1.0.0 && < 0.2,
100− witherable >= 0.3 && < 0.5
87+ witherable >= 0.3 && < 0.3.2
101
88
102 if flag(split-these)
89 if flag(split-these)
103− build-depends: these >= 1 && <1.2,
90+ build-depends: these >= 1 && <1.1,
104 semialign >=1 && <1.2,
91 semialign >=1 && <1.2,
105 monoidal-containers >= 0.6 && < 0.7
92 monoidal-containers >= 0.6 && < 0.7
106 else
93 else
@@ -112,6 +99,7 @@ library
112 Data.AppendMap,
99 Data.AppendMap,
113 Data.FastMutableIntMap,
100 Data.FastMutableIntMap,
114 Data.FastWeakBag,
101 Data.FastWeakBag,
102+ Data.Functor.Misc,
115 Data.Map.Misc,
103 Data.Map.Misc,
116 Data.WeakBag,
104 Data.WeakBag,
117 Reflex,
105 Reflex,
@@ -131,9 +119,15 @@ library
131 Reflex.FastWeak,
119 Reflex.FastWeak,
132 Reflex.FunctorMaybe,
120 Reflex.FunctorMaybe,
133 Reflex.Host.Class,
121 Reflex.Host.Class,
134− Reflex.Host.Headless,
135 Reflex.Network,
122 Reflex.Network,
136 Reflex.NotReady.Class,
123 Reflex.NotReady.Class,
124+ Reflex.Patch,
125+ Reflex.Patch.Class,
126+ Reflex.Patch.DMap,
127+ Reflex.Patch.DMapWithMove,
128+ Reflex.Patch.IntMap,
129+ Reflex.Patch.Map,
130+ Reflex.Patch.MapWithMove,
137 Reflex.PerformEvent.Base,
131 Reflex.PerformEvent.Base,
138 Reflex.PerformEvent.Class,
132 Reflex.PerformEvent.Class,
139 Reflex.PostBuild.Base,
133 Reflex.PostBuild.Base,
@@ -152,22 +146,12 @@ library
152 Reflex.Widget.Basic,
146 Reflex.Widget.Basic,
153 Reflex.Workflow
147 Reflex.Workflow
154
148
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
149+ -- ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively
150+ ghc-options: -O0
166
151
167 if flag(debug-trace-events)
152 if flag(debug-trace-events)
168 cpp-options: -DDEBUG_TRACE_EVENTS
153 cpp-options: -DDEBUG_TRACE_EVENTS
169− build-depends:
154+ build-depends: bytestring
170− bytestring >= 0.10.8 && < 0.11
171
155
172 if flag(use-reflex-optimizer)
156 if flag(use-reflex-optimizer)
173 cpp-options: -DUSE_REFLEX_OPTIMIZER
157 cpp-options: -DUSE_REFLEX_OPTIMIZER
@@ -175,7 +159,7 @@ library
175 exposed-modules: Reflex.Optimizer
159 exposed-modules: Reflex.Optimizer
176
160
177 if flag(debug-propagation)
161 if flag(debug-propagation)
178− cpp-options: -DDEBUG -DDEBUG_TRACE_PROPAGATION -DDEBUG_TRACE_INVALIDATION
162+ cpp-options: -DDEBUG
179
163
180 if flag(debug-cycles)
164 if flag(debug-cycles)
181 cpp-options: -DDEBUG_CYCLES
165 cpp-options: -DDEBUG_CYCLES
@@ -183,26 +167,26 @@ library
183 if flag(use-template-haskell)
167 if flag(use-template-haskell)
184 cpp-options: -DUSE_TEMPLATE_HASKELL
168 cpp-options: -DUSE_TEMPLATE_HASKELL
185 build-depends:
169 build-depends:
186− dependent-sum >= 0.6 && < 0.8,
170+ dependent-sum >= 0.6 && < 0.7,
187− haskell-src-exts >= 1.16 && < 1.24,
171+ haskell-src-exts >= 1.16 && < 1.23,
188 haskell-src-meta >= 0.6 && < 0.9,
172 haskell-src-meta >= 0.6 && < 0.9,
189− template-haskell >= 2.9 && < 2.17
173+ template-haskell >= 2.9 && < 2.16
190 exposed-modules:
174 exposed-modules:
191 Reflex.Dynamic.TH
175 Reflex.Dynamic.TH
192 other-extensions: TemplateHaskell
176 other-extensions: TemplateHaskell
193 else
177 else
194 build-depends:
178 build-depends:
195− dependent-sum >= 0.6 && < 0.8
179+ dependent-sum >= 0.6 && < 0.7
196
180
197 if flag(fast-weak) && impl(ghcjs)
181 if flag(fast-weak) && impl(ghcjs)
198 cpp-options: -DGHCJS_FAST_WEAK
182 cpp-options: -DGHCJS_FAST_WEAK
199
183
200 if impl(ghcjs)
184 if impl(ghcjs)
201− build-depends:
185+ build-depends: ghcjs-base
202− ghcjs-base == 0.2.*
186+
187+
203
188
204test-suite semantics
189test-suite semantics
205− default-language: Haskell2010
206 type: exitcode-stdio-1.0
190 type: exitcode-stdio-1.0
207 main-is: semantics.hs
191 main-is: semantics.hs
208 hs-source-dirs: test
192 hs-source-dirs: test
@@ -228,7 +212,6 @@ test-suite semantics
228 Reflex.TestPlan
212 Reflex.TestPlan
229
213
230test-suite CrossImpl
214test-suite CrossImpl
231− default-language: Haskell2010
232 type: exitcode-stdio-1.0
215 type: exitcode-stdio-1.0
233 main-is: Reflex/Test/CrossImpl.hs
216 main-is: Reflex/Test/CrossImpl.hs
234 hs-source-dirs: test
217 hs-source-dirs: test
@@ -250,7 +233,6 @@ test-suite CrossImpl
250 Reflex.Plan.Pure
233 Reflex.Plan.Pure
251
234
252test-suite hlint
235test-suite hlint
253− default-language: Haskell2010
254 type: exitcode-stdio-1.0
236 type: exitcode-stdio-1.0
255 main-is: hlint.hs
237 main-is: hlint.hs
256 hs-source-dirs: test
238 hs-source-dirs: test
@@ -258,15 +240,11 @@ test-suite hlint
258 , directory
240 , directory
259 , filepath
241 , filepath
260 , filemanip
242 , filemanip
261− if impl(ghc >= 8.8)
262− build-depends: hlint >= 3 && < 4
263− else
264− build-depends: hlint (< 2.1 || >= 2.2.2) && < 4
243+ , hlint < 2.1 || >= 2.2.2
265 if impl(ghcjs)
244 if impl(ghcjs)
266 buildable: False
245 buildable: False
267
246
268test-suite EventWriterT
247test-suite EventWriterT
269− default-language: Haskell2010
270 type: exitcode-stdio-1.0
248 type: exitcode-stdio-1.0
271 main-is: EventWriterT.hs
249 main-is: EventWriterT.hs
272 hs-source-dirs: test
250 hs-source-dirs: test
@@ -290,7 +268,6 @@ test-suite EventWriterT
290
268
291
269
292test-suite DebugCycles
270test-suite DebugCycles
293− default-language: Haskell2010
294 type: exitcode-stdio-1.0
271 type: exitcode-stdio-1.0
295 main-is: DebugCycles.hs
272 main-is: DebugCycles.hs
296 hs-source-dirs: test
273 hs-source-dirs: test
@@ -300,7 +277,6 @@ test-suite DebugCycles
300 , deepseq
277 , deepseq
301 , dependent-map
278 , dependent-map
302 , dependent-sum
279 , dependent-sum
303− , hspec
304 , lens
280 , lens
305 , mtl
281 , mtl
306 , these
282 , these
@@ -319,24 +295,20 @@ test-suite DebugCycles
319
295
320
296
321test-suite RequesterT
297test-suite RequesterT
322− default-language: Haskell2010
323 type: exitcode-stdio-1.0
298 type: exitcode-stdio-1.0
324 main-is: RequesterT.hs
299 main-is: RequesterT.hs
325 hs-source-dirs: test
300 hs-source-dirs: test
326 build-depends: base
301 build-depends: base
327− , constraints
328− , constraints-extras
329 , containers
302 , containers
330 , deepseq
303 , deepseq
331− , dependent-map
332 , dependent-sum
304 , dependent-sum
305+ , dependent-map
333 , lens
306 , lens
334 , mtl
307 , mtl
335− , ref-tf
336− , reflex
337− , text
338 , these
308 , these
339 , transformers
309 , transformers
310+ , reflex
311+ , ref-tf
340
312
341 if flag(split-these)
313 if flag(split-these)
342 build-depends: these-lens
314 build-depends: these-lens
@@ -346,31 +318,7 @@ test-suite RequesterT
346 Reflex.Plan.Pure
318 Reflex.Plan.Pure
347 Test.Run
319 Test.Run
348
320
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−
372test-suite QueryT
321test-suite QueryT
373− default-language: Haskell2010
374 type: exitcode-stdio-1.0
322 type: exitcode-stdio-1.0
375 main-is: QueryT.hs
323 main-is: QueryT.hs
376 hs-source-dirs: test
324 hs-source-dirs: test
@@ -382,7 +330,6 @@ test-suite QueryT
382 , lens
330 , lens
383 , monoidal-containers
331 , monoidal-containers
384 , mtl
332 , mtl
385− , patch
386 , ref-tf
333 , ref-tf
387 , reflex
334 , reflex
388 , these
335 , these
@@ -398,7 +345,6 @@ test-suite QueryT
398 Reflex.Plan.Pure
345 Reflex.Plan.Pure
399
346
400test-suite GC-Semantics
347test-suite GC-Semantics
401− default-language: Haskell2010
402 type: exitcode-stdio-1.0
348 type: exitcode-stdio-1.0
403 main-is: GC.hs
349 main-is: GC.hs
404 hs-source-dirs: test
350 hs-source-dirs: test
@@ -408,7 +354,6 @@ test-suite GC-Semantics
408 , dependent-map
354 , dependent-map
409 , deepseq
355 , deepseq
410 , mtl
356 , mtl
411− , patch
412 , these
357 , these
413 , transformers
358 , transformers
414 , reflex
359 , reflex
@@ -424,7 +369,6 @@ test-suite GC-Semantics
424 Test.Run
369 Test.Run
425
370
426test-suite rootCleanup
371test-suite rootCleanup
427− default-language: Haskell2010
428 type: exitcode-stdio-1.0
372 type: exitcode-stdio-1.0
429 main-is: rootCleanup.hs
373 main-is: rootCleanup.hs
430 hs-source-dirs: test
374 hs-source-dirs: test
@@ -442,7 +386,6 @@ test-suite rootCleanup
442 Test.Run
386 Test.Run
443
387
444benchmark spider-bench
388benchmark spider-bench
445− default-language: Haskell2010
446 type: exitcode-stdio-1.0
389 type: exitcode-stdio-1.0
447 hs-source-dirs: bench test
390 hs-source-dirs: bench test
448 main-is: Main.hs
391 main-is: Main.hs
@@ -467,7 +410,6 @@ benchmark spider-bench
467 Reflex.Bench.Focused
410 Reflex.Bench.Focused
468
411
469benchmark saulzar-bench
412benchmark saulzar-bench
470− default-language: Haskell2010
471 type: exitcode-stdio-1.0
413 type: exitcode-stdio-1.0
472 hs-source-dirs: bench test
414 hs-source-dirs: bench test
473 c-sources: bench-cbits/checkCapability.c
415 c-sources: bench-cbits/checkCapability.c
release.nix+2−2
@@ -1,12 +1,12 @@
1{ reflex-platform-fun ? import ./dep/reflex-platform
1{ reflex-platform-fun ? import ./dep/reflex-platform
2−, supportedSystems ? ["x86_64-linux" "x86_64-darwin"]
3}:
2}:
4
3
5let
4let
6 native-reflex-platform = reflex-platform-fun {};
5 native-reflex-platform = reflex-platform-fun {};
7 inherit (native-reflex-platform.nixpkgs) lib;
6 inherit (native-reflex-platform.nixpkgs) lib;
7+ systems = ["x86_64-linux" "x86_64-darwin"];
8
8
9− perPlatform = lib.genAttrs supportedSystems (system: let
9+ perPlatform = lib.genAttrs systems (system: let
10 reflex-platform = reflex-platform-fun { inherit system; };
10 reflex-platform = reflex-platform-fun { inherit system; };
11 compilers = [
11 compilers = [
12 "ghc"
12 "ghc"
src/Data/AppendMap.hs+1−1
@@ -71,7 +71,7 @@ mapMaybeNoNull f as =
71 then Nothing
71 then Nothing
72 else Just bs
72 else Just bs
73
73
74−-- TODO: Move instances to `Data.Patch`
74+-- TODO: Move instances to `Reflex.Patch`
75-- | Displays a 'MonoidalMap' as a tree. See 'Data.Map.Lazy.showTree' for details.
75-- | Displays a 'MonoidalMap' as a tree. See 'Data.Map.Lazy.showTree' for details.
76showTree :: forall k a. (Show k, Show a) => MonoidalMap k a -> String
76showTree :: forall k a. (Show k, Show a) => MonoidalMap k a -> String
77showTree = coerce (Map.showTree :: Map k a -> String)
77showTree = coerce (Map.showTree :: Map k a -> String)
src/Data/FastMutableIntMap.hs+3−3
@@ -35,8 +35,8 @@ import Data.Foldable (traverse_)
35import Data.IntMap.Strict (IntMap)
35import Data.IntMap.Strict (IntMap)
36import qualified Data.IntMap.Strict as IntMap
36import qualified Data.IntMap.Strict as IntMap
37import Data.IORef
37import Data.IORef
38−import Data.Patch.Class
38+import Reflex.Patch.Class
39−import Data.Patch.IntMap
39+import Reflex.Patch.IntMap
40
40
41-- | A 'FastMutableIntMap' holds a map of values of type @a@ and allows low-overhead modifications via IO.
41-- | A 'FastMutableIntMap' holds a map of values of type @a@ and allows low-overhead modifications via IO.
42-- Operations on 'FastMutableIntMap' run in IO.
42-- Operations on 'FastMutableIntMap' run in IO.
@@ -85,7 +85,7 @@ getFrozenAndClear (FastMutableIntMap r) = do
85 writeIORef r IntMap.empty
85 writeIORef r IntMap.empty
86 return result
86 return result
87
87
88−-- | Updates the value of a 'FastMutableIntMap' with the given patch (see 'Data.Patch.IntMap'),
88+-- | Updates the value of a 'FastMutableIntMap' with the given patch (see 'Reflex.Patch.IntMap'),
89-- and returns an 'IntMap' with the modified keys and values.
89-- and returns an 'IntMap' with the modified keys and values.
90applyPatch :: FastMutableIntMap a -> PatchIntMap a -> IO (IntMap a)
90applyPatch :: FastMutableIntMap a -> PatchIntMap a -> IO (IntMap a)
91applyPatch (FastMutableIntMap r) p@(PatchIntMap m) = do
91applyPatch (FastMutableIntMap r) p@(PatchIntMap m) = do
src/Data/Functor/Misc.hsnew file+235
@@ -0,0 +1,235 @@
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.Type.Equality ((:~:)(Refl))
57+import Data.Typeable hiding (Refl)
58+
59+--------------------------------------------------------------------------------
60+-- Const2
61+--------------------------------------------------------------------------------
62+
63+-- | 'Const2' stores a value of a given type 'k' and ensures that a particular
64+-- type 'v' is always given for the last type parameter
65+data Const2 :: * -> x -> x -> * where
66+ Const2 :: k -> Const2 k v v
67+ deriving (Typeable)
68+
69+-- | Extract the value from a Const2
70+unConst2 :: Const2 k v v' -> k
71+unConst2 (Const2 k) = k
72+
73+deriving instance Eq k => Eq (Const2 k v v')
74+deriving instance Ord k => Ord (Const2 k v v')
75+deriving instance Show k => Show (Const2 k v v')
76+deriving instance Read k => Read (Const2 k v v)
77+
78+instance Show k => GShow (Const2 k v) where
79+ gshowsPrec n x@(Const2 _) = showsPrec n x
80+
81+instance Eq k => GEq (Const2 k v) where
82+ geq (Const2 a) (Const2 b) =
83+ if a == b
84+ then Just Refl
85+ else Nothing
86+
87+instance Ord k => GCompare (Const2 k v) where
88+ gcompare (Const2 a) (Const2 b) = case compare a b of
89+ LT -> GLT
90+ EQ -> GEQ
91+ GT -> GGT
92+
93+-- | Convert a 'DMap' to a regular 'Map'
94+dmapToMap :: DMap (Const2 k v) Identity -> Map k v
95+dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList
96+
97+-- | Convert a 'DMap' to an 'IntMap'
98+dmapToIntMap :: DMap (Const2 IntMap.Key v) Identity -> IntMap v
99+dmapToIntMap = IntMap.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList
100+
101+-- | Convert a 'DMap' to a regular 'Map', applying the given function to remove
102+-- the wrapping 'Functor'
103+dmapToMapWith :: (f v -> v') -> DMap (Const2 k v) f -> Map k v'
104+dmapToMapWith f = Map.fromDistinctAscList . map (\(Const2 k :=> v) -> (k, f v)) . DMap.toAscList
105+
106+-- | Convert a regular 'Map' to a 'DMap'
107+mapToDMap :: Map k v -> DMap (Const2 k v) Identity
108+mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> Identity v) . Map.toAscList
109+
110+-- | Convert a regular 'Map', where the values are already wrapped in a functor,
111+-- to a 'DMap'
112+mapWithFunctorToDMap :: Map k (f v) -> DMap (Const2 k v) f
113+mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . Map.toAscList
114+
115+-- | Convert a regular 'IntMap', where the values are already wrapped in a
116+-- functor, to a 'DMap'
117+intMapWithFunctorToDMap :: IntMap (f v) -> DMap (Const2 IntMap.Key v) f
118+intMapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . IntMap.toAscList
119+
120+-- | Convert a 'DMap' to a regular 'Map' by forgetting the types associated with
121+-- the keys, using a function to remove the wrapping 'Functor'
122+weakenDMapWith :: (forall a. v a -> v') -> DMap k v -> Map (Some k) v'
123+weakenDMapWith f = Map.fromDistinctAscList . map (\(k :=> v) -> (Some k, f v)) . DMap.toAscList
124+
125+--------------------------------------------------------------------------------
126+-- WrapArg
127+--------------------------------------------------------------------------------
128+
129+-- | 'WrapArg' can be used to tag a value in one functor with a type
130+-- representing another functor. This was primarily used with dependent-map <
131+-- 0.2, in which the value type was not wrapped in a separate functor.
132+data WrapArg :: (k -> *) -> (k -> *) -> * -> * where
133+ WrapArg :: f a -> WrapArg g f (g a)
134+
135+deriving instance Eq (f a) => Eq (WrapArg g f (g' a))
136+deriving instance Ord (f a) => Ord (WrapArg g f (g' a))
137+deriving instance Show (f a) => Show (WrapArg g f (g' a))
138+deriving instance Read (f a) => Read (WrapArg g f (g a))
139+
140+instance GEq f => GEq (WrapArg g f) where
141+ geq (WrapArg a) (WrapArg b) = (\Refl -> Refl) <$> geq a b
142+
143+instance GCompare f => GCompare (WrapArg g f) where
144+ gcompare (WrapArg a) (WrapArg b) = case gcompare a b of
145+ GLT -> GLT
146+ GEQ -> GEQ
147+ GGT -> GGT
148+
149+--------------------------------------------------------------------------------
150+-- Convenience functions for DMap
151+--------------------------------------------------------------------------------
152+
153+-- | Map over all key/value pairs in a 'DMap', potentially altering the key as
154+-- well as the value. The provided function MUST preserve the ordering of the
155+-- keys, or the resulting 'DMap' will be malformed.
156+mapKeyValuePairsMonotonic :: (DSum k v -> DSum k' v') -> DMap k v -> DMap k' v'
157+mapKeyValuePairsMonotonic f = DMap.fromDistinctAscList . map f . DMap.toAscList
158+
159+{-# INLINE combineDMapsWithKey #-}
160+-- | Union two 'DMap's of different types, yielding another type. Each key that
161+-- is present in either input map will be present in the output.
162+combineDMapsWithKey :: forall f g h i.
163+ GCompare f
164+ => (forall a. f a -> These (g a) (h a) -> i a)
165+ -> DMap f g
166+ -> DMap f h
167+ -> DMap f i
168+combineDMapsWithKey f mg mh = DMap.fromList $ go (DMap.toList mg) (DMap.toList mh)
169+ where go :: [DSum f g] -> [DSum f h] -> [DSum f i]
170+ go [] hs = map (\(hk :=> hv) -> hk :=> f hk (That hv)) hs
171+ go gs [] = map (\(gk :=> gv) -> gk :=> f gk (This gv)) gs
172+ go gs@((gk :=> gv) : gs') hs@((hk :=> hv) : hs') = case gk `gcompare` hk of
173+ GLT -> (gk :=> f gk (This gv)) : go gs' hs
174+ GEQ -> (gk :=> f gk (These gv hv)) : go gs' hs'
175+ GGT -> (hk :=> f hk (That hv)) : go gs hs'
176+
177+-- | Extract the values of a 'DMap' of 'EitherTag's.
178+dmapToThese :: DMap (EitherTag a b) Identity -> Maybe (These a b)
179+dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of
180+ (Nothing, Nothing) -> Nothing
181+ (Just (Identity a), Nothing) -> Just $ This a
182+ (Nothing, Just (Identity b)) -> Just $ That b
183+ (Just (Identity a), Just (Identity b)) -> Just $ These a b
184+
185+-- | Tag type for 'Either' to use it as a 'DSum'.
186+data EitherTag l r a where
187+ LeftTag :: EitherTag l r l
188+ RightTag :: EitherTag l r r
189+ deriving (Typeable)
190+
191+deriving instance Show (EitherTag l r a)
192+deriving instance Eq (EitherTag l r a)
193+deriving instance Ord (EitherTag l r a)
194+
195+instance GEq (EitherTag l r) where
196+ geq a b = case (a, b) of
197+ (LeftTag, LeftTag) -> Just Refl
198+ (RightTag, RightTag) -> Just Refl
199+ _ -> Nothing
200+
201+instance GCompare (EitherTag l r) where
202+ gcompare a b = case (a, b) of
203+ (LeftTag, LeftTag) -> GEQ
204+ (LeftTag, RightTag) -> GLT
205+ (RightTag, LeftTag) -> GGT
206+ (RightTag, RightTag) -> GEQ
207+
208+instance GShow (EitherTag l r) where
209+ gshowsPrec _ a = case a of
210+ LeftTag -> showString "LeftTag"
211+ RightTag -> showString "RightTag"
212+
213+-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.
214+eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity
215+eitherToDSum = \case
216+ Left a -> (LeftTag :=> Identity a)
217+ Right b -> (RightTag :=> Identity b)
218+
219+-- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'.
220+dsumToEither :: DSum (EitherTag a b) Identity -> Either a b
221+dsumToEither = \case
222+ (LeftTag :=> Identity a) -> Left a
223+ (RightTag :=> Identity b) -> Right b
224+
225+--------------------------------------------------------------------------------
226+-- ComposeMaybe
227+--------------------------------------------------------------------------------
228+
229+-- | We can't use @Compose Maybe@ instead of 'ComposeMaybe', because that would
230+-- make the 'f' parameter have a nominal type role. We need f to be
231+-- representational so that we can use safe 'coerce'.
232+newtype ComposeMaybe f a =
233+ ComposeMaybe { getComposeMaybe :: Maybe (f a) } deriving (Show, Eq, Ord)
234+
235+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
43
43
44-- |Given a @'Map' k (Maybe v)@ representing keys to insert/update (@Just@) or delete (@Nothing@), produce a new map from the given input @'Map' k v@.
44-- |Given a @'Map' k (Maybe v)@ representing keys to insert/update (@Just@) or delete (@Nothing@), produce a new map from the given input @'Map' k v@.
45--
45--
46−-- See also 'Data.Patch.Map' and 'Data.Patch.MapWithMove'.
46+-- See also 'Reflex.Patch.Map' and 'Reflex.Patch.MapWithMove'.
47applyMap :: Ord k => Map k (Maybe v) -> Map k v -> Map k v
47applyMap :: Ord k => Map k (Maybe v) -> Map k v -> Map k v
48applyMap patch old = insertions `Map.union` (old `Map.difference` deletions)
48applyMap patch old = insertions `Map.union` (old `Map.difference` deletions)
49 where (deletions, insertions) = Map.mapEither maybeToEither patch
49 where (deletions, insertions) = Map.mapEither maybeToEither patch
src/Reflex/Adjustable/Class.hs+2−3
@@ -30,8 +30,7 @@ module Reflex.Adjustable.Class
30
30
31import Control.Monad.Identity
31import Control.Monad.Identity
32import Control.Monad.Reader
32import Control.Monad.Reader
33−import Data.Dependent.Map (DMap)
33+import Data.Dependent.Map (DMap, GCompare (..))
34−import Data.GADT.Compare (GCompare(..))
35import qualified Data.Dependent.Map as DMap
34import qualified Data.Dependent.Map as DMap
36import Data.Functor.Constant
35import Data.Functor.Constant
37import Data.Functor.Misc
36import Data.Functor.Misc
@@ -40,7 +39,7 @@ import qualified Data.IntMap.Strict as IntMap
40import Data.Map (Map)
39import Data.Map (Map)
41
40
42import Reflex.Class
41import Reflex.Class
43−import Data.Patch.DMapWithMove
42+import Reflex.Patch.DMapWithMove
44
43
45-- | A 'Monad' that supports adjustment over time. After an action has been
44-- | A 'Monad' that supports adjustment over time. After an action has been
46-- run, if the given events fire, it will adjust itself so that its net effect
45-- run, if the given events fire, it will adjust itself so that its net effect
src/Reflex/BehaviorWriter/Base.hs+7−16
@@ -1,6 +1,6 @@
1{-|
1{-|
2Module: Reflex.BehaviorWriter.Base
2Module: Reflex.BehaviorWriter.Base
3−Description: Implementation of BehaviorWriter
3+Description: Implementation of MonadBehaviorWriter
4-}
4-}
5{-# LANGUAGE CPP #-}
5{-# LANGUAGE CPP #-}
6{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE FlexibleInstances #-}
@@ -24,7 +24,6 @@ module Reflex.BehaviorWriter.Base
24import Control.Monad.Exception
24import Control.Monad.Exception
25import Control.Monad.Identity
25import Control.Monad.Identity
26import Control.Monad.IO.Class
26import Control.Monad.IO.Class
27−import Control.Monad.Morph
28import Control.Monad.Reader
27import Control.Monad.Reader
29import Control.Monad.Ref
28import Control.Monad.Ref
30import Control.Monad.State.Strict
29import Control.Monad.State.Strict
@@ -47,20 +46,9 @@ import Reflex.Query.Class
47import Reflex.Requester.Class
46import Reflex.Requester.Class
48import Reflex.TriggerEvent.Class
47import Reflex.TriggerEvent.Class
49
48
50−-- | A basic implementation of 'BehaviorWriter'.
49+-- | A basic implementation of 'MonadBehaviorWriter'.
51newtype BehaviorWriterT t w m a = BehaviorWriterT { unBehaviorWriterT :: StateT [Behavior t w] m a }
50newtype BehaviorWriterT t w m a = BehaviorWriterT { unBehaviorWriterT :: StateT [Behavior t w] m a }
52− -- The list is kept in reverse order
51+ deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadAsyncException, MonadException) -- The list is kept in reverse order
53− deriving
54− ( Functor
55− , Applicative
56− , Monad
57− , MonadTrans
58− , MFunctor
59− , MonadIO
60− , MonadFix
61− , MonadAsyncException
62− , MonadException
63− )
64
52
65-- | Run a 'BehaviorWriterT' action. The behavior writer output will be provided
53-- | Run a 'BehaviorWriterT' action. The behavior writer output will be provided
66-- along with the result of the action.
54-- along with the result of the action.
@@ -85,6 +73,9 @@ withBehaviorWriterT f dw = do
85deriving instance MonadHold t m => MonadHold t (BehaviorWriterT t w m)
73deriving instance MonadHold t m => MonadHold t (BehaviorWriterT t w m)
86deriving instance MonadSample t m => MonadSample t (BehaviorWriterT t w m)
74deriving instance MonadSample t m => MonadSample t (BehaviorWriterT t w m)
87
75
76+instance MonadTrans (BehaviorWriterT t w) where
77+ lift = BehaviorWriterT . lift
78+
88instance MonadRef m => MonadRef (BehaviorWriterT t w m) where
79instance MonadRef m => MonadRef (BehaviorWriterT t w m) where
89 type Ref (BehaviorWriterT t w m) = Ref m
80 type Ref (BehaviorWriterT t w m) = Ref m
90 newRef = lift . newRef
81 newRef = lift . newRef
@@ -98,7 +89,7 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (BehaviorWri
98 newEventWithTrigger = lift . newEventWithTrigger
89 newEventWithTrigger = lift . newEventWithTrigger
99 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
90 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
100
91
101−instance (Monad m, Monoid w, Reflex t) => BehaviorWriter t w (BehaviorWriterT t w m) where
92+instance (Monad m, Monoid w, Reflex t) => MonadBehaviorWriter t w (BehaviorWriterT t w m) where
102 tellBehavior w = BehaviorWriterT $ modify (w :)
93 tellBehavior w = BehaviorWriterT $ modify (w :)
103
94
104instance MonadReader r m => MonadReader r (BehaviorWriterT t w m) where
95instance MonadReader r m => MonadReader r (BehaviorWriterT t w m) where
src/Reflex/BehaviorWriter/Class.hs+5−11
@@ -1,9 +1,8 @@
1{-|
1{-|
2Module: Reflex.BehaviorWriter.Class
2Module: Reflex.BehaviorWriter.Class
3−Description: This module defines the 'BehaviorWriter' class
3+Description: This module defines the 'MonadBehaviorWriter' class
4-}
4-}
5{-# LANGUAGE CPP #-}
5{-# LANGUAGE CPP #-}
6−{-# LANGUAGE ConstraintKinds #-}
7{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE FlexibleInstances #-}
8{-# LANGUAGE FunctionalDependencies #-}
7{-# LANGUAGE FunctionalDependencies #-}
9{-# LANGUAGE UndecidableInstances #-}
8{-# LANGUAGE UndecidableInstances #-}
@@ -11,21 +10,16 @@ Description: This module defines the 'BehaviorWriter' class
11{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
10{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
12#endif
11#endif
13module Reflex.BehaviorWriter.Class
12module Reflex.BehaviorWriter.Class
14− ( MonadBehaviorWriter
13+ ( MonadBehaviorWriter (..)
15− , BehaviorWriter(..)
16 ) where
14 ) where
17
15
18import Control.Monad.Reader (ReaderT, lift)
16import Control.Monad.Reader (ReaderT, lift)
19import Reflex.Class (Behavior)
17import Reflex.Class (Behavior)
20
18
21−{-# DEPRECATED MonadBehaviorWriter "Use 'BehaviorWriter' instead" #-}
22−-- | Type synonym for 'BehaviorWriter'
23−type MonadBehaviorWriter = BehaviorWriter
24−
25−-- | 'BehaviorWriter' efficiently collects 'Behavior' values using 'tellBehavior'
19+-- | 'MonadBehaviorWriter' efficiently collects 'Behavior' values using 'tellBehavior'
26-- and combines them monoidally to provide a 'Behavior' result.
20-- and combines them monoidally to provide a 'Behavior' result.
27−class (Monad m, Monoid w) => BehaviorWriter t w m | m -> t w where
21+class (Monad m, Monoid w) => MonadBehaviorWriter t w m | m -> t w where
28 tellBehavior :: Behavior t w -> m ()
22 tellBehavior :: Behavior t w -> m ()
29
23
30−instance BehaviorWriter t w m => BehaviorWriter t w (ReaderT r m) where
24+instance MonadBehaviorWriter t w m => MonadBehaviorWriter t w (ReaderT r m) where
31 tellBehavior = lift . tellBehavior
25 tellBehavior = lift . tellBehavior
src/Reflex/Class.hs+6−26
@@ -29,7 +29,7 @@
29-- convenience functions for working with 'Event's, 'Behavior's, and other
29-- convenience functions for working with 'Event's, 'Behavior's, and other
30-- signals.
30-- signals.
31module Reflex.Class
31module Reflex.Class
32− ( module Data.Patch
32+ ( module Reflex.Patch
33 -- * Primitives
33 -- * Primitives
34 , Reflex (..)
34 , Reflex (..)
35 , mergeInt
35 , mergeInt
@@ -180,7 +180,7 @@ import Prelude hiding (zip, zipWith)
180import Data.These.Combinators (justThese)
180import Data.These.Combinators (justThese)
181#endif
181#endif
182#if MIN_VERSION_semialign(1,1,0)
182#if MIN_VERSION_semialign(1,1,0)
183−import Data.Zip (Zip (..), Unzip (..))
183+import Data.Zip (Zip (..))
184#endif
184#endif
185#endif
185#endif
186
186
@@ -196,8 +196,7 @@ import Data.Align
196import Data.Bifunctor
196import Data.Bifunctor
197import Data.Coerce
197import Data.Coerce
198import Data.Default
198import Data.Default
199−import Data.Dependent.Map (DMap)
199+import Data.Dependent.Map (DMap, DSum (..))
200−import Data.Dependent.Sum (DSum (..))
201import qualified Data.Dependent.Map as DMap
200import qualified Data.Dependent.Map as DMap
202import Data.Functor.Compose
201import Data.Functor.Compose
203import Data.Functor.Product
202import Data.Functor.Product
@@ -211,7 +210,7 @@ import Data.IntMap.Strict (IntMap)
211import qualified Data.IntMap.Strict as IntMap
210import qualified Data.IntMap.Strict as IntMap
212import Data.List.NonEmpty (NonEmpty (..))
211import Data.List.NonEmpty (NonEmpty (..))
213import Data.Map (Map)
212import Data.Map (Map)
214−import Data.Semigroup (Semigroup (..))
213+import Data.Semigroup (Semigroup, sconcat, stimes, (<>))
215import Data.Some (Some(Some))
214import Data.Some (Some(Some))
216import Data.String
215import Data.String
217import Data.These
216import Data.These
@@ -221,8 +220,8 @@ import Data.Witherable (Filterable(..))
221import qualified Data.Witherable as W
220import qualified Data.Witherable as W
222import Reflex.FunctorMaybe (FunctorMaybe)
221import Reflex.FunctorMaybe (FunctorMaybe)
223import qualified Reflex.FunctorMaybe
222import qualified Reflex.FunctorMaybe
224−import Data.Patch
223+import Reflex.Patch
225−import qualified Data.Patch.MapWithMove as PatchMapWithMove
224+import qualified Reflex.Patch.MapWithMove as PatchMapWithMove
226
225
227import Debug.Trace (trace)
226import Debug.Trace (trace)
228
227
@@ -421,13 +420,6 @@ class MonadSample t m => MonadHold t m where
421 -- | Create a new 'Event' that only occurs only once, on the first occurrence of
420 -- | Create a new 'Event' that only occurs only once, on the first occurrence of
422 -- the supplied 'Event'.
421 -- the supplied 'Event'.
423 headE :: Event t a -> m (Event t a)
422 headE :: Event t a -> m (Event t a)
424− -- | An event which only occurs at the current moment in time, such that:
425− --
426− -- > coincidence (pushAlways (\a -> (a <$) <$> now) e) = e
427− --
428− now :: m (Event t ())
429− default now :: (m ~ f m', MonadTrans f, MonadHold t m') => m (Event t ())
430− now = lift now
431
423
432-- | Accumulate an 'Incremental' with the supplied initial value and the firings of the provided 'Event',
424-- | Accumulate an 'Incremental' with the supplied initial value and the firings of the provided 'Event',
433-- using the combining function to produce a patch.
425-- using the combining function to produce a patch.
@@ -573,7 +565,6 @@ instance MonadHold t m => MonadHold t (ReaderT r m) where
573 holdIncremental a0 = lift . holdIncremental a0
565 holdIncremental a0 = lift . holdIncremental a0
574 buildDynamic a0 = lift . buildDynamic a0
566 buildDynamic a0 = lift . buildDynamic a0
575 headE = lift . headE
567 headE = lift . headE
576− now = lift now
577
568
578instance (MonadSample t m, Monoid r) => MonadSample t (WriterT r m) where
569instance (MonadSample t m, Monoid r) => MonadSample t (WriterT r m) where
579 sample = lift . sample
570 sample = lift . sample
@@ -584,7 +575,6 @@ instance (MonadHold t m, Monoid r) => MonadHold t (WriterT r m) where
584 holdIncremental a0 = lift . holdIncremental a0
575 holdIncremental a0 = lift . holdIncremental a0
585 buildDynamic a0 = lift . buildDynamic a0
576 buildDynamic a0 = lift . buildDynamic a0
586 headE = lift . headE
577 headE = lift . headE
587− now = lift now
588
578
589instance MonadSample t m => MonadSample t (StateT s m) where
579instance MonadSample t m => MonadSample t (StateT s m) where
590 sample = lift . sample
580 sample = lift . sample
@@ -595,7 +585,6 @@ instance MonadHold t m => MonadHold t (StateT s m) where
595 holdIncremental a0 = lift . holdIncremental a0
585 holdIncremental a0 = lift . holdIncremental a0
596 buildDynamic a0 = lift . buildDynamic a0
586 buildDynamic a0 = lift . buildDynamic a0
597 headE = lift . headE
587 headE = lift . headE
598− now = lift now
599
588
600instance MonadSample t m => MonadSample t (ExceptT e m) where
589instance MonadSample t m => MonadSample t (ExceptT e m) where
601 sample = lift . sample
590 sample = lift . sample
@@ -606,7 +595,6 @@ instance MonadHold t m => MonadHold t (ExceptT e m) where
606 holdIncremental a0 = lift . holdIncremental a0
595 holdIncremental a0 = lift . holdIncremental a0
607 buildDynamic a0 = lift . buildDynamic a0
596 buildDynamic a0 = lift . buildDynamic a0
608 headE = lift . headE
597 headE = lift . headE
609− now = lift now
610
598
611instance (MonadSample t m, Monoid w) => MonadSample t (RWST r w s m) where
599instance (MonadSample t m, Monoid w) => MonadSample t (RWST r w s m) where
612 sample = lift . sample
600 sample = lift . sample
@@ -617,7 +605,6 @@ instance (MonadHold t m, Monoid w) => MonadHold t (RWST r w s m) where
617 holdIncremental a0 = lift . holdIncremental a0
605 holdIncremental a0 = lift . holdIncremental a0
618 buildDynamic a0 = lift . buildDynamic a0
606 buildDynamic a0 = lift . buildDynamic a0
619 headE = lift . headE
607 headE = lift . headE
620− now = lift now
621
608
622instance MonadSample t m => MonadSample t (ContT r m) where
609instance MonadSample t m => MonadSample t (ContT r m) where
623 sample = lift . sample
610 sample = lift . sample
@@ -628,7 +615,6 @@ instance MonadHold t m => MonadHold t (ContT r m) where
628 holdIncremental a0 = lift . holdIncremental a0
615 holdIncremental a0 = lift . holdIncremental a0
629 buildDynamic a0 = lift . buildDynamic a0
616 buildDynamic a0 = lift . buildDynamic a0
630 headE = lift . headE
617 headE = lift . headE
631− now = lift now
632
618
633--------------------------------------------------------------------------------
619--------------------------------------------------------------------------------
634-- Convenience functions
620-- Convenience functions
@@ -1105,12 +1091,6 @@ instance Reflex t => Zip (Event t) where
1105 zip x y = mapMaybe justThese $ align x y
1091 zip x y = mapMaybe justThese $ align x y
1106#endif
1092#endif
1107
1093
1108−#ifdef MIN_VERSION_semialign
1109−#if MIN_VERSION_semialign(1,1,0)
1110−instance Reflex t => Unzip (Event t) where
1111− unzip = splitE
1112−#endif
1113−#endif
1114
1094
1115-- | Create a new 'Event' that only occurs if the supplied 'Event' occurs and
1095-- | Create a new 'Event' that only occurs if the supplied 'Event' occurs and
1116-- the 'Behavior' is true at the time of occurrence.
1096-- the 'Behavior' is true at the time of occurrence.
src/Reflex/Dynamic.hs+1−15
@@ -53,12 +53,10 @@ module Reflex.Dynamic
53 , foldDynMaybe
53 , foldDynMaybe
54 , foldDynMaybeM
54 , foldDynMaybeM
55 , joinDynThroughMap
55 , joinDynThroughMap
56− , joinDynThroughIntMap
57 , traceDyn
56 , traceDyn
58 , traceDynWith
57 , traceDynWith
59 , splitDynPure
58 , splitDynPure
60 , distributeMapOverDynPure
59 , distributeMapOverDynPure
61− , distributeIntMapOverDynPure
62 , distributeDMapOverDynPure
60 , distributeDMapOverDynPure
63 , distributeListOverDynPure
61 , distributeListOverDynPure
64 , Demux
62 , Demux
@@ -90,8 +88,6 @@ import Data.Dependent.Map (DMap)
90import qualified Data.Dependent.Map as DMap
88import qualified Data.Dependent.Map as DMap
91import Data.Dependent.Sum (DSum (..))
89import Data.Dependent.Sum (DSum (..))
92import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))
90import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))
93−import Data.IntMap (IntMap)
94−import qualified Data.IntMap as IntMap
95import Data.Map (Map)
91import Data.Map (Map)
96import Data.Maybe
92import Data.Maybe
97import Data.Monoid ((<>))
93import Data.Monoid ((<>))
@@ -206,11 +202,6 @@ splitDynPure d = (fmap fst d, fmap snd d)
206distributeMapOverDynPure :: (Reflex t, Ord k) => Map k (Dynamic t v) -> Dynamic t (Map k v)
202distributeMapOverDynPure :: (Reflex t, Ord k) => Map k (Dynamic t v) -> Dynamic t (Map k v)
207distributeMapOverDynPure = fmap dmapToMap . distributeDMapOverDynPure . mapWithFunctorToDMap
203distributeMapOverDynPure = fmap dmapToMap . distributeDMapOverDynPure . mapWithFunctorToDMap
208
204
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−
214-- | Convert a list with 'Dynamic' elements into a 'Dynamic' of a list with
205-- | Convert a list with 'Dynamic' elements into a 'Dynamic' of a list with
215-- non-'Dynamic' elements, preserving the order of the elements.
206-- non-'Dynamic' elements, preserving the order of the elements.
216{-# DEPRECATED distributeListOverDynPure "Use 'distributeListOverDyn' instead" #-}
207{-# DEPRECATED distributeListOverDynPure "Use 'distributeListOverDyn' instead" #-}
@@ -223,11 +214,6 @@ distributeListOverDynPure = distributeListOverDyn
223joinDynThroughMap :: forall t k a. (Reflex t, Ord k) => Dynamic t (Map k (Dynamic t a)) -> Dynamic t (Map k a)
214joinDynThroughMap :: forall t k a. (Reflex t, Ord k) => Dynamic t (Map k (Dynamic t a)) -> Dynamic t (Map k a)
224joinDynThroughMap = (distributeMapOverDynPure =<<)
215joinDynThroughMap = (distributeMapOverDynPure =<<)
225
216
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−
231-- | Print the value of the 'Dynamic' when it is first read and on each
217-- | Print the value of the 'Dynamic' when it is first read and on each
232-- subsequent change that is observed (as 'traceEvent'), prefixed with the
218-- subsequent change that is observed (as 'traceEvent'), prefixed with the
233-- provided string. This should /only/ be used for debugging.
219-- provided string. This should /only/ be used for debugging.
@@ -348,7 +334,7 @@ factorDyn d = buildDynamic (sample (current d) >>= holdKey) update where
348--
334--
349-- > demuxed (demux d) k === fmap (== k) d
335-- > demuxed (demux d) k === fmap (== k) d
350--
336--
351−-- However, when 'demuxed' is used multiple times, the complexity is only
337+-- However, when getDemuxed is used multiple times, the complexity is only
352-- /O(log(n))/, rather than /O(n)/ for fmap.
338-- /O(log(n))/, rather than /O(n)/ for fmap.
353data Demux t k = Demux { demuxValue :: Behavior t k
339data Demux t k = Demux { demuxValue :: Behavior t k
354 , demuxSelector :: EventSelector t (Const2 k Bool)
340 , demuxSelector :: EventSelector t (Const2 k Bool)
src/Reflex/DynamicWriter/Base.hs+5−14
@@ -22,7 +22,6 @@ module Reflex.DynamicWriter.Base
22import Control.Monad.Exception
22import Control.Monad.Exception
23import Control.Monad.Identity
23import Control.Monad.Identity
24import Control.Monad.IO.Class
24import Control.Monad.IO.Class
25−import Control.Monad.Morph
26import Control.Monad.Primitive
25import Control.Monad.Primitive
27import Control.Monad.Reader
26import Control.Monad.Reader
28import Control.Monad.Ref
27import Control.Monad.Ref
@@ -45,13 +44,16 @@ import Reflex.Class
45import Reflex.DynamicWriter.Class
44import Reflex.DynamicWriter.Class
46import Reflex.EventWriter.Class (EventWriter, tellEvent)
45import Reflex.EventWriter.Class (EventWriter, tellEvent)
47import Reflex.Host.Class
46import Reflex.Host.Class
48−import qualified Data.Patch.MapWithMove as MapWithMove
47+import qualified Reflex.Patch.MapWithMove as MapWithMove
49import Reflex.PerformEvent.Class
48import Reflex.PerformEvent.Class
50import Reflex.PostBuild.Class
49import Reflex.PostBuild.Class
51import Reflex.Query.Class
50import Reflex.Query.Class
52import Reflex.Requester.Class
51import Reflex.Requester.Class
53import Reflex.TriggerEvent.Class
52import Reflex.TriggerEvent.Class
54
53
54+instance MonadTrans (DynamicWriterT t w) where
55+ lift = DynamicWriterT . lift
56+
55mapIncrementalMapValues :: (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')
57mapIncrementalMapValues :: (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')
56mapIncrementalMapValues f = unsafeMapIncremental (fmap f) (fmap f)
58mapIncrementalMapValues f = unsafeMapIncremental (fmap f) (fmap f)
57
59
@@ -88,18 +90,7 @@ mergeDynIncrementalWithMove a = unsafeBuildIncremental (mapM (sample . current)
88
90
89-- | A basic implementation of 'DynamicWriter'.
91-- | A basic implementation of 'DynamicWriter'.
90newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT [Dynamic t w] m a }
92newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT [Dynamic t w] m a }
91− -- The list is kept in reverse order
93+ deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadAsyncException, MonadException) -- The list is kept in reverse order
92− deriving
93− ( Functor
94− , Applicative
95− , Monad
96− , MonadTrans
97− , MFunctor
98− , MonadIO
99− , MonadFix
100− , MonadAsyncException
101− , MonadException
102− )
103
94
104deriving instance MonadHold t m => MonadHold t (DynamicWriterT t w m)
95deriving instance MonadHold t m => MonadHold t (DynamicWriterT t w m)
105deriving instance MonadSample t m => MonadSample t (DynamicWriterT t w m)
96deriving instance MonadSample t m => MonadSample t (DynamicWriterT t w m)
src/Reflex/EventWriter/Base.hs+5−16
@@ -35,14 +35,12 @@ import Reflex.TriggerEvent.Class
35
35
36import Control.Monad.Exception
36import Control.Monad.Exception
37import Control.Monad.Identity
37import Control.Monad.Identity
38−import Control.Monad.Morph
39import Control.Monad.Primitive
38import Control.Monad.Primitive
40import Control.Monad.Reader
39import Control.Monad.Reader
41import Control.Monad.Ref
40import Control.Monad.Ref
42import Control.Monad.State.Strict
41import Control.Monad.State.Strict
43−import Data.Dependent.Map (DMap)
42+import Data.Dependent.Map (DMap, DSum (..))
44import qualified Data.Dependent.Map as DMap
43import qualified Data.Dependent.Map as DMap
45−import Data.Dependent.Sum (DSum (..))
46import Data.Functor.Compose
44import Data.Functor.Compose
47import Data.Functor.Misc
45import Data.Functor.Misc
48import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))
46import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))
@@ -98,17 +96,7 @@ data EventWriterState t w = EventWriterState
98
96
99-- | A basic implementation of 'EventWriter'.
97-- | A basic implementation of 'EventWriter'.
100newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (EventWriterState t w) m a }
98newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (EventWriterState t w) m a }
101− deriving
99+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
102− ( Functor
103− , Applicative
104− , Monad
105− , MonadTrans
106− , MFunctor
107− , MonadFix
108− , MonadIO
109− , MonadException
110− , MonadAsyncException
111− )
112
100
113-- | Run a 'EventWriterT' action.
101-- | Run a 'EventWriterT' action.
114runEventWriterT :: forall t m w a. (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)
102runEventWriterT :: forall t m w a. (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)
@@ -128,6 +116,9 @@ instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m
128 , _eventWriterState_told = (tellId myId :=> w) : _eventWriterState_told old
116 , _eventWriterState_told = (tellId myId :=> w) : _eventWriterState_told old
129 }
117 }
130
118
119+instance MonadTrans (EventWriterT t w) where
120+ lift = EventWriterT . lift
121+
131instance MonadSample t m => MonadSample t (EventWriterT t w m) where
122instance MonadSample t m => MonadSample t (EventWriterT t w m) where
132 sample = lift . sample
123 sample = lift . sample
133
124
@@ -142,8 +133,6 @@ instance MonadHold t m => MonadHold t (EventWriterT t w m) where
142 buildDynamic a0 = lift . buildDynamic a0
133 buildDynamic a0 = lift . buildDynamic a0
143 {-# INLINABLE headE #-}
134 {-# INLINABLE headE #-}
144 headE = lift . headE
135 headE = lift . headE
145− {-# INLINABLE now #-}
146− now = lift now
147
136
148instance (Reflex t, Adjustable t m, MonadHold t m, Semigroup w) => Adjustable t (EventWriterT t w m) where
137instance (Reflex t, Adjustable t m, MonadHold t m, Semigroup w) => Adjustable t (EventWriterT t w m) where
149 runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
138 runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
src/Reflex/FastWeak.hs−10
@@ -151,16 +151,6 @@ getFastWeakTicket w = do
151
151
152-- | Create a 'FastWeakTicket' directly from a value, creating a 'FastWeak' in the process
152-- | Create a 'FastWeakTicket' directly from a value, creating a 'FastWeak' in the process
153-- which can be obtained with 'getFastWeakTicketValue'.
153-- which can be obtained with 'getFastWeakTicketValue'.
154−--
155−-- This function is marked NOINLINE so it is opaque to GHC.
156−-- If we do not do this, then GHC will sometimes fuse the constructor away
157−-- so any weak references that are attached to the ticket will have their
158−-- finalizer run. Using the opaque constructor, GHC does not see the
159−-- constructor application, so it behaves like an IORef and cannot be fused away.
160−--
161−-- The result is also evaluated to WHNF, since forcing a thunk invalidates
162−-- the weak pointer to it in some cases.
163−{-# NOINLINE mkFastWeakTicket #-}
164mkFastWeakTicket :: a -> IO (FastWeakTicket a)
154mkFastWeakTicket :: a -> IO (FastWeakTicket a)
165-- I think it's fine if this is lazy - it'll retain the 'a', but so would the output; we just need to make sure it's forced before we start relying on the
155-- I think it's fine if this is lazy - it'll retain the 'a', but so would the output; we just need to make sure it's forced before we start relying on the
166-- associated FastWeak to actually be weak
156-- associated FastWeak to actually be weak
src/Reflex/Host/Headless.hsdeleted−128
@@ -1,128 +0,0 @@
1−{-# LANGUAGE LambdaCase #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE RankNTypes #-}
4−{-# LANGUAGE TypeFamilies #-}
5−{-# LANGUAGE ConstraintKinds #-}
6−
7−module Reflex.Host.Headless where
8−
9−import Control.Concurrent.Chan (newChan, readChan)
10−import Control.Monad (unless)
11−import Control.Monad.Fix (MonadFix, fix)
12−import Control.Monad.IO.Class (MonadIO, liftIO)
13−import Control.Monad.Primitive (PrimMonad)
14−import Control.Monad.Ref (MonadRef, Ref, readRef)
15−import Data.Dependent.Sum (DSum (..), (==>))
16−import Data.Foldable (for_)
17−import Data.Functor.Identity (Identity(..))
18−import Data.IORef (IORef, readIORef)
19−import Data.Maybe (catMaybes, fromMaybe)
20−import Data.Traversable (for)
21−
22−import Reflex
23−import Reflex.Host.Class
24−
25−type MonadHeadlessApp t m =
26− ( Adjustable t m
27− , MonadFix m
28− , MonadHold t m
29− , MonadIO (HostFrame t)
30− , MonadIO (Performable m)
31− , MonadIO m
32− , MonadRef (HostFrame t)
33− , NotReady t m
34− , PerformEvent t m
35− , PostBuild t m
36− , PrimMonad (HostFrame t)
37− , Ref (HostFrame t) ~ IORef
38− , Ref m ~ IORef
39− , Reflex t
40− , ReflexHost t
41− , TriggerEvent t m
42− )
43−
44−-- | Run a headless FRP network. Inside the action, you will most probably use
45−-- the capabilities provided by the 'TriggerEvent' and 'PerformEvent' type
46−-- classes to interface the FRP network with the outside world. Useful for
47−-- testing. Each headless network runs on its own spider timeline.
48−runHeadlessApp
49− :: (forall t m. MonadHeadlessApp t m => m (Event t ()))
50− -- ^ The action to be run in the headless FRP network. The FRP network is
51− -- closed at the first occurrence of the resulting 'Event'.
52− -> IO ()
53−runHeadlessApp guest =
54− -- We are using the 'Spider' implementation of reflex. Running the host
55− -- allows us to take actions on the FRP timeline.
56− withSpiderTimeline $ runSpiderHostForTimeline $ do
57− -- Create the "post-build" event and associated trigger. This event fires
58− -- once, when the application starts.
59− (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
60− -- Create a queue to which we will write 'Event's that need to be
61− -- processed.
62− events <- liftIO newChan
63− -- Run the "guest" application, providing the appropriate context. We'll
64− -- pure the result of the action, and a 'FireCommand' that will be used to
65− -- trigger events.
66− (result, fc@(FireCommand fire)) <- do
67− hostPerformEventT $ -- Allows the guest app to run
68− -- 'performEvent', so that actions
69− -- (e.g., IO actions) can be run when
70− -- 'Event's fire.
71−
72− flip runPostBuildT postBuild $ -- Allows the guest app to access to
73− -- a "post-build" 'Event'
74−
75− flip runTriggerEventT events $ -- Allows the guest app to create new
76− -- events and triggers and write
77− -- those triggers to a channel from
78− -- which they will be read and
79− -- processed.
80− guest
81−
82− -- Read the trigger reference for the post-build event. This will be
83− -- 'Nothing' if the guest application hasn't subscribed to this event.
84− mPostBuildTrigger <- readRef postBuildTriggerRef
85−
86− -- Subscribe to an 'Event' of that the guest application can use to
87− -- request application shutdown. We'll check whether this 'Event' is firing
88− -- to determine whether to terminate.
89− shutdown <- subscribeEvent result
90−
91− -- When there is a subscriber to the post-build event, fire the event.
92− soa <- for mPostBuildTrigger $ \postBuildTrigger ->
93− fire [postBuildTrigger :=> Identity ()] $ isFiring shutdown
94−
95− -- The main application loop. We wait for new events and fire those that
96− -- have subscribers. If we detect a shutdown request, the application
97− -- terminates.
98− unless (or (fromMaybe [] soa)) $ fix $ \loop -> do
99− -- Read the next event (blocking).
100− ers <- liftIO $ readChan events
101− stop <- do
102− -- Fire events that have subscribers.
103− fireEventTriggerRefs fc ers $
104− -- Check if the shutdown 'Event' is firing.
105− isFiring shutdown
106− if or stop
107− then pure ()
108− else loop
109− where
110− isFiring ev = readEvent ev >>= \case
111− Nothing -> pure False
112− Just _ -> pure True
113− -- Use the given 'FireCommand' to fire events that have subscribers
114− -- and call the callback for the 'TriggerInvocation' of each.
115− fireEventTriggerRefs
116− :: MonadIO m
117− => FireCommand t m
118− -> [DSum (EventTriggerRef t) TriggerInvocation]
119− -> ReadPhase m a
120− -> m [a]
121− fireEventTriggerRefs (FireCommand fire) ers rcb = do
122− mes <- liftIO $
123− for ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do
124− me <- readIORef er
125− pure $ fmap (==> a) me
126− a <- fire (catMaybes mes) rcb
127− liftIO $ for_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb
128− pure a
src/Reflex/Patch.hsnew file+46
@@ -0,0 +1,46 @@
1+{-# LANGUAGE TypeFamilies #-}
2+-- |
3+-- Module:
4+-- Reflex.Patch
5+-- Description:
6+-- This module defines the 'Patch' class, which is used by Reflex to manage
7+-- changes to 'Reflex.Class.Incremental' values.
8+module Reflex.Patch
9+ ( module Reflex.Patch
10+ , module X
11+ ) where
12+
13+import Reflex.Patch.Class as X
14+import Reflex.Patch.DMap as X hiding (getDeletions)
15+import Reflex.Patch.DMapWithMove as X (PatchDMapWithMove, const2PatchDMapWithMoveWith, mapPatchDMapWithMove,
16+ patchDMapWithMoveToPatchMapWithMoveWith,
17+ traversePatchDMapWithMoveWithKey, unPatchDMapWithMove,
18+ unsafePatchDMapWithMove, weakenPatchDMapWithMoveWith)
19+import Reflex.Patch.IntMap as X hiding (getDeletions)
20+import Reflex.Patch.Map as X
21+import Reflex.Patch.MapWithMove as X (PatchMapWithMove, patchMapWithMoveNewElements,
22+ patchMapWithMoveNewElementsMap, unPatchMapWithMove,
23+ unsafePatchMapWithMove)
24+import Data.Map.Monoidal (MonoidalMap)
25+import Data.Semigroup (Semigroup (..), (<>))
26+
27+-- | A 'Group' is a 'Monoid' where every element has an inverse.
28+class (Semigroup q, Monoid q) => Group q where
29+ negateG :: q -> q
30+ (~~) :: q -> q -> q
31+ r ~~ s = r <> negateG s
32+
33+-- | An 'Additive' 'Semigroup' is one where (<>) is commutative
34+class Semigroup q => Additive q where
35+
36+-- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type.
37+newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }
38+
39+instance Additive p => Patch (AdditivePatch p) where
40+ type PatchTarget (AdditivePatch p) = p
41+ apply (AdditivePatch p) q = Just $ p <> q
42+
43+instance (Ord k, Group q) => Group (MonoidalMap k q) where
44+ negateG = fmap negateG
45+
46+instance (Ord k, Additive q) => Additive (MonoidalMap k q)
src/Reflex/Patch/Class.hsnew file+34
@@ -0,0 +1,34 @@
1+{-# LANGUAGE TypeFamilies #-}
2+-- | The interface for types which represent changes made to other types
3+module Reflex.Patch.Class where
4+
5+import Control.Monad.Identity
6+import Data.Maybe
7+import Data.Semigroup (Semigroup(..))
8+
9+-- | A 'Patch' type represents a kind of change made to a datastructure.
10+--
11+-- If an instance of 'Patch' is also an instance of 'Semigroup', it should obey
12+-- the law that @applyAlways (f <> g) == applyAlways f . applyAlways g@.
13+class Patch p where
14+ type PatchTarget p :: *
15+ -- | Apply the patch @p a@ to the value @a@. If no change is needed, return
16+ -- 'Nothing'.
17+ apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
18+
19+-- | Apply a 'Patch'; if it does nothing, return the original value
20+applyAlways :: Patch p => p -> PatchTarget p -> PatchTarget p
21+applyAlways p t = fromMaybe t $ apply p t
22+
23+-- | 'Identity' can be used as a 'Patch' that always fully replaces the value
24+instance Patch (Identity a) where
25+ type PatchTarget (Identity a) = a
26+ apply (Identity a) _ = Just a
27+
28+-- | Like '(.)', but composes functions that return patches rather than
29+-- functions that return new values. The Semigroup instance for patches must
30+-- apply patches right-to-left, like '(.)'.
31+composePatchFunctions :: (Patch p, Semigroup p) => (PatchTarget p -> p) -> (PatchTarget p -> p) -> PatchTarget p -> p
32+composePatchFunctions g f a =
33+ let fp = f a
34+ in g (applyAlways fp a) <> fp
src/Reflex/Patch/DMap.hsnew file+82
@@ -0,0 +1,82 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE LambdaCase #-}
3+{-# LANGUAGE PolyKinds #-}
4+{-# LANGUAGE Rank2Types #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE StandaloneDeriving #-}
7+{-# LANGUAGE TypeFamilies #-}
8+-- | 'Patch'es on 'DMap' that consist only of insertions (or overwrites) and deletions.
9+module Reflex.Patch.DMap where
10+
11+import Reflex.Patch.Class
12+import Reflex.Patch.IntMap
13+import Reflex.Patch.Map
14+
15+import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
16+import qualified Data.Dependent.Map as DMap
17+import Data.Functor.Constant
18+import Data.Functor.Misc
19+import qualified Data.IntMap as IntMap
20+import qualified Data.Map as Map
21+import Data.Semigroup (Semigroup (..))
22+import Data.Some (Some)
23+
24+-- | A set of changes to a 'DMap'. Any element may be inserted/updated or deleted.
25+-- Insertions are represented as @'ComposeMaybe' (Just value)@,
26+-- while deletions are represented as @'ComposeMaybe' Nothing@.
27+newtype PatchDMap k v = PatchDMap { unPatchDMap :: DMap k (ComposeMaybe v) }
28+
29+deriving instance GCompare k => Semigroup (PatchDMap k v)
30+
31+deriving instance GCompare k => Monoid (PatchDMap k v)
32+
33+-- | Apply the insertions or deletions to a given 'DMap'.
34+instance GCompare k => Patch (PatchDMap k v) where
35+ type PatchTarget (PatchDMap k v) = DMap k v
36+ apply (PatchDMap diff) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
37+ where insertions = DMap.mapMaybeWithKey (const $ getComposeMaybe) diff
38+ deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getComposeMaybe) diff
39+ nothingToJust = \case
40+ Nothing -> Just $ Constant ()
41+ Just _ -> Nothing
42+
43+-- | Map a function @v a -> v' a@ over any inserts/updates in the given
44+-- @'PatchDMap' k v@ to produce a @'PatchDMap' k v'@.
45+mapPatchDMap :: (forall a. v a -> v' a) -> PatchDMap k v -> PatchDMap k v'
46+mapPatchDMap f (PatchDMap p) = PatchDMap $ DMap.map (ComposeMaybe . fmap f . getComposeMaybe) p
47+
48+-- | Map an effectful function @v a -> f (v' a)@ over any inserts/updates in the given
49+-- @'PatchDMap' k v@ to produce a @'PatchDMap' k v'@.
50+traversePatchDMap :: Applicative f => (forall a. v a -> f (v' a)) -> PatchDMap k v -> f (PatchDMap k v')
51+traversePatchDMap f = traversePatchDMapWithKey $ const f
52+
53+-- | Map an effectful function @k a -> v a -> f (v' a)@ over any inserts/updates
54+-- in the given @'PatchDMap' k v@ to produce a @'PatchDMap' k v'@.
55+traversePatchDMapWithKey :: Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v')
56+traversePatchDMapWithKey f (PatchDMap p) = PatchDMap <$> DMap.traverseWithKey (\k (ComposeMaybe v) -> ComposeMaybe <$> traverse (f k) v) p
57+
58+-- | Weaken a @'PatchDMap' k v@ to a @'PatchMap' (Some k) v'@ using a function
59+-- @v a -> v'@ to weaken each value contained in the patch.
60+weakenPatchDMapWith :: (forall a. v a -> v') -> PatchDMap k v -> PatchMap (Some k) v'
61+weakenPatchDMapWith f (PatchDMap p) = PatchMap $ weakenDMapWith (fmap f . getComposeMaybe) p
62+
63+-- | Convert a weak @'PatchDMap' ('Const2' k a) v@ where the @a@ is known by way of
64+-- the @Const2@ into a @'PatchMap' k v'@ using a rank 1 function @v a -> v'@.
65+patchDMapToPatchMapWith :: (v a -> v') -> PatchDMap (Const2 k a) v -> PatchMap k v'
66+patchDMapToPatchMapWith f (PatchDMap p) = PatchMap $ dmapToMapWith (fmap f . getComposeMaybe) p
67+
68+-- | Convert a @'PatchMap' k v@ into a @'PatchDMap' ('Const2' k a) v'@ using a function @v -> v' a@.
69+const2PatchDMapWith :: forall k v v' a. (v -> v' a) -> PatchMap k v -> PatchDMap (Const2 k a) v'
70+const2PatchDMapWith f (PatchMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
71+ where g :: (k, Maybe v) -> DSum (Const2 k a) (ComposeMaybe v')
72+ g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)
73+
74+-- | Convert a @'PatchIntMap' v@ into a @'PatchDMap' ('Const2' Int a) v'@ using a function @v -> v' a@.
75+const2IntPatchDMapWith :: forall v f a. (v -> f a) -> PatchIntMap v -> PatchDMap (Const2 IntMap.Key a) f
76+const2IntPatchDMapWith f (PatchIntMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> IntMap.toAscList p
77+ where g :: (IntMap.Key, Maybe v) -> DSum (Const2 IntMap.Key a) (ComposeMaybe f)
78+ g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)
79+
80+-- | Get the values that will be replaced or deleted if the given patch is applied to the given 'DMap'.
81+getDeletions :: GCompare k => PatchDMap k v -> DMap k v' -> DMap k v'
82+getDeletions (PatchDMap p) m = DMap.intersectionWithKey (\_ v _ -> v) m p
src/Reflex/Patch/DMapWithMove.hsnew file+363
@@ -0,0 +1,363 @@
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.hsnew file+59
@@ -0,0 +1,59 @@
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.hsnew file+55
@@ -0,0 +1,55 @@
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.hsnew file+270
@@ -0,0 +1,270 @@
1+{-# LANGUAGE DeriveFoldable #-}
2+{-# LANGUAGE DeriveFunctor #-}
3+{-# LANGUAGE DeriveTraversable #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE LambdaCase #-}
6+{-# LANGUAGE PatternGuards #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeFamilies #-}
9+-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
10+-- another
11+module Reflex.Patch.MapWithMove where
12+
13+import Reflex.Patch.Class
14+
15+import Control.Arrow
16+import Control.Monad.State
17+import Data.Foldable
18+import Data.Function
19+import Data.List
20+import Data.Map (Map)
21+import qualified Data.Map as Map
22+import Data.Maybe
23+import Data.Semigroup (Semigroup (..), (<>))
24+import qualified Data.Set as Set
25+import Data.These (These(..))
26+import Data.Tuple
27+
28+-- | Patch a DMap with additions, deletions, and moves. Invariant: If key @k1@
29+-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
30+-- and vice versa. There should never be any unpaired From/To keys.
31+newtype PatchMapWithMove k v = PatchMapWithMove (Map k (NodeInfo k v)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
32+
33+-- | Holds the information about each key: where its new value should come from,
34+-- and where its old value should go to
35+data NodeInfo k v = NodeInfo
36+ { _nodeInfo_from :: !(From k v)
37+ -- ^ Where do we get the new value for this key?
38+ , _nodeInfo_to :: !(To k)
39+ -- ^ If the old value is being kept (i.e. moved rather than deleted or
40+ -- replaced), where is it going?
41+ }
42+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
43+
44+-- | Describe how a key's new value should be produced
45+data From k v
46+ = From_Insert v -- ^ Insert the given value here
47+ | From_Delete -- ^ Delete the existing value, if any, from here
48+ | From_Move !k -- ^ Move the value here from the given key
49+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
50+
51+-- | Describe where a key's old value will go. If this is 'Just', that means
52+-- the key's old value will be moved to the given other key; if it is 'Nothing',
53+-- that means it will be deleted.
54+type To = Maybe
55+
56+-- | Create a 'PatchMapWithMove', validating it
57+patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
58+patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing
59+ where valid = forwardLinks == backwardLinks
60+ forwardLinks = Map.mapMaybe _nodeInfo_to m
61+ backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, v) ->
62+ case _nodeInfo_from v of
63+ From_Move from -> Just (from, to)
64+ _ -> Nothing
65+
66+-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'
67+patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v
68+patchMapWithMoveInsertAll m = PatchMapWithMove $ flip fmap m $ \v -> NodeInfo
69+ { _nodeInfo_from = From_Insert v
70+ , _nodeInfo_to = Nothing
71+ }
72+
73+-- | Extract the internal representation of the 'PatchMapWithMove'
74+unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)
75+unPatchMapWithMove (PatchMapWithMove p) = p
76+
77+-- | Make a @'PatchMapWithMove' k v@ which has the effect of inserting or updating a value @v@ to the given key @k@, like 'Map.insert'.
78+insertMapKey :: k -> v -> PatchMapWithMove k v
79+insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing
80+
81+-- |Make a @'PatchMapWithMove' k v@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to:
82+--
83+-- @
84+-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
85+-- @
86+moveMapKey :: Ord k => k -> k -> PatchMapWithMove k v
87+moveMapKey src dst
88+ | src == dst = mempty
89+ | otherwise =
90+ PatchMapWithMove $ Map.fromList
91+ [ (dst, NodeInfo (From_Move src) Nothing)
92+ , (src, NodeInfo From_Delete (Just dst))
93+ ]
94+
95+-- |Make a @'PatchMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
96+--
97+-- @
98+-- let aMay = Map.lookup a map
99+-- bMay = Map.lookup b map
100+-- in maybe id (Map.insert a) (bMay `mplus` aMay)
101+-- . maybe id (Map.insert b) (aMay `mplus` bMay)
102+-- . Map.delete a . Map.delete b $ map
103+-- @
104+swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v
105+swapMapKey src dst
106+ | src == dst = mempty
107+ | otherwise =
108+ PatchMapWithMove $ Map.fromList
109+ [ (dst, NodeInfo (From_Move src) (Just src))
110+ , (src, NodeInfo (From_Move dst) (Just dst))
111+ ]
112+
113+-- |Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'Map.delete'.
114+deleteMapKey :: k -> PatchMapWithMove k v
115+deleteMapKey k = PatchMapWithMove . Map.singleton k $ NodeInfo From_Delete Nothing
116+
117+-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants.
118+--
119+-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithMove' are preserved; they will not be checked.
120+unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
121+unsafePatchMapWithMove = PatchMapWithMove
122+
123+-- | Apply the insertions, deletions, and moves to a given 'Map'
124+instance Ord k => Patch (PatchMapWithMove k v) where
125+ type PatchTarget (PatchMapWithMove k v) = Map k v
126+ apply (PatchMapWithMove p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
127+ where insertions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of
128+ From_Insert v -> Just v
129+ From_Move k -> Map.lookup k old
130+ From_Delete -> Nothing
131+ deletions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of
132+ From_Delete -> Just ()
133+ _ -> Nothing
134+
135+-- | Returns all the new elements that will be added to the 'Map'.
136+patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
137+patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap
138+
139+-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@.
140+patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v
141+patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p
142+ where f ni = case _nodeInfo_from ni of
143+ From_Insert v -> Just v
144+ From_Move _ -> Nothing
145+ From_Delete -> Nothing
146+
147+-- | Create a 'PatchMapWithMove' that, if applied to the given 'Map', will sort
148+-- its values using the given ordering function. The set keys of the 'Map' is
149+-- not changed.
150+patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v
151+patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted
152+ where unsorted = Map.toList m
153+ sorted = sortBy (cmp `on` snd) unsorted
154+ f (to, _) (from, _) = if to == from then Nothing else
155+ Just (from, to)
156+ reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
157+ g (to, _) (from, _) = if to == from then Nothing else
158+ let Just movingTo = Map.lookup 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−2
@@ -164,8 +164,6 @@ instance (ReflexHost t, MonadHold t m) => MonadHold t (PerformEventT t m) where
164 buildDynamic getV0 v' = PerformEventT $ lift $ buildDynamic getV0 v'
164 buildDynamic getV0 v' = PerformEventT $ lift $ buildDynamic getV0 v'
165 {-# INLINABLE headE #-}
165 {-# INLINABLE headE #-}
166 headE = PerformEventT . lift . headE
166 headE = PerformEventT . lift . headE
167− {-# INLINABLE now #-}
168− now = PerformEventT . lift $ now
169
167
170instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m) where
168instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m) where
171 type Ref (PerformEventT t m) = Ref (HostFrame t)
169 type Ref (PerformEventT t m) = Ref (HostFrame t)
src/Reflex/PerformEvent/Class.hs+1−6
@@ -8,6 +8,7 @@
8{-# LANGUAGE RankNTypes #-}
8{-# LANGUAGE RankNTypes #-}
9{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE TypeFamilies #-}
11+{-# LANGUAGE TypeOperators #-}
11{-# LANGUAGE UndecidableInstances #-}
12{-# LANGUAGE UndecidableInstances #-}
12#ifdef USE_REFLEX_OPTIMIZER
13#ifdef USE_REFLEX_OPTIMIZER
13{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
14{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
@@ -21,7 +22,6 @@ import Reflex.Class
21import Reflex.TriggerEvent.Class
22import Reflex.TriggerEvent.Class
22
23
23import Control.Monad.Reader
24import Control.Monad.Reader
24−import Control.Monad.Trans.Maybe (MaybeT (..))
25
25
26-- | 'PerformEvent' represents actions that can trigger other actions based on
26-- | 'PerformEvent' represents actions that can trigger other actions based on
27-- 'Event's.
27-- 'Event's.
@@ -61,8 +61,3 @@ instance PerformEvent t m => PerformEvent t (ReaderT r m) where
61 performEvent e = do
61 performEvent e = do
62 r <- ask
62 r <- ask
63 lift $ performEvent $ flip runReaderT r <$> e
63 lift $ performEvent $ flip runReaderT r <$> e
64−
65−instance PerformEvent t m => PerformEvent t (MaybeT m) where
66− type Performable (MaybeT m) = MaybeT (Performable m)
67− performEvent_ = lift . performEvent_ . fmapCheap (void . runMaybeT)
68− performEvent = lift . fmap (fmapMaybe id) . performEvent . fmapCheap runMaybeT
src/Reflex/PostBuild/Base.hs+1−2
@@ -9,6 +9,7 @@
9{-# LANGUAGE RecursiveDo #-}
9{-# LANGUAGE RecursiveDo #-}
10{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE TypeFamilies #-}
11{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE TypeOperators #-}
12{-# LANGUAGE UndecidableInstances #-}
13{-# LANGUAGE UndecidableInstances #-}
13#ifdef USE_REFLEX_OPTIMIZER
14#ifdef USE_REFLEX_OPTIMIZER
14{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
15{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
@@ -83,8 +84,6 @@ instance MonadHold t m => MonadHold t (PostBuildT t m) where
83 buildDynamic a0 = lift . buildDynamic a0
84 buildDynamic a0 = lift . buildDynamic a0
84 {-# INLINABLE headE #-}
85 {-# INLINABLE headE #-}
85 headE = lift . headE
86 headE = lift . headE
86− {-# INLINABLE now #-}
87− now = lift now
88
87
89instance PerformEvent t m => PerformEvent t (PostBuildT t m) where
88instance PerformEvent t m => PerformEvent t (PostBuildT t m) where
90 type Performable (PostBuildT t m) = Performable m
89 type Performable (PostBuildT t m) = Performable m
src/Reflex/PostBuild/Class.hs+1
@@ -6,6 +6,7 @@
6{-# LANGUAGE FunctionalDependencies #-}
6{-# LANGUAGE FunctionalDependencies #-}
7{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE TypeFamilies #-}
9+{-# LANGUAGE TypeOperators #-}
9{-# LANGUAGE UndecidableInstances #-}
10{-# LANGUAGE UndecidableInstances #-}
10#ifdef USE_REFLEX_OPTIMIZER
11#ifdef USE_REFLEX_OPTIMIZER
11{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
12{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
src/Reflex/Profiled.hs+5−59
@@ -26,10 +26,8 @@ import Control.Monad.Primitive
26import Control.Monad.Reader
26import Control.Monad.Reader
27import Control.Monad.Ref
27import Control.Monad.Ref
28import Control.Monad.State.Strict (StateT, execStateT, modify)
28import Control.Monad.State.Strict (StateT, execStateT, modify)
29−import Data.Bifunctor
30import Data.Coerce
29import Data.Coerce
31−import Data.Dependent.Map (DMap)
30+import Data.Dependent.Map (DMap, GCompare)
32−import Data.GADT.Compare (GCompare)
33import Data.FastMutableIntMap
31import Data.FastMutableIntMap
34import Data.IORef
32import Data.IORef
35import Data.List
33import Data.List
@@ -44,20 +42,12 @@ import Foreign.Ptr
44import GHC.Foreign
42import GHC.Foreign
45import GHC.IO.Encoding
43import GHC.IO.Encoding
46import GHC.Stack
44import GHC.Stack
47−import Reflex.Adjustable.Class
48−import Reflex.BehaviorWriter.Class
49import Reflex.Class
45import Reflex.Class
50−import Reflex.DynamicWriter.Class
51−import Reflex.EventWriter.Class
52import Reflex.Host.Class
46import Reflex.Host.Class
53−import Reflex.NotReady.Class
54import Reflex.PerformEvent.Class
47import Reflex.PerformEvent.Class
55−import Reflex.PostBuild.Class
56−import Reflex.Query.Class
57−import Reflex.Requester.Class
58−import Reflex.TriggerEvent.Class
59
48
60import System.IO.Unsafe
49import System.IO.Unsafe
50+import Unsafe.Coerce
61
51
62data ProfiledTimeline t
52data ProfiledTimeline t
63
53
@@ -147,7 +137,7 @@ instance Reflex t => Reflex (ProfiledTimeline t) where
147 pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e
137 pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e
148 pull = Behavior_Profiled . pull . coerce
138 pull = Behavior_Profiled . pull . coerce
149 fanG (Event_Profiled e) = EventSelectorG $ coerce $ selectG (fanG $ profileEvent e)
139 fanG (Event_Profiled e) = EventSelectorG $ coerce $ selectG (fanG $ profileEvent e)
150− mergeG :: forall z (k :: z -> *) q v. GCompare k
140+ mergeG :: forall (k :: z -> *) q v. GCompare k
151 => (forall a. q a -> Event (ProfiledTimeline t) (v a))
141 => (forall a. q a -> Event (ProfiledTimeline t) (v a))
152 -> DMap k q -> Event (ProfiledTimeline t) (DMap k v)
142 -> DMap k q -> Event (ProfiledTimeline t) (DMap k v)
153 mergeG nt = Event_Profiled #. mergeG (coerce nt)
143 mergeG nt = Event_Profiled #. mergeG (coerce nt)
@@ -157,8 +147,8 @@ instance Reflex t => Reflex (ProfiledTimeline t) where
157 updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d
147 updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d
158 unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'
148 unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'
159 unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'
149 unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'
160− mergeIncrementalG nt res = Event_Profiled $ mergeIncrementalG (coerce nt) (coerce res)
150+ mergeIncrementalG nt = (Event_Profiled . coerce) #. mergeIncrementalG nt
161− mergeIncrementalWithMoveG nt res = Event_Profiled $ mergeIncrementalWithMoveG (coerce nt) (coerce res)
151+ mergeIncrementalWithMoveG nt = (Event_Profiled . coerce) #. mergeIncrementalWithMoveG nt
162 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i
152 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i
163 updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i
153 updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i
164 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i
154 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i
@@ -184,21 +174,10 @@ instance MonadHold t m => MonadHold (ProfiledTimeline t) (ProfiledM m) where
184 holdIncremental v0 (Event_Profiled v') = ProfiledM $ Incremental_Profiled <$> holdIncremental v0 v'
174 holdIncremental v0 (Event_Profiled v') = ProfiledM $ Incremental_Profiled <$> holdIncremental v0 v'
185 buildDynamic (ProfiledM v0) (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> buildDynamic v0 v'
175 buildDynamic (ProfiledM v0) (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> buildDynamic v0 v'
186 headE (Event_Profiled e) = ProfiledM $ Event_Profiled <$> headE e
176 headE (Event_Profiled e) = ProfiledM $ Event_Profiled <$> headE e
187− now = ProfiledM $ Event_Profiled <$> now
188
177
189instance MonadSample t m => MonadSample (ProfiledTimeline t) (ProfiledM m) where
178instance MonadSample t m => MonadSample (ProfiledTimeline t) (ProfiledM m) where
190 sample (Behavior_Profiled b) = ProfiledM $ sample b
179 sample (Behavior_Profiled b) = ProfiledM $ sample b
191
180
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−
202instance MonadTrans ProfiledM where
181instance MonadTrans ProfiledM where
203 lift = ProfiledM
182 lift = ProfiledM
204
183
@@ -210,39 +189,6 @@ instance PerformEvent t m => PerformEvent (ProfiledTimeline t) (ProfiledM m) whe
210 performEvent_ = lift . performEvent_ . coerce
189 performEvent_ = lift . performEvent_ . coerce
211 performEvent = lift . fmap coerce . performEvent . coerce
190 performEvent = lift . fmap coerce . performEvent . coerce
212
191
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−
246instance MonadRef m => MonadRef (ProfiledM m) where
192instance MonadRef m => MonadRef (ProfiledM m) where
247 type Ref (ProfiledM m) = Ref m
193 type Ref (ProfiledM m) = Ref m
248 newRef = lift . newRef
194 newRef = lift . newRef
src/Reflex/Pure.hs+1−6
@@ -32,8 +32,7 @@ module Reflex.Pure
32 ) where
32 ) where
33
33
34import Control.Monad
34import Control.Monad
35−import Data.Dependent.Map (DMap)
35+import Data.Dependent.Map (DMap, GCompare)
36−import Data.GADT.Compare (GCompare)
37import qualified Data.Dependent.Map as DMap
36import qualified Data.Dependent.Map as DMap
38import Data.IntMap (IntMap)
37import Data.IntMap (IntMap)
39import qualified Data.IntMap as IntMap
38import qualified Data.IntMap as IntMap
@@ -211,7 +210,3 @@ instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where
211 Just x -> fromMaybe lastValue $ apply x lastValue
210 Just x -> fromMaybe lastValue $ apply x lastValue
212
211
213 headE = slowHeadE
212 headE = slowHeadE
214− now t = Event $ guard . (t ==)
215−
216−
217−
src/Reflex/Query/Base.hs+4−10
@@ -22,19 +22,16 @@ module Reflex.Query.Base
22import Control.Applicative (liftA2)
22import Control.Applicative (liftA2)
23import Control.Monad.Exception
23import Control.Monad.Exception
24import Control.Monad.Fix
24import Control.Monad.Fix
25−import Control.Monad.Morph
26import Control.Monad.Primitive
25import Control.Monad.Primitive
27import Control.Monad.Reader
26import Control.Monad.Reader
28import Control.Monad.Ref
27import Control.Monad.Ref
29import Control.Monad.State.Strict
28import Control.Monad.State.Strict
30import Data.Align
29import Data.Align
31−import Data.Dependent.Map (DMap)
30+import Data.Dependent.Map (DMap, DSum (..))
32import qualified Data.Dependent.Map as DMap
31import qualified Data.Dependent.Map as DMap
33−import Data.Dependent.Sum (DSum(..))
34import Data.Foldable
32import Data.Foldable
35import Data.Functor.Compose
33import Data.Functor.Compose
36import Data.Functor.Misc
34import Data.Functor.Misc
37−import Data.GADT.Compare (GCompare)
38import Data.IntMap (IntMap)
35import Data.IntMap (IntMap)
39import qualified Data.IntMap as IntMap
36import qualified Data.IntMap as IntMap
40import Data.Map (Map)
37import Data.Map (Map)
@@ -50,7 +47,7 @@ import Reflex.DynamicWriter.Class
50import Reflex.EventWriter.Base
47import Reflex.EventWriter.Base
51import Reflex.EventWriter.Class
48import Reflex.EventWriter.Class
52import Reflex.Host.Class
49import Reflex.Host.Class
53−import qualified Data.Patch.MapWithMove as MapWithMove
50+import qualified Reflex.Patch.MapWithMove as MapWithMove
54import Reflex.PerformEvent.Class
51import Reflex.PerformEvent.Class
55import Reflex.PostBuild.Class
52import Reflex.PostBuild.Class
56import Reflex.Query.Class
53import Reflex.Query.Class
@@ -138,7 +135,7 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t
138 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
135 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
139 return (liftedResult0, liftedResult')
136 return (liftedResult0, liftedResult')
140
137
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'))
138+ 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'))
142 traverseDMapWithKeyWithAdjust f dm0 dm' = do
139 traverseDMapWithKeyWithAdjust f dm0 dm' = do
143 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
140 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
144 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
141 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
@@ -183,7 +180,7 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t
183 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
180 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
184 return (liftedResult0, liftedResult')
181 return (liftedResult0, liftedResult')
185
182
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'))
183+ 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'))
187 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do
184 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do
188 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
185 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
189 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
186 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
@@ -240,9 +237,6 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t
240instance MonadTrans (QueryT t q) where
237instance MonadTrans (QueryT t q) where
241 lift = QueryT . lift . lift . lift
238 lift = QueryT . lift . lift . lift
242
239
243−instance MFunctor (QueryT t q) where
244− hoist = mapQueryT
245−
246instance PrimMonad m => PrimMonad (QueryT t q m) where
240instance PrimMonad m => PrimMonad (QueryT t q m) where
247 type PrimState (QueryT t q m) = PrimState m
241 type PrimState (QueryT t q m) = PrimState m
248 primitive = lift . primitive
242 primitive = lift . primitive
src/Reflex/Query/Class.hs+4−44
@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveDataTypeable #-}
1{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
@@ -22,7 +21,6 @@ module Reflex.Query.Class
22 , MonadQuery (..)
21 , MonadQuery (..)
23 , tellQueryDyn
22 , tellQueryDyn
24 , queryDyn
23 , queryDyn
25− , subQuery
26 , mapQuery
24 , mapQuery
27 , mapQueryResult
25 , mapQueryResult
28 ) where
26 ) where
@@ -37,9 +35,6 @@ import Data.Map.Monoidal (MonoidalMap)
37import qualified Data.Map.Monoidal as MonoidalMap
35import qualified Data.Map.Monoidal as MonoidalMap
38import Data.Semigroup (Semigroup(..))
36import Data.Semigroup (Semigroup(..))
39import Foreign.Storable
37import Foreign.Storable
40−import Data.Void
41−import Data.Monoid hiding ((<>))
42−import Control.Applicative
43
38
44import Reflex.Class
39import Reflex.Class
45
40
@@ -55,37 +50,6 @@ instance (Ord k, Query v) => Query (MonoidalMap k v) where
55 type QueryResult (MonoidalMap k v) = MonoidalMap k (QueryResult v)
50 type QueryResult (MonoidalMap k v) = MonoidalMap k (QueryResult v)
56 crop q r = MonoidalMap.intersectionWith (flip crop) r q
51 crop q r = MonoidalMap.intersectionWith (flip crop) r q
57
52
58−-- | the result of two queries is both results.
59−instance (Query a, Query b) => Query (a, b) where
60− type QueryResult (a, b) = (QueryResult a, QueryResult b)
61− crop (x, x') (y, y') = (crop x y, crop x' y')
62−
63−-- | Trivial queries have trivial results.
64−instance Query () where
65− type QueryResult () = ()
66− crop _ _ = ()
67−
68−-- | The result of an absurd query is trivial; If you can ask the question, the
69−-- answer cannot tell you anything you didn't already know.
70−--
71−-- 'QueryResult Void = @Void@' seems like it would also work, but that has
72−-- problems of robustness. In some applications, an unasked question can still
73−-- be answered, so it is important that the result is inhabited even when the
74−-- question isn't. Applications that wish to prevent this can mandate that the
75−-- query result be paired with the query: then the whole response will be
76−-- uninhabited as desired.
77−instance Query Void where
78− type QueryResult Void = ()
79− crop = absurd
80−
81−#if MIN_VERSION_base(4,12,0)
82−-- | We can lift queries into monoidal containers.
83−-- But beware of Applicatives whose monoid is different from (pure mempty, liftA2 mappend)
84−instance (Query q, Applicative f) => Query (Ap f q) where
85− type QueryResult (Ap f q) = Ap f (QueryResult q)
86− crop = liftA2 crop
87−#endif
88−
89-- | QueryMorphism's must be group homomorphisms when acting on the query type
53-- | QueryMorphism's must be group homomorphisms when acting on the query type
90-- and compatible with the query relationship when acting on the query result.
54-- and compatible with the query relationship when acting on the query result.
91data QueryMorphism q q' = QueryMorphism
55data QueryMorphism q q' = QueryMorphism
@@ -125,7 +89,7 @@ instance Group SelectedCount where
125
89
126instance Additive SelectedCount
90instance Additive SelectedCount
127
91
128−-- | The Semigroup\/Monoid\/Group instances for a Query containing 'SelectedCount's should use
92+-- | The Semigroup/Monoid/Group instances for a Query containing 'SelectedCount's should use
129-- this function which returns Nothing if the result is 0. This allows the pruning of leaves
93-- this function which returns Nothing if the result is 0. This allows the pruning of leaves
130-- of the 'Query' that are no longer wanted.
94-- of the 'Query' that are no longer wanted.
131combineSelectedCounts :: SelectedCount -> SelectedCount -> Maybe SelectedCount
95combineSelectedCounts :: SelectedCount -> SelectedCount -> Maybe SelectedCount
@@ -133,12 +97,12 @@ combineSelectedCounts (SelectedCount i) (SelectedCount j) = if i == negate j the
133
97
134-- | A class that allows sending of 'Query's and retrieval of 'QueryResult's. See 'queryDyn' for a commonly
98-- | A class that allows sending of 'Query's and retrieval of 'QueryResult's. See 'queryDyn' for a commonly
135-- used interface.
99-- used interface.
136−class (Group q, Additive q, Query q, Monad m) => MonadQuery t q m | m -> q t where
100+class (Group q, Additive q, Query q) => MonadQuery t q m | m -> q t where
137 tellQueryIncremental :: Incremental t (AdditivePatch q) -> m ()
101 tellQueryIncremental :: Incremental t (AdditivePatch q) -> m ()
138 askQueryResult :: m (Dynamic t (QueryResult q))
102 askQueryResult :: m (Dynamic t (QueryResult q))
139 queryIncremental :: Incremental t (AdditivePatch q) -> m (Dynamic t (QueryResult q))
103 queryIncremental :: Incremental t (AdditivePatch q) -> m (Dynamic t (QueryResult q))
140
104
141−instance MonadQuery t q m => MonadQuery t q (ReaderT r m) where
105+instance (Monad m, MonadQuery t q m) => MonadQuery t q (ReaderT r m) where
142 tellQueryIncremental = lift . tellQueryIncremental
106 tellQueryIncremental = lift . tellQueryIncremental
143 askQueryResult = lift askQueryResult
107 askQueryResult = lift askQueryResult
144 queryIncremental = lift . queryIncremental
108 queryIncremental = lift . queryIncremental
@@ -148,11 +112,7 @@ tellQueryDyn :: (Reflex t, MonadQuery t q m) => Dynamic t q -> m ()
148tellQueryDyn d = tellQueryIncremental $ unsafeBuildIncremental (sample (current d)) $ attachWith (\old new -> AdditivePatch $ new ~~ old) (current d) (updated d)
112tellQueryDyn d = tellQueryIncremental $ unsafeBuildIncremental (sample (current d)) $ attachWith (\old new -> AdditivePatch $ new ~~ old) (current d) (updated d)
149
113
150-- | Retrieve 'Dynamic'ally updating 'QueryResult's for a 'Dynamic'ally updating 'Query'.
114-- | Retrieve 'Dynamic'ally updating 'QueryResult's for a 'Dynamic'ally updating 'Query'.
151−queryDyn :: (Reflex t, MonadQuery t q m) => Dynamic t q -> m (Dynamic t (QueryResult q))
115+queryDyn :: (Reflex t, Monad m, MonadQuery t q m) => Dynamic t q -> m (Dynamic t (QueryResult q))
152queryDyn q = do
116queryDyn q = do
153 tellQueryDyn q
117 tellQueryDyn q
154 zipDynWith crop q <$> askQueryResult
118 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+27−97
@@ -1,7 +1,6 @@
1-- | This module provides 'RequesterT', the standard implementation of
1-- | This module provides 'RequesterT', the standard implementation of
2-- 'Requester'.
2-- 'Requester'.
3{-# LANGUAGE AllowAmbiguousTypes #-}
3{-# LANGUAGE AllowAmbiguousTypes #-}
4−{-# LANGUAGE ApplicativeDo #-}
5{-# LANGUAGE CPP #-}
4{-# LANGUAGE CPP #-}
6{-# LANGUAGE EmptyDataDecls #-}
5{-# LANGUAGE EmptyDataDecls #-}
7{-# LANGUAGE ExistentialQuantification #-}
6{-# LANGUAGE ExistentialQuantification #-}
@@ -33,7 +32,6 @@ module Reflex.Requester.Base
33 , requesterDataToList
32 , requesterDataToList
34 , singletonRequesterData
33 , singletonRequesterData
35 , matchResponsesWithRequests
34 , matchResponsesWithRequests
36− , matchResponseMapWithRequests
37 , multiEntry
35 , multiEntry
38 , unMultiEntry
36 , unMultiEntry
39 , requesting'
37 , requesting'
@@ -51,17 +49,14 @@ import Reflex.TriggerEvent.Class
51import Control.Applicative (liftA2)
49import Control.Applicative (liftA2)
52import Control.Monad.Exception
50import Control.Monad.Exception
53import Control.Monad.Identity
51import Control.Monad.Identity
54−import Control.Monad.Morph
55import Control.Monad.Primitive
52import Control.Monad.Primitive
56import Control.Monad.Reader
53import Control.Monad.Reader
57import Control.Monad.Ref
54import Control.Monad.Ref
58import Control.Monad.State.Strict
55import Control.Monad.State.Strict
59import Data.Bits
56import Data.Bits
60import Data.Coerce
57import Data.Coerce
61−import Data.Constraint
62−import Data.Dependent.Map (DMap)
58+import Data.Dependent.Map (DMap, DSum (..))
63import qualified Data.Dependent.Map as DMap
59import qualified Data.Dependent.Map as DMap
64−import Data.Dependent.Sum (DSum (..))
65import Data.Functor.Compose
60import Data.Functor.Compose
66import Data.Functor.Misc
61import Data.Functor.Misc
67import Data.IntMap.Strict (IntMap)
62import Data.IntMap.Strict (IntMap)
@@ -84,51 +79,19 @@ newtype TagMap (f :: * -> *) = TagMap (IntMap Any)
84
79
85newtype RequesterData f = RequesterData (TagMap (Entry f))
80newtype RequesterData f = RequesterData (TagMap (Entry f))
86
81
87−emptyRequesterData :: RequesterData f
88−emptyRequesterData = RequesterData $ TagMap IntMap.empty
89−
90data RequesterDataKey a where
82data RequesterDataKey a where
91 RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a
83 RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a
92 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
84 RequesterDataKey_Multi :: {-# UNPACK #-} !(MyTag Multi) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a --TODO: Don't put a second Int here (or in the other Multis); use a single Int instead
93− RequesterDataKey_Multi2 :: GCompare k => {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
85+ RequesterDataKey_Multi2 :: {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
94 RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
86 RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
95
87
96singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f
88singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f
97singletonRequesterData rdk v = case rdk of
89singletonRequesterData rdk v = case rdk of
98 RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v
90 RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v
99 RequesterDataKey_Multi k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v
91 RequesterDataKey_Multi k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v
100− RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Multi2Contents
92+ RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
101− { _multi2Contents_values = Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
102− , _multi2Contents_dict = Dict
103− }
104 RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
93 RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
105
94
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−
132requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]
95requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]
133requesterDataToList (RequesterData m) = do
96requesterDataToList (RequesterData m) = do
134 k :=> Entry e <- tagMapToList m
97 k :=> Entry e <- tagMapToList m
@@ -138,12 +101,11 @@ requesterDataToList (RequesterData m) = do
138 (k', e') <- IntMap.toList e
101 (k', e') <- IntMap.toList e
139 k'' :=> e'' <- requesterDataToList e'
102 k'' :=> e'' <- requesterDataToList e'
140 return $ RequesterDataKey_Multi k k' k'' :=> e''
103 return $ RequesterDataKey_Multi k k' k'' :=> e''
141− MyTagType_Multi2 -> case _multi2Contents_dict e of
104+ MyTagType_Multi2 -> do
142− Dict -> do
143− (k', e') <- Map.toList $ _multi2Contents_values e
105+ (k', e') <- Map.toList e
144− (k'', e'') <- IntMap.toList e'
106+ (k'', e'') <- IntMap.toList e'
145− k''' :=> e''' <- requesterDataToList e''
107+ k''' :=> e''' <- requesterDataToList e''
146− return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''
108+ return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''
147 MyTagType_Multi3 -> do
109 MyTagType_Multi3 -> do
148 (k', e') <- IntMap.toList e
110 (k', e') <- IntMap.toList e
149 (k'', e'') <- IntMap.toList e'
111 (k'', e'') <- IntMap.toList e'
@@ -171,13 +133,7 @@ traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWith
171 go k (Entry request) = Entry <$> case myKeyType k of
133 go k (Entry request) = Entry <$> case myKeyType k of
172 MyTagType_Single -> f request
134 MyTagType_Single -> f request
173 MyTagType_Multi -> traverse (traverseRequesterData f) request
135 MyTagType_Multi -> traverse (traverseRequesterData f) request
174− MyTagType_Multi2 -> case request of
175− Multi2Contents { _multi2Contents_values = request', _multi2Contents_dict = Dict } -> do
176− v <- traverse (traverse (traverseRequesterData f)) request'
136+ MyTagType_Multi2 -> traverse (traverse (traverseRequesterData f)) request
177− pure $ Multi2Contents
178− { _multi2Contents_values = v
179− , _multi2Contents_dict = Dict
180− }
181 MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request
137 MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request
182
138
183-- | 'traverseRequesterData' with its arguments flipped
139-- | 'traverseRequesterData' with its arguments flipped
@@ -221,14 +177,9 @@ instance MyTagTypeOffset Multi3 where
221type family EntryContents request a where
177type family EntryContents request a where
222 EntryContents request (Single a) = request a
178 EntryContents request (Single a) = request a
223 EntryContents request Multi = IntMap (RequesterData request)
179 EntryContents request Multi = IntMap (RequesterData request)
224− EntryContents request (Multi2 k) = Multi2Contents k request
180+ EntryContents request (Multi2 k) = Map (Some k) (IntMap (RequesterData request))
225 EntryContents request Multi3 = IntMap (IntMap (RequesterData request))
181 EntryContents request Multi3 = IntMap (IntMap (RequesterData request))
226
182
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−
232newtype Entry request x = Entry { unEntry :: EntryContents request x }
183newtype Entry request x = Entry { unEntry :: EntryContents request x }
233
184
234{-# INLINE singleEntry #-}
185{-# INLINE singleEntry #-}
@@ -357,7 +308,7 @@ tagRequest req = do
357 return t
308 return t
358
309
359{-# INLINE responseFromTag #-}
310{-# INLINE responseFromTag #-}
360−responseFromTag :: forall m t request response x. Monad m => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))
311+responseFromTag :: Monad m => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))
361responseFromTag (MyTagWrap t) = do
312responseFromTag (MyTagWrap t) = do
362 responses :: EventSelectorInt t Any <- RequesterT ask
313 responses :: EventSelectorInt t Any <- RequesterT ask
363 return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t
314 return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t
@@ -365,9 +316,6 @@ responseFromTag (MyTagWrap t) = do
365instance MonadTrans (RequesterT t request response) where
316instance MonadTrans (RequesterT t request response) where
366 lift = RequesterT . lift . lift
317 lift = RequesterT . lift . lift
367
318
368−instance MFunctor (RequesterT t request response) where
369− hoist f = RequesterT . hoist (hoist f) . unRequesterT
370−
371instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where
319instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where
372 type Performable (RequesterT t request response m) = Performable m
320 type Performable (RequesterT t request response m) = Performable m
373 performEvent_ = lift . performEvent_
321 performEvent_ = lift . performEvent_
@@ -487,9 +435,9 @@ traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchN
487 let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))
435 let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))
488 responses = fanMap $ fmapCheap unpack response
436 responses = fanMap $ fmapCheap unpack response
489 unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))
437 unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))
490− unpack = _multi2Contents_values . unEntry
438+ unpack = unEntry
491 pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)
439 pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)
492− pack m = Entry $ Multi2Contents { _multi2Contents_values = m, _multi2Contents_dict = Dict }
440+ pack = Entry
493 f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)
441 f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)
494 f' k (Compose (n, v)) = do
442 f' k (Compose (n, v)) = do
495 (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some k))
443 (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some k))
@@ -510,30 +458,10 @@ traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchN
510data Decoder rawResponse response =
458data Decoder rawResponse response =
511 forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)
459 forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)
512
460
513−matchResponsesWithRequests
514− :: forall t rawRequest rawResponse request response m.
515− ( MonadFix m
516− , MonadHold t m
517− , Reflex t
518− )
519− => (forall a. request a -> (rawRequest, rawResponse -> response a))
520− -- ^ Given a request (from 'Requester'), produces the wire format of the
521− -- request and a function used to process the associated response
522− -> Event t (RequesterData request)
523− -- ^ The outgoing requests
524− -> Event t (Int, rawResponse)
525− -- ^ The incoming responses, tagged by an identifying key
526− -> m ( Event t (Map Int rawRequest)
527− , Event t (RequesterData response)
528− )
529− -- ^ A map of outgoing wire-format requests and an event of responses keyed
530− -- by the 'RequesterData' key of the associated outgoing request
531−matchResponsesWithRequests f send recv = matchResponseMapWithRequests f send $ uncurry Map.singleton <$> recv
532−
533-- | Matches incoming responses with previously-sent requests
461-- | Matches incoming responses with previously-sent requests
534-- and uses the provided request "decoder" function to process
462-- and uses the provided request "decoder" function to process
535-- incoming responses.
463-- incoming responses.
536−matchResponseMapWithRequests
464+matchResponsesWithRequests
537 :: forall t rawRequest rawResponse request response m.
465 :: forall t rawRequest rawResponse request response m.
538 ( MonadFix m
466 ( MonadFix m
539 , MonadHold t m
467 , MonadHold t m
@@ -544,14 +472,14 @@ matchResponseMapWithRequests
544 -- request and a function used to process the associated response
472 -- request and a function used to process the associated response
545 -> Event t (RequesterData request)
473 -> Event t (RequesterData request)
546 -- ^ The outgoing requests
474 -- ^ The outgoing requests
547− -> Event t (Map Int rawResponse)
475+ -> Event t (Int, rawResponse)
548− -- ^ A map of incoming responses, tagged by an identifying key
476+ -- ^ The incoming responses, tagged by an identifying key
549 -> m ( Event t (Map Int rawRequest)
477 -> m ( Event t (Map Int rawRequest)
550 , Event t (RequesterData response)
478 , Event t (RequesterData response)
551 )
479 )
552 -- ^ A map of outgoing wire-format requests and an event of responses keyed
480 -- ^ A map of outgoing wire-format requests and an event of responses keyed
553 -- by the 'RequesterData' key of the associated outgoing request
481 -- by the 'RequesterData' key of the associated outgoing request
554−matchResponseMapWithRequests f send recv = do
482+matchResponsesWithRequests f send recv = do
555 rec nextId <- hold 1 $ fmap (\(next, _, _) -> next) outgoing
483 rec nextId <- hold 1 $ fmap (\(next, _, _) -> next) outgoing
556 waitingFor :: Incremental t (PatchMap Int (Decoder rawResponse response)) <-
484 waitingFor :: Incremental t (PatchMap Int (Decoder rawResponse response)) <-
557 holdIncremental mempty $ leftmost
485 holdIncremental mempty $ leftmost
@@ -593,15 +521,17 @@ matchResponseMapWithRequests f send recv = do
593 processIncoming
521 processIncoming
594 :: Incremental t (PatchMap Int (Decoder rawResponse response))
522 :: Incremental t (PatchMap Int (Decoder rawResponse response))
595 -- A map of outstanding expected responses
523 -- A map of outstanding expected responses
596− -> Event t (Map Int rawResponse)
524+ -> Event t (Int, rawResponse)
597 -- A incoming response paired with its identifying key
525 -- A incoming response paired with its identifying key
598 -> Event t (RequesterData response, PatchMap Int v)
526 -> Event t (RequesterData response, PatchMap Int v)
599 -- The decoded response and a patch that clears the outstanding responses queue
527 -- The decoded response and a patch that clears the outstanding responses queue
600− processIncoming waitingFor inc = flip push inc $ \rspMap -> do
528+ processIncoming waitingFor inc = flip push inc $ \(n, rawRsp) -> do
601 wf <- sample $ currentIncremental waitingFor
529 wf <- sample $ currentIncremental waitingFor
602− let match rawRsp (Decoder k rspF) =
530+ case Map.lookup n wf of
603− let rsp = rspF rawRsp
531+ Nothing -> return Nothing -- TODO How should lookup failures be handled here? They shouldn't ever happen..
604− in singletonRequesterData k rsp
532+ Just (Decoder k rspF) -> do
605− matches = Map.intersectionWith match rspMap wf
533+ let rsp = rspF rawRsp
606− pure $ if Map.null matches then Nothing else Just
534+ return $ Just
607− (Map.foldl' mergeRequesterData emptyRequesterData matches, PatchMap $ Nothing <$ matches)
535+ ( singletonRequesterData k rsp
536+ , PatchMap $ Map.singleton n Nothing
537+ )
src/Reflex/Spider/Internal.hs+33−103
@@ -9,6 +9,7 @@
9{-# LANGUAGE GADTs #-}
9{-# LANGUAGE GADTs #-}
10{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10{-# LANGUAGE GeneralizedNewtypeDeriving #-}
11{-# LANGUAGE LambdaCase #-}
11{-# LANGUAGE LambdaCase #-}
12+{-# LANGUAGE MultiWayIf #-}
12{-# LANGUAGE RankNTypes #-}
13{-# LANGUAGE RankNTypes #-}
13{-# LANGUAGE RoleAnnotations #-}
14{-# LANGUAGE RoleAnnotations #-}
14{-# LANGUAGE ScopedTypeVariables #-}
15{-# LANGUAGE ScopedTypeVariables #-}
@@ -19,7 +20,6 @@
19{-# LANGUAGE DeriveFunctor #-}
20{-# LANGUAGE DeriveFunctor #-}
20{-# LANGUAGE StandaloneDeriving #-}
21{-# LANGUAGE StandaloneDeriving #-}
21{-# LANGUAGE InstanceSigs #-}
22{-# LANGUAGE InstanceSigs #-}
22−{-# LANGUAGE MultiWayIf #-}
23
23
24#ifdef USE_REFLEX_OPTIMIZER
24#ifdef USE_REFLEX_OPTIMIZER
25{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
25{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
@@ -38,6 +38,7 @@ import Control.Monad hiding (forM, forM_, mapM, mapM_)
38import Control.Monad.Exception
38import Control.Monad.Exception
39import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)
39import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)
40import Control.Monad.Primitive
40import Control.Monad.Primitive
41+--import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_)
41import Control.Monad.Reader.Class
42import Control.Monad.Reader.Class
42import Control.Monad.IO.Class
43import Control.Monad.IO.Class
43import Control.Monad.ReaderIO
44import Control.Monad.ReaderIO
@@ -46,9 +47,8 @@ import Control.Monad.Fail (MonadFail)
46import qualified Control.Monad.Fail as MonadFail
47import qualified Control.Monad.Fail as MonadFail
47import Data.Align
48import Data.Align
48import Data.Coerce
49import Data.Coerce
49−import Data.Dependent.Map (DMap)
50+import Data.Dependent.Map (DMap, DSum (..))
50import qualified Data.Dependent.Map as DMap
51import qualified Data.Dependent.Map as DMap
51−import Data.Dependent.Sum (DSum (..))
52import Data.FastMutableIntMap (FastMutableIntMap, PatchIntMap (..))
52import Data.FastMutableIntMap (FastMutableIntMap, PatchIntMap (..))
53import qualified Data.FastMutableIntMap as FastMutableIntMap
53import qualified Data.FastMutableIntMap as FastMutableIntMap
54import Data.Foldable hiding (concat, elem, sequence_)
54import Data.Foldable hiding (concat, elem, sequence_)
@@ -106,21 +106,15 @@ import qualified Reflex.Class
106import qualified Reflex.Class as R
106import qualified Reflex.Class as R
107import qualified Reflex.Host.Class
107import qualified Reflex.Host.Class
108import Reflex.NotReady.Class
108import Reflex.NotReady.Class
109−import Data.Patch
109+import Reflex.Patch
110−import qualified Data.Patch.DMapWithMove as PatchDMapWithMove
110+import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
111import Reflex.PerformEvent.Base (PerformEventT)
111import Reflex.PerformEvent.Base (PerformEventT)
112
112
113#ifdef DEBUG_TRACE_EVENTS
113#ifdef DEBUG_TRACE_EVENTS
114import qualified Data.ByteString.Char8 as BS8
114import qualified Data.ByteString.Char8 as BS8
115import System.IO (stderr)
115import System.IO (stderr)
116import Data.List (isPrefixOf)
116import Data.List (isPrefixOf)
117−#endif
118
117
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
124withStackOneLine :: (BS8.ByteString -> a) -> a
118withStackOneLine :: (BS8.ByteString -> a) -> a
125withStackOneLine expr = unsafePerformIO $ do
119withStackOneLine expr = unsafePerformIO $ do
126 stack <- currentCallStack
120 stack <- currentCallStack
@@ -129,33 +123,9 @@ withStackOneLine expr = unsafePerformIO $ do
129
123
130#endif
124#endif
131
125
132−debugPropagate :: Bool
133−
134−debugInvalidateHeight :: Bool
135−
136−debugInvalidate :: Bool
137−
138#ifdef DEBUG
126#ifdef DEBUG
139#define DEBUG_NODEIDS
127#define DEBUG_NODEIDS
140
128
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−
159class HasNodeId a where
129class HasNodeId a where
160 getNodeId :: a -> Int
130 getNodeId :: a -> Int
161
131
@@ -193,10 +163,6 @@ showNodeId' = ("#"<>) . show
193
163
194#else
164#else
195
165
196−debugPropagate = False
197−debugInvalidateHeight = False
198−debugInvalidate = False
199−
200-- This must be inline, or error messages will cause memory leaks due to retaining the node in question
166-- This must be inline, or error messages will cause memory leaks due to retaining the node in question
201{-# INLINE showNodeId #-}
167{-# INLINE showNodeId #-}
202showNodeId :: a -> String
168showNodeId :: a -> String
@@ -253,11 +219,11 @@ subscribeAndRead = unEvent
253{-# INLINE [1] pushCheap #-}
219{-# INLINE [1] pushCheap #-}
254pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
220pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
255pushCheap !f e = Event $ \sub -> do
221pushCheap !f e = Event $ \sub -> do
256− (subscription, occ) <- subscribeAndRead e $ debugSubscriber' "push" $ sub
222+ (subscription, occ) <- subscribeAndRead e $ debugSubscriber' "push" (sub
257 { subscriberPropagate = \a -> do
223 { subscriberPropagate = \a -> do
258 mb <- f a
224 mb <- f a
259 mapM_ (subscriberPropagate sub) mb
225 mapM_ (subscriberPropagate sub) mb
260− }
226+ })
261 occ' <- join <$> mapM f occ
227 occ' <- join <$> mapM f occ
262 return (subscription, occ')
228 return (subscription, occ')
263
229
@@ -307,20 +273,7 @@ data CacheSubscribed x a
307#endif
273#endif
308 }
274 }
309
275
310−nowSpiderEventM :: (HasSpiderTimeline x) => EventM x (R.Event (SpiderTimeline x) ())
276+
311−nowSpiderEventM =
312− SpiderEvent <$> now
313−
314−now :: (MonadIO m, Defer (Some Clear) m, HasSpiderTimeline x
315− ) => m (Event x ())
316−now = do
317− nowOrNot <- liftIO $ newIORef $ Just ()
318− scheduleClear nowOrNot
319− return . Event $ \_ -> do
320− occ <- liftIO . readIORef $ nowOrNot
321− return ( EventSubscription (return ()) eventSubscribedNow
322− , occ
323− )
324
277
325-- | Construct an 'Event' whose value is guaranteed not to be recomputed
278-- | Construct an 'Event' whose value is guaranteed not to be recomputed
326-- repeatedly
279-- repeatedly
@@ -464,6 +417,16 @@ data Subscriber x a = Subscriber
464 , subscriberRecalculateHeight :: !(Height -> IO ())
417 , subscriberRecalculateHeight :: !(Height -> IO ())
465 }
418 }
466
419
420+--TODO: Move this comment to WeakBag
421+-- These function are constructor functions that are marked NOINLINE so they are
422+-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away
423+-- so any weak references that are attached to the constructors will have their
424+-- finalizer run. Using the opaque constructor, does not see the
425+-- constructor application, so it behaves like an IORef and cannot be fused away.
426+--
427+-- The result is also evaluated to WHNF, since forcing a thunk invalidates
428+-- the weak pointer to it in some cases.
429+
467newSubscriberHold :: (HasSpiderTimeline x, Patch p) => Hold x p -> IO (Subscriber x p)
430newSubscriberHold :: (HasSpiderTimeline x, Patch p) => Hold x p -> IO (Subscriber x p)
468newSubscriberHold h = return $ Subscriber
431newSubscriberHold h = return $ Subscriber
469 { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h
432 { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h
@@ -607,16 +570,6 @@ eventSubscribedNever = EventSubscribed
607 , eventSubscribedWhoCreated = return ["never"]
570 , eventSubscribedWhoCreated = return ["never"]
608#endif
571#endif
609 }
572 }
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− }
620
573
621eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x
574eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x
622eventSubscribedFan !subscribed = EventSubscribed
575eventSubscribedFan !subscribed = EventSubscribed
@@ -1346,7 +1299,7 @@ mkWeakPtrWithDebug x debugNote = do
1346 x' <- evaluate x
1299 x' <- evaluate x
1347 mkWeakPtr x' $
1300 mkWeakPtr x' $
1348 if debugFinalize
1301 if debugFinalize
1349− then Just $ debugStrLn $ "finalizing: " ++ debugNote
1302+ then Just $ putStrLn $ "finalizing: " ++ debugNote
1350 else Nothing
1303 else Nothing
1351
1304
1352type WeakList a = [Weak a]
1305type WeakList a = [Weak a]
@@ -1368,13 +1321,13 @@ debugSubscriber' description subscribed = Subscriber
1368 tracePropagate (Proxy :: Proxy x) ("subscriberPropagate: " <> description)
1321 tracePropagate (Proxy :: Proxy x) ("subscriberPropagate: " <> description)
1369 subscriberPropagate subscribed m
1322 subscriberPropagate subscribed m
1370 , subscriberInvalidateHeight = \old -> do
1323 , subscriberInvalidateHeight = \old -> do
1371− traceInvalidateHeight $ "invalidateSubscriberHeight: " <> description <> ", old = " <> show (unHeight old)
1324+ putStrLn $ "invalidateSubscriberHeight: " <> description <> ", old = " <> show (unHeight old)
1372 subscriberInvalidateHeight subscribed old
1325 subscriberInvalidateHeight subscribed old
1373− traceInvalidateHeight $ "invalidateSubscriberHeight: " <> description <> ", done"
1326+ putStrLn $ "invalidateSubscriberHeight: " <> description <> ", done"
1374 , subscriberRecalculateHeight = \new -> do
1327 , subscriberRecalculateHeight = \new -> do
1375− traceInvalidateHeight $ "subscriberRecalculateHeight: " <> description <> ", new = " <> show (unHeight new)
1328+ putStrLn $ "subscriberRecalculateHeight: " <> description <> ", new = " <> show (unHeight new)
1376 subscriberRecalculateHeight subscribed new
1329 subscriberRecalculateHeight subscribed new
1377− traceInvalidateHeight $ "subscriberRecalculateHeight: " <> description <> ", done"
1330+ putStrLn $ "subscriberRecalculateHeight: " <> description <> ", done"
1378 }
1331 }
1379
1332
1380
1333
@@ -1388,15 +1341,11 @@ withIncreasedDepth _ a = do
1388
1341
1389{-# INLINE tracePropagate #-}
1342{-# INLINE tracePropagate #-}
1390tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1343tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1391−tracePropagate p = when debugPropagate . trace p
1344+tracePropagate p = trace p
1392
1345
1393{-# INLINE traceInvalidate #-}
1346{-# INLINE traceInvalidate #-}
1394traceInvalidate :: String -> IO ()
1347traceInvalidate :: String -> IO ()
1395−traceInvalidate = when debugInvalidate . liftIO . debugStrLn
1348+traceInvalidate = liftIO . putStrLn
1396−
1397−{-# INLINE traceInvalidateHeight #-}
1398−traceInvalidateHeight :: String -> IO ()
1399−traceInvalidateHeight = when debugInvalidateHeight . liftIO . debugStrLn
1400
1349
1401{-# INLINE trace #-}
1350{-# INLINE trace #-}
1402trace :: (CanTrace x m) => proxy x -> String -> m ()
1351trace :: (CanTrace x m) => proxy x -> String -> m ()
@@ -1407,7 +1356,7 @@ traceM :: forall x proxy m. (CanTrace x m) => proxy x -> m String -> m ()
1407traceM _ getMessage = do
1356traceM _ getMessage = do
1408 message <- getMessage
1357 message <- getMessage
1409 d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)
1358 d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)
1410− liftIO $ debugStrLn $ replicate d ' ' <> message
1359+ liftIO $ putStrLn $ replicate d ' ' <> message
1411
1360
1412#else
1361#else
1413
1362
@@ -1423,10 +1372,6 @@ tracePropagate _ _ = return ()
1423traceInvalidate :: String -> IO ()
1372traceInvalidate :: String -> IO ()
1424traceInvalidate _ = return ()
1373traceInvalidate _ = return ()
1425
1374
1426−{-# INLINE traceInvalidateHeight #-}
1427−traceInvalidateHeight :: String -> IO ()
1428−traceInvalidateHeight _ = return ()
1429−
1430{-# INLINE debugSubscriber #-}
1375{-# INLINE debugSubscriber #-}
1431debugSubscriber :: String -> Subscriber x a -> IO (Subscriber x a)
1376debugSubscriber :: String -> Subscriber x a -> IO (Subscriber x a)
1432debugSubscriber _ = return
1377debugSubscriber _ = return
@@ -1467,11 +1412,8 @@ showStacks :: [[String]] -> String
1467showStacks = drawForest . listsToForest . fmap (filterStack "Reflex.Spider.Internal")
1412showStacks = drawForest . listsToForest . fmap (filterStack "Reflex.Spider.Internal")
1468
1413
1469filterStack :: String -> [String] -> [String]
1414filterStack :: String -> [String] -> [String]
1470−#ifdef DEBUG_HIDE_INTERNALS
1471filterStack prefix = filter (not . (prefix `isPrefixOf`))
1415filterStack prefix = filter (not . (prefix `isPrefixOf`))
1472−#else
1416+
1473−filterStack prefix = id
1474−#endif
1475
1417
1476#ifdef DEBUG_CYCLES
1418#ifdef DEBUG_CYCLES
1477
1419
@@ -1498,7 +1440,7 @@ instance Show EventLoopException where
1498{-# INLINE propagateSubscriberHold #-}
1440{-# INLINE propagateSubscriberHold #-}
1499propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()
1441propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()
1500propagateSubscriberHold h a = do
1442propagateSubscriberHold h a = do
1501− {-# SCC "trace" #-} when debugPropagate $ traceM (Proxy :: Proxy x) $ liftIO $ do
1443+ traceM (Proxy :: Proxy x) $ liftIO $ do
1502 invalidators <- liftIO $ readIORef $ holdInvalidators h
1444 invalidators <- liftIO $ readIORef $ holdInvalidators h
1503 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
1445 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
1504
1446
@@ -1506,7 +1448,7 @@ propagateSubscriberHold h a = do
1506 case {-# SCC "apply" #-} apply a v of
1448 case {-# SCC "apply" #-} apply a v of
1507 Nothing -> return ()
1449 Nothing -> return ()
1508 Just v' -> do
1450 Just v' -> do
1509− {-# SCC "trace2" #-} withIncreasedDepth (Proxy :: Proxy x) $
1451+ withIncreasedDepth (Proxy :: Proxy x) $
1510 tracePropagate (Proxy :: Proxy x) ("propagateSubscriberHold: assigning Hold" <> showNodeId h)
1452 tracePropagate (Proxy :: Proxy x) ("propagateSubscriberHold: assigning Hold" <> showNodeId h)
1511 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
1453 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
1512 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
1454 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
@@ -2038,7 +1980,7 @@ revalidateMergeHeight m = do
2038 LT -> return ()
1980 LT -> return ()
2039 EQ -> do
1981 EQ -> do
2040 let height = succHeight $ heightBagMax heights
1982 let height = succHeight $ heightBagMax heights
2041− traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height
1983+ traceInvalidate $ "recalculateSubscriberHeight: height: " <> show height
2042 writeIORef (_merge_heightRef m) $! height
1984 writeIORef (_merge_heightRef m) $! height
2043 subscriberRecalculateHeight (_merge_sub m) height
1985 subscriberRecalculateHeight (_merge_sub m) height
2044 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
1986 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
@@ -2202,7 +2144,7 @@ mergeIntCheap d = Event $ \sub -> do
2202 LT -> return ()
2144 LT -> return ()
2203 EQ -> do
2145 EQ -> do
2204 let height = succHeight $ heightBagMax heights
2146 let height = succHeight $ heightBagMax heights
2205− traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height
2147+ traceInvalidate $ "recalculateSubscriberHeight: height: " <> show height
2206 writeIORef heightRef $! height
2148 writeIORef heightRef $! height
2207 subscriberRecalculateHeight sub height
2149 subscriberRecalculateHeight sub height
2208 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"
2150 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"
@@ -2385,7 +2327,7 @@ runFrame a = SpiderHost $ do
2385 subscription <- unSpiderHost $ runFrame $ {-# SCC "subscribeSwitch" #-} subscribe e sub --TODO: Assert that the event isn't firing --TODO: This should not loop because none of the events should be firing, but still, it is inefficient
2327 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
2386 {-
2328 {-
2387 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
2329 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
2388− liftIO $ debugStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
2330+ liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
2389 EventRoot _ -> "EventRoot"
2331 EventRoot _ -> "EventRoot"
2390 EventNever -> "EventNever"
2332 EventNever -> "EventNever"
2391 _ -> "something else"
2333 _ -> "something else"
@@ -2520,8 +2462,6 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Event
2520 {-# INLINABLE headE #-}
2462 {-# INLINABLE headE #-}
2521 headE = R.slowHeadE
2463 headE = R.slowHeadE
2522-- headE (SpiderEvent e) = SpiderEvent <$> Reflex.Spider.Internal.headE e
2464-- headE (SpiderEvent e) = SpiderEvent <$> Reflex.Spider.Internal.headE e
2523− {-# INLINABLE now #-}
2524− now = nowSpiderEventM
2525
2465
2526instance Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where
2466instance Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where
2527 {-# INLINABLE sample #-}
2467 {-# INLINABLE sample #-}
@@ -2543,9 +2483,6 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide
2543 {-# INLINABLE headE #-}
2483 {-# INLINABLE headE #-}
2544 headE = R.slowHeadE
2484 headE = R.slowHeadE
2545-- headE (SpiderEvent e) = SpiderPushM $ SpiderEvent <$> Reflex.Spider.Internal.headE e
2485-- headE (SpiderEvent e) = SpiderPushM $ SpiderEvent <$> Reflex.Spider.Internal.headE e
2546− {-# INLINABLE now #-}
2547− now = SpiderPushM nowSpiderEventM
2548−
2549
2486
2550instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where
2487instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where
2551 {-# INLINE return #-}
2488 {-# INLINE return #-}
@@ -2609,9 +2546,6 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide
2609 buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e
2546 buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e
2610 {-# INLINABLE headE #-}
2547 {-# INLINABLE headE #-}
2611 headE e = runFrame . runSpiderHostFrame $ Reflex.Class.headE e
2548 headE e = runFrame . runSpiderHostFrame $ Reflex.Class.headE e
2612− {-# INLINABLE now #-}
2613− now = runFrame . runSpiderHostFrame $ Reflex.Class.now
2614−
2615
2549
2616instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where
2550instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where
2617 sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can
2551 sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can
@@ -2628,8 +2562,6 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide
2628 {-# INLINABLE headE #-}
2562 {-# INLINABLE headE #-}
2629 headE = R.slowHeadE
2563 headE = R.slowHeadE
2630-- headE (SpiderEvent e) = SpiderHostFrame $ SpiderEvent <$> Reflex.Spider.Internal.headE e
2564-- headE (SpiderEvent e) = SpiderHostFrame $ SpiderEvent <$> Reflex.Spider.Internal.headE e
2631− {-# INLINABLE now #-}
2632− now = SpiderHostFrame Reflex.Class.now
2633
2565
2634instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where
2566instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where
2635 {-# INLINABLE sample #-}
2567 {-# INLINABLE sample #-}
@@ -2650,8 +2582,6 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Refle
2650 buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e
2582 buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e
2651 {-# INLINABLE headE #-}
2583 {-# INLINABLE headE #-}
2652 headE e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.headE e
2584 headE e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.headE e
2653− {-# INLINABLE now #-}
2654− now = Reflex.Spider.Internal.ReadPhase Reflex.Class.now
2655
2585
2656--------------------------------------------------------------------------------
2586--------------------------------------------------------------------------------
2657-- Deprecated items
2587-- Deprecated items
@@ -2775,7 +2705,7 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2775 fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))
2705 fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))
2776 {-# INLINABLE mergeG #-}
2706 {-# INLINABLE mergeG #-}
2777 mergeG
2707 mergeG
2778− :: forall k2 (k :: k2 -> *) q (v :: k2 -> *). GCompare k
2708+ :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k
2779 => (forall a. q a -> R.Event (SpiderTimeline x) (v a))
2709 => (forall a. q a -> R.Event (SpiderTimeline x) (v a))
2780 -> DMap k q
2710 -> DMap k q
2781 -> R.Event (SpiderTimeline x) (DMap k v)
2711 -> R.Event (SpiderTimeline x) (DMap k v)
src/Reflex/TriggerEvent/Base.hs−2
@@ -122,8 +122,6 @@ instance MonadHold t m => MonadHold t (TriggerEventT t m) where
122 buildDynamic a0 = lift . buildDynamic a0
122 buildDynamic a0 = lift . buildDynamic a0
123 {-# INLINABLE headE #-}
123 {-# INLINABLE headE #-}
124 headE = lift . headE
124 headE = lift . headE
125− {-# INLINABLE now #-}
126− now = lift now
127
125
128instance Adjustable t m => Adjustable t (TriggerEventT t m) where
126instance Adjustable t m => Adjustable t (TriggerEventT t m) where
129 {-# INLINABLE runWithReplace #-}
127 {-# INLINABLE runWithReplace #-}
src/Reflex/TriggerEvent/Class.hs−6
@@ -12,7 +12,6 @@ import Reflex.Class
12import Control.Monad.Reader
12import Control.Monad.Reader
13import Control.Monad.State
13import Control.Monad.State
14import qualified Control.Monad.State.Strict as Strict
14import qualified Control.Monad.State.Strict as Strict
15−import Control.Monad.Trans.Maybe (MaybeT)
16
15
17--TODO: Shouldn't have IO hard-coded
16--TODO: Shouldn't have IO hard-coded
18-- | 'TriggerEvent' represents actions that can create 'Event's that can be
17-- | 'TriggerEvent' represents actions that can create 'Event's that can be
@@ -48,8 +47,3 @@ instance TriggerEvent t m => TriggerEvent t (Strict.StateT s m) where
48 newTriggerEvent = lift newTriggerEvent
47 newTriggerEvent = lift newTriggerEvent
49 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
48 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
50 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
49 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)
13
13
14import Reflex.Class
14import Reflex.Class
15import Reflex.Adjustable.Class
15import Reflex.Adjustable.Class
16−import Data.Patch.MapWithMove
16+import Reflex.Patch.MapWithMove
17
17
18
18
19-- | Build sortable content in such a way that re-sorting it can cause minimal
19-- | Build sortable content in such a way that re-sorting it can cause minimal
test/Adjustable.hsdeleted−62
@@ -1,62 +0,0 @@
1−{-# LANGUAGE BangPatterns #-}
2−{-# LANGUAGE LambdaCase #-}
3−{-# LANGUAGE RankNTypes #-}
4−{-# LANGUAGE RecursiveDo #-}
5−
6−module Main where
7−
8−import Control.Monad.Fix
9−import Data.Maybe
10−import qualified Data.Map as Map
11−
12−import Reflex
13−import Reflex.EventWriter.Base
14−import Reflex.Network
15−import Reflex.Patch.MapWithMove
16−import Test.Run
17−
18−main :: IO ()
19−main = do
20− let actions = [ Increment, Update0th, Increment, Swap, Increment, Increment ]
21− os <- runAppB testPatchMapWithMove $ map Just actions
22− -- If the final counter value in the adjusted widgets corresponds to the number of times it has
23− -- been incremented, we know that the networks haven't broken.
24− let expectedCount = length $ ffilter (== Increment) actions
25− -- let !True = last (last os) == [expectedCount,expectedCount] -- TODO re-enable this test after issue #369 has been resolved
26− return ()
27−
28−data PatchMapTestAction
29− = Increment
30− | Swap
31− | Update0th
32− deriving Eq
33−
34−-- See https://github.com/reflex-frp/reflex/issues/369 for the bug that this is testing.
35−testPatchMapWithMove
36− :: forall t m
37− . ( Reflex t
38− , Adjustable t m
39− , MonadHold t m
40− , MonadFix m
41− )
42− => Event t PatchMapTestAction
43− -> m (Behavior t [Int])
44−testPatchMapWithMove pulse = do
45− let pulseAction = ffor pulse $ \case
46− Increment -> Nothing
47− Swap -> patchMapWithMove $ Map.fromList
48− [ (0, NodeInfo (From_Move 1) (Just 1))
49− , (1, NodeInfo (From_Move 0) (Just 0))
50− ]
51− Update0th -> patchMapWithMove $ Map.fromList
52− [ (0, NodeInfo (From_Insert 'z') Nothing) ]
53− (_, result) <- runBehaviorWriterT $ mdo
54− counter <- foldDyn (+) 1 $ fmapMaybe (\e -> if isNothing e then Just 1 else Nothing) pulseAction
55− _ <- mapMapWithAdjustWithMove
56− (\_ _ -> networkHold
57− (tellBehavior $ constant [])
58− ((\t -> tellBehavior $ constant [t]) <$> updated counter))
59− (Map.fromList $ zip [0..] "ab")
60− (fmapMaybe id pulseAction)
61− return ()
62− return result
test/DebugCycles.hs+87−44
@@ -15,20 +15,28 @@ import Control.Applicative
15import Control.Monad
15import Control.Monad
16import Control.Monad.Fix
16import Control.Monad.Fix
17import Control.Exception
17import Control.Exception
18+
18import System.Timeout
19import System.Timeout
20+
19import Data.Maybe (isJust)
21import Data.Maybe (isJust)
20import Data.Functor.Misc
22import Data.Functor.Misc
21import qualified Data.Map as Map
23import qualified Data.Map as Map
22import Data.Map (Map)
24import Data.Map (Map)
25+
23import qualified Data.IntMap as IntMap
26import qualified Data.IntMap as IntMap
24import Data.IntMap (IntMap)
27import Data.IntMap (IntMap)
28+
29+
25import Data.These
30import Data.These
26import Data.Align
31import Data.Align
32+
27import Reflex
33import Reflex
28import Reflex.EventWriter.Base
34import Reflex.EventWriter.Base
29import Test.Run
35import Test.Run
30−import Test.Hspec
36+
31import Reflex.Spider.Internal (EventLoopException)
37import Reflex.Spider.Internal (EventLoopException)
38+
39+
32import Data.Witherable (Filterable)
40import Data.Witherable (Filterable)
33
41
34#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))
42#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))
@@ -37,11 +45,13 @@ import Data.These.Lens
37
45
38type Widget t m = (MonadHold t m, Reflex t, MonadFix m)
46type Widget t m = (MonadHold t m, Reflex t, MonadFix m)
39
47
48+
40−connectDyn :: Widget t m => Event t () -> (Dynamic t a, Dynamic t a) -> m (Dynamic t a)
49+connectDyn ::Widget t m => Event t () -> (Dynamic t a, Dynamic t a) -> m (Dynamic t a)
41connectDyn e (d, d') = do
50connectDyn e (d, d') = do
42 dd <- holdDyn d (d' <$ e)
51 dd <- holdDyn d (d' <$ e)
43 return $ join dd
52 return $ join dd
44
53
54+
45dynLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
55dynLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
46dynLoop (e1, e2) = do
56dynLoop (e1, e2) = do
47 -- "heightBagRemove: Height 2 not present in bag HeightBag {_heightBag_size = 2, _heightBag_contents = fromList [(0,1)]}"
57 -- "heightBagRemove: Height 2 not present in bag HeightBag {_heightBag_size = 2, _heightBag_contents = fromList [(0,1)]}"
@@ -64,6 +74,7 @@ coincidenceLoop (e1, e2) = do
64 d <- count (align e' e1)
74 d <- count (align e' e1)
65 return $ updated d
75 return $ updated d
66
76
77+
67addHeight :: Reflex t => Event t a -> Event t a
78addHeight :: Reflex t => Event t a -> Event t a
68addHeight e = leftmost [e4, e4] where
79addHeight e = leftmost [e4, e4] where
69 e1 = leftmost [e, e]
80 e1 = leftmost [e, e]
@@ -71,11 +82,13 @@ addHeight e = leftmost [e4, e4] where
71 e3 = leftmost [e2, e2]
82 e3 = leftmost [e2, e2]
72 e4 = leftmost [e3, e3]
83 e4 = leftmost [e3, e3]
73
84
85+
74-- Take an existing test and build it inside a
86-- Take an existing test and build it inside a
75buildLoop :: 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)
87buildLoop :: 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)
76buildLoop test (e1, e2) = switchHold never buildLoop
88buildLoop test (e1, e2) = switchHold never buildLoop
77 where buildLoop = pushAlways (const $ test (e1, e2)) e2
89 where buildLoop = pushAlways (const $ test (e1, e2)) e2
78
90
91+
79connectButtonPromptly :: Widget t m => Event t () -> Event t a -> m (Event t a)
92connectButtonPromptly :: Widget t m => Event t () -> Event t a -> m (Event t a)
80connectButtonPromptly click e = do
93connectButtonPromptly click e = do
81 d <- holdDyn never (e <$ click)
94 d <- holdDyn never (e <$ click)
@@ -86,8 +99,9 @@ connectButton click e = do
86 d <- hold never (e <$ click)
99 d <- hold never (e <$ click)
87 return (switch d)
100 return (switch d)
88
101
102+
89−switchLoop01 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
103+switchLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
90−switchLoop01 (e1, e2) = do
104+switchLoop (e1, e2) = do
91 rec
105 rec
92 e' <- connectButton e2 (updated d)
106 e' <- connectButton e2 (updated d)
93 d <- count (align e' e1)
107 d <- count (align e' e1)
@@ -98,74 +112,103 @@ mergeLoop (e1, e2) = do
98 rec
112 rec
99 (_, e) <- runEventWriterT $
113 (_, e) <- runEventWriterT $
100 runWithReplace w (leftmost [w <$ e1])
114 runWithReplace w (leftmost [w <$ e1])
115+
101 return (sum <$> e)
116 return (sum <$> e)
117+
102 where
118 where
103 w = do
119 w = do
104 c <- count e1
120 c <- count e1
105 tellEvent (updated ((pure <$> c) :: Dynamic t [Int]))
121 tellEvent (updated ((pure <$> c) :: Dynamic t [Int]))
106
122
123+
124+
125+
107−switchLoop02 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
126+switchLoop' :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
108−switchLoop02 (e1, e2) = do
127+switchLoop' (e1, e2) = do
109 rec
128 rec
110 e' <- connectButton e2 (updated d)
129 e' <- connectButton e2 (updated d)
111 d <- count (leftmost [e', e1])
130 d <- count (leftmost [e', e1])
112 return $ updated d
131 return $ updated d
113
132
133+
114−switchLoop03 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
134+switchLoop2 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
115−switchLoop03 (e1, e2) = do
135+switchLoop2 (e1, e2) = do
116 rec
136 rec
117 e' <- connectButton e2 (addHeight $ updated d)
137 e' <- connectButton e2 (addHeight $ updated d)
118 d <- count (align e' e1)
138 d <- count (align e' e1)
119 return $ updated d
139 return $ updated d
120
140
141+
121−staticLoop01 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
142+staticLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
122−staticLoop01 (e1, e2) = do
143+staticLoop (e1, e2) = do
123 rec
144 rec
124 d <- foldDyn (+) (0 :: Int) (1 <$ align e1 (updated d))
145 d <- foldDyn (+) (0 :: Int) (1 <$ align e1 (updated d))
125 return $ updated d
146 return $ updated d
126
147
127−staticLoop02 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
148+staticLoop' :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
128−staticLoop02 (e1, e2) = do
149+staticLoop' (e1, e2) = do
129 rec
150 rec
130 d <- foldDyn (+) (0 :: Int) (leftmost [e1, updated d])
151 d <- foldDyn (+) (0 :: Int) (leftmost [e1, updated d])
131 return $ updated d
152 return $ updated d
132
153
154+
133buildStaticLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
155buildStaticLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)
134buildStaticLoop (e1, e2) = switchHold never buildLoop
156buildStaticLoop (e1, e2) = switchHold never buildLoop
135− where buildLoop = pushAlways (const $ staticLoop01 (e1, e2)) e2
157+ where buildLoop = pushAlways (const $ staticLoop (e1, e2)) e2
136
158
137splitThese :: Filterable f => f (These a b) -> (f a, f b)
159splitThese :: Filterable f => f (These a b) -> (f a, f b)
138splitThese f = (mapMaybe (preview here) f, mapMaybe (preview there) f)
160splitThese f = (mapMaybe (preview here) f, mapMaybe (preview there) f)
139
161
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+
140main :: IO ()
207main :: IO ()
141−main = hspec $ do
208+main = traverse_ runTest tests
142− describe "DebugCycles" $ do
209+
143− it "throws EventLoopException on switchLoop01" $ do
210+
144− check switchLoop01
211+
145− it "throws EventLoopException on switchLoop02" $ do
212+
146− check switchLoop02
213+
147− it "throws EventLoopException on switchLoop03" $ do
214+
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+1−2
@@ -18,10 +18,9 @@ import Data.GADT.Compare
18import Data.IORef
18import Data.IORef
19import Data.Semigroup
19import Data.Semigroup
20import Data.These
20import Data.These
21−import Data.Type.Equality ((:~:)(Refl))
22
21
23import Data.Functor.Misc
22import Data.Functor.Misc
24−import Data.Patch
23+import Reflex.Patch
25
24
26import qualified Reflex.Host.Class as Host
25import qualified Reflex.Host.Class as Host
27import qualified Reflex.Spider.Internal as S
26import qualified Reflex.Spider.Internal as S
test/Headless.hsdeleted−10
@@ -1,10 +0,0 @@
1−module Main where
2−
3−import Reflex
4−import Reflex.Host.Headless (runHeadlessApp)
5−
6−main :: IO ()
7−main = do
8− runHeadlessApp $ do
9− pb <- getPostBuild
10− performEvent (pure <$> pb)
test/QueryT.hs+1−1
@@ -24,7 +24,7 @@ import Data.These.Lens
24#endif
24#endif
25
25
26import Reflex
26import Reflex
27−import Data.Patch.MapWithMove
27+import Reflex.Patch.MapWithMove
28import Test.Run
28import Test.Run
29
29
30newtype MyQuery = MyQuery SelectedCount
30newtype MyQuery = MyQuery SelectedCount
test/Reflex/Plan/Pure.hs−1
@@ -41,7 +41,6 @@ instance MonadHold (Pure Int) PurePlan where
41 holdIncremental initial = liftPlan . holdIncremental initial
41 holdIncremental initial = liftPlan . holdIncremental initial
42 buildDynamic getInitial = liftPlan . buildDynamic getInitial
42 buildDynamic getInitial = liftPlan . buildDynamic getInitial
43 headE = liftPlan . headE
43 headE = liftPlan . headE
44− now = liftPlan now
45
44
46instance MonadSample (Pure Int) PurePlan where
45instance MonadSample (Pure Int) PurePlan where
47 sample = liftPlan . sample
46 sample = liftPlan . sample
test/Reflex/Test/CrossImpl.hs+8−13
@@ -21,12 +21,11 @@ import Reflex.Dynamic
21import Reflex.Host.Class
21import Reflex.Host.Class
22import qualified Reflex.Pure as P
22import qualified Reflex.Pure as P
23import qualified Reflex.Spider.Internal as S
23import qualified Reflex.Spider.Internal as S
24−import qualified Reflex.Profiled as Prof
25
24
26import Control.Arrow (second, (&&&))
25import Control.Arrow (second, (&&&))
27import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
26import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
28import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
27import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
29−import Data.Dependent.Sum (DSum (..))
28+import Data.Dependent.Map (DSum (..))
30import Data.Foldable
29import Data.Foldable
31import Data.Map.Strict (Map)
30import Data.Map.Strict (Map)
32import qualified Data.Map.Strict as Map
31import qualified Data.Map.Strict as Map
@@ -36,6 +35,8 @@ import Data.Traversable
36import System.Exit
35import System.Exit
37import System.Mem
36import System.Mem
38
37
38+import System.IO.Unsafe
39+
39mapToPureBehavior :: Map Int a -> Behavior PureReflexDomain a
40mapToPureBehavior :: Map Int a -> Behavior PureReflexDomain a
40mapToPureBehavior m = P.Behavior $ \t -> case Map.lookupLE t m of
41mapToPureBehavior m = P.Behavior $ \t -> case Map.lookupLE t m of
41 Nothing -> error $ "mapToPureBehavior: no value for time " <> show t
42 Nothing -> error $ "mapToPureBehavior: no value for time " <> show t
@@ -72,14 +73,11 @@ instance MapMSignals (Event t a) (Event t' a) t t' where
72instance (MapMSignals a a' t t', MapMSignals b b' t t') => MapMSignals (a, b) (a', b') t t' where
73instance (MapMSignals a a' t t', MapMSignals b b' t t') => MapMSignals (a, b) (a', b') t t' where
73 mapMSignals fb fe (a, b) = liftM2 (,) (mapMSignals fb fe a) (mapMSignals fb fe b)
74 mapMSignals fb fe (a, b) = liftM2 (,) (mapMSignals fb fe a) (mapMSignals fb fe b)
74
75
75−testTimeline
76− :: (forall m t. TestCaseConstraint t m => (Behavior t a, Event t b) -> m (Behavior t c, Event t d))
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− -> (Map Int a, Map Int b)
78− -> (forall m t. (MonadReflexHost t m, MonadIO m, MonadRef m, Ref m ~ Ref IO, MonadSample t m) => m (Map Int c, Map Int d))
79−testTimeline builder (bMap, eMap) = do
77+testSpider builder (bMap, eMap) = unsafePerformIO $ S.runSpiderHost $ do
80 (re, reTrigger) <- newEventWithTriggerRef
78 (re, reTrigger) <- newEventWithTriggerRef
81 (rb, rbTrigger) <- newEventWithTriggerRef
79 (rb, rbTrigger) <- newEventWithTriggerRef
82− b <- runHostFrame $ hold (error "testTimeline: No value for input behavior yet") rb
80+ b <- runHostFrame $ hold (error "testSpider: No value for input behavior yet") rb
83 (b', e') <- runHostFrame $ builder (b, re)
81 (b', e') <- runHostFrame $ builder (b, re)
84 e'Handle <- subscribeEvent e' --TODO: This should be unnecessary
82 e'Handle <- subscribeEvent e' --TODO: This should be unnecessary
85 let times = relevantTestingTimes (bMap, eMap)
83 let times = relevantTestingTimes (bMap, eMap)
@@ -104,11 +102,9 @@ testAgreement :: (Eq c, Eq d, Show c, Show d) => (forall m t. TestCaseConstraint
104testAgreement builder inputs = do
102testAgreement builder inputs = do
105 let identityResult = testPure builder inputs
103 let identityResult = testPure builder inputs
106 tracePerf "---------" $ return ()
104 tracePerf "---------" $ return ()
107− spiderResult <- S.runSpiderHost $ testTimeline builder inputs
105+ let spiderResult = testSpider builder inputs
108− tracePerf "---------" $ return ()
109− profiledResult <- S.runSpiderHost $ Prof.runProfiledM $ testTimeline builder inputs
110 tracePerf "---------" $ return ()
106 tracePerf "---------" $ return ()
111− let resultsAgree = identityResult == spiderResult && identityResult == profiledResult
107+ let resultsAgree = identityResult == spiderResult
112 if resultsAgree
108 if resultsAgree
113 then do --putStrLn "Success:"
109 then do --putStrLn "Success:"
114 --print identityResult
110 --print identityResult
@@ -116,7 +112,6 @@ testAgreement builder inputs = do
116 else do putStrLn "Failure:"
112 else do putStrLn "Failure:"
117 putStrLn $ "Pure result: " <> show identityResult
113 putStrLn $ "Pure result: " <> show identityResult
118 putStrLn $ "Spider result: " <> show spiderResult
114 putStrLn $ "Spider result: " <> show spiderResult
119− putStrLn $ "Profiled result: " <> show profiledResult
120 return resultsAgree
115 return resultsAgree
121
116
122type TestCaseConstraint t m = (Reflex t, MonadSample t m, MonadHold t m, MonadFix m, MonadFix (PushM t))
117type TestCaseConstraint t m = (Reflex t, MonadSample t m, MonadHold t m, MonadFix m, MonadFix (PushM t))
test/Reflex/Test/Micro.hs+2−8
@@ -322,14 +322,8 @@ testCases =
322 let e = never <$ switch b
322 let e = never <$ switch b
323 return $ void e
323 return $ void e
324 lazyHold
324 lazyHold
325− , testE "now-1" $ do
325+
326− e1 <- events1
326+
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
333 ] where
327 ] where
334
328
335 events1, events2, events3 :: TestPlan t m => m (Event t String)
329 events1, events2, events3 :: TestPlan t m => m (Event t String)
test/RequesterT.hs+2−63
@@ -1,36 +1,20 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE BangPatterns #-}
2{-# LANGUAGE BangPatterns #-}
3{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE GADTs #-}
4{-# LANGUAGE GADTs #-}
6−{-# LANGUAGE LambdaCase #-}
5+{-# LANGUAGE RankNTypes #-}
7−{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE RecursiveDo #-}
6{-# LANGUAGE RecursiveDo #-}
9{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE TemplateHaskell #-}
11−{-# LANGUAGE TypeApplications #-}
12−{-# LANGUAGE TypeFamilies #-}
13module Main where
8module Main where
14
9
15−import Control.Lens hiding (has)
10+import Control.Lens
16import Control.Monad
11import Control.Monad
17import Control.Monad.Fix
12import 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
22import qualified Data.Dependent.Map as DMap
13import qualified Data.Dependent.Map as DMap
23import Data.Dependent.Sum
14import Data.Dependent.Sum
24import Data.Functor.Misc
15import Data.Functor.Misc
25−import Data.List (words)
26−import Data.Map (Map)
27import qualified Data.Map as M
16import qualified Data.Map as M
28−#if !MIN_VERSION_these(4,11,0)
29−import Data.Semigroup ((<>))
30−#endif
31−import Data.Text (Text)
32import Data.These
17import Data.These
33−import Text.Read (readMaybe)
34
18
35#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))
19#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))
36import Data.These.Lens
20import Data.These.Lens
@@ -65,19 +49,12 @@ main = do
65 print os5
49 print os5
66 os6 <- runApp' (unwrapApp delayedPulse) [Just ()]
50 os6 <- runApp' (unwrapApp delayedPulse) [Just ()]
67 print os6
51 print os6
68− os7 <- runApp' testMatchRequestsWithResponses [ Just $ TestRequest_Increment 1 ]
69− print os7
70− os8 <- runApp' testMatchRequestsWithResponses [ Just $ TestRequest_Reverse "yoyo" ]
71− print os8
72 let ![[Just [1,2,3,4,5,6,7,8,9,10]]] = os1 -- The order is reversed here: see the documentation for 'runRequesterT'
52 let ![[Just [1,2,3,4,5,6,7,8,9,10]]] = os1 -- The order is reversed here: see the documentation for 'runRequesterT'
73 let ![[Just [9,7,5,3,1]],[Nothing,Nothing],[Just [10,8,6,4,2]],[Just [10,8,6,4,2],Nothing]] = os2
53 let ![[Just [9,7,5,3,1]],[Nothing,Nothing],[Just [10,8,6,4,2]],[Just [10,8,6,4,2],Nothing]] = os2
74 let ![[Nothing, Just [2]]] = os3
54 let ![[Nothing, Just [2]]] = os3
75 let ![[Nothing, Just [2]]] = os4
55 let ![[Nothing, Just [2]]] = os4
76 let ![[Nothing, Just [1, 2]]] = os5
56 let ![[Nothing, Just [1, 2]]] = os5
77 -- let ![[Nothing, Nothing]] = os6 -- TODO re-enable this test after issue #233 has been resolved
57 -- 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−
81 return ()
58 return ()
82
59
83unwrapRequest :: DSum tag RequestInt -> Int
60unwrapRequest :: DSum tag RequestInt -> Int
@@ -195,41 +172,3 @@ delayedPulse pulse = void $ flip runWithReplace (pure () <$ pulse) $ do
195 -- This has the effect of delaying pulse' from pulse
172 -- This has the effect of delaying pulse' from pulse
196 (_, pulse') <- runWithReplace (pure ()) $ pure (RequestInt 1) <$ pulse
173 (_, pulse') <- runWithReplace (pure ()) $ pure (RequestInt 1) <$ pulse
197 requestingIdentity pulse'
174 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+1−2
@@ -1,7 +1,7 @@
1module Main where
1module Main where
2
2
3import Control.Monad
3import Control.Monad
4−import Language.Haskell.HLint (hlint)
4+import Language.Haskell.HLint3 (hlint)
5import System.Directory
5import System.Directory
6import System.Exit (exitFailure, exitSuccess)
6import System.Exit (exitFailure, exitSuccess)
7import System.FilePath
7import System.FilePath
@@ -22,7 +22,6 @@ main = do
22 , "--ignore=Use unless"
22 , "--ignore=Use unless"
23 , "--ignore=Reduce duplication"
23 , "--ignore=Reduce duplication"
24 , "--cpp-define=USE_TEMPLATE_HASKELL"
24 , "--cpp-define=USE_TEMPLATE_HASKELL"
25− , "--cpp-define=DEBUG"
26 , "--ignore=Use tuple-section"
25 , "--ignore=Use tuple-section"
27 ]
26 ]
28 recurseInto = and <$> sequence
27 recurseInto = and <$> sequence