4c38730...develop · reflex

git.iko.soy/reflex

on develop help sign in

.github/workflows/haskell.ymlnew file+41

since splitsnapshots

unifiedsplit

@@ -0,0 +1,41 @@

1+name: github-action

3+on: [push, pull_request]

5+jobs:

6+ build:

7+ strategy:

8+ matrix:

9+ ghc: ['8.4.4', '8.6.5', '8.8.4', '8.10.2']

10+ os: ['ubuntu-latest', 'macos-latest']

11+ runs-on: ${{ matrix.os }}

12+

13+ name: GHC ${{ matrix.ghc }} on ${{ matrix.os }}

14+ steps:

15+ - uses: actions/checkout@v2

16+ - uses: actions/setup-haskell@v1

17+ with:

18+ ghc-version: ${{ matrix.ghc }}

19+ - name: Cache

20+ uses: actions/cache@v1

21+ env:

22+ cache-name: cache-cabal

23+ with:

24+ path: ~/.cabal

25+ key: ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }}

26+ restore-keys: |

27+ ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-

28+ ${{ runner.os }}-${{ matrix.ghc }}-build-

29+ ${{ runner.os }}-${{ matrix.ghc }}-

30+ ${{ runner.os }}

31+

32+ - name: Install dependencies

33+ run: |

34+ cabal update

35+ cabal build --only-dependencies --enable-tests --enable-benchmarks

36+ - name: Build

37+ run: cabal build --enable-tests --enable-benchmarks all

38+ - name: Run tests

39+ run: cabal test all

40+ - name: Build Docs

41+ run: cabal haddock

.travis.ymldeleted−177

@@ -1,177 +0,0 @@

1−# This Travis job script has been generated by a script via

2−#

3−# haskell-ci 'reflex.cabal' '--config' 'cabal.haskell-ci'

4−#

5−# For more information, see https://github.com/haskell-CI/haskell-ci

6−#

7−# version: 0.3.20190815

8−#

9−language: c

10−dist: xenial

11−git:

12− # whether to recursively clone submodules

13− submodules: false

14−cache:

15− directories:

16− - $HOME/.cabal/packages

17− - $HOME/.cabal/store

18−before_cache:

19− - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log

20− # remove files that are regenerated by 'cabal update'

21− - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.*

22− - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json

23− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache

24− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar

25− - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx

26− - rm -rfv $CABALHOME/packages/head.hackage

27−matrix:

28− include:

29− - compiler: ghcjs-8.4

30− addons: {"apt":{"sources":["hvr-ghc"],"packages":["cabal-install-3.0"]}}

31− - compiler: ghc-8.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+68−1

@@ -1,9 +1,76 @@

1# Revision history for reflex

3−## Unreleased

3+## 0.8.2.0

5+* Add `matchResponseMapWithRequests`, which it similar to `matchResponsesWithRequests` but allows processing of multiple responses at once.

7+## 0.8.1.1

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

5* Add `Reflex.Query.Base.mapQueryT`. See that module for documentation

64* Add `Reflex.Query.Base.mapQueryT`. See that module for documentation

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+

7## 0.6.3

74## 0.6.3

9* `Data.WeakBag.traverse` and `Data.FastWeakBag.traverse` have been deprecated.

76* `Data.WeakBag.traverse` and `Data.FastWeakBag.traverse` have been deprecated.

Quickref.md+1

@@ -54,6 +54,7 @@ Since MonadHold depends on MonadSample, any [S] function also runs in [H] contex

54[ ] difference :: Event a -> Event b -> Event a

55[ ] align :: Event a -> Event b -> Event (These a b)

56[ ] alignWith :: (These a b -> c) -> Event a -> Event b -> Event c

57+ -- Note align functions from Data.Align in semialign package

57[ ] mergeWith :: (a -> a -> a) -> [Event a] -> Event a

58[ ] mergeWith :: (a -> a -> a) -> [Event a] -> Event a

58[ ] leftmost :: [Event a] -> Event a

59[ ] leftmost :: [Event a] -> Event a

59[ ] mergeList :: [Event a] -> Event (NonEmpty a)

60[ ] mergeList :: [Event a] -> Event (NonEmpty a)

README.md+15−17

@@ -1,25 +1,23 @@

1−## [Reflex](https://reflex-frp.org/)

1+# [Reflex](https://reflex-frp.org/)

3−[![Hackage](https://img.shields.io/hackage/v/reflex.svg)](http://hackage.haskell.org/package/reflex)

3+[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/reflex.svg)](https://hackage.haskell.org/package/reflex) [![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/reflex/badge)](https://matrix.hackage.haskell.org/#/package/reflex) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](https://github.com/reflex-frp/reflex/blob/master/LICENSE)

5−### Practical Functional Reactive Programming

5+Interactive programs without callbacks or side-effects. Functional Reactive Programming (FRP) uses composable events and time-varying values to describe interactive systems as pure functions. Just like other pure functional code, functional reactive code is easier to get right on the first try, maintain, and reuse.

7−Reflex is a fully-deterministic, higher-order Functional Reactive Programming (FRP) interface and an engine that efficiently implements that interface.

7+Reflex is a fully-deterministic, higher-order Functional Reactive Programming interface and an engine that efficiently implements that interface.

9−[Reflex-DOM](https://github.com/reflex-frp/reflex-dom) is a framework built on Reflex that facilitates the development of web pages, including highly-interactive single-page apps.

9+**Visit https://reflex-frp.org for more information, tutorials, documentation and [examples](https://examples.reflex-frp.org/).**

11−A summary of Reflex functions is available in the [quick reference](Quickref.md).

11+## Resources

13−**Visit https://reflex-frp.org/ for more information, tutorials, documentation and [examples](https://examples.reflex-frp.org/).**

13+* [Official Website](https://reflex-frp.org)

14+* [Quick Reference](Quickref.md)

15+* [Reflex-DOM](https://github.com/reflex-frp/reflex-dom): A framework built on Reflex that facilitates the development of web pages, including highly-interactive single-page apps.

16+* [Obelisk](https://github.com/obsidiansystems/obelisk#obelisk): A framework built on Reflex and Reflex-DOM for functional reactive web and mobile applications, with batteries included.

17+* [Get started with Reflex](https://github.com/reflex-frp/reflex-platform)

18+* [/r/reflexfrp](https://www.reddit.com/r/reflexfrp)

19+* [irc.freenode.net #reflex-frp](http://webchat.freenode.net?channels=%23reflex-frp&uio=d4)

15−### Resources

21+## Hacking

16−[Get started with Reflex](https://github.com/reflex-frp/reflex-platform)

18−[/r/reflexfrp](https://www.reddit.com/r/reflexfrp)

23+From the root of a [Reflex Platform](https://github.com/reflex-frp/reflex-platform) checkout, run `./scripts/hack-on haskell-overlays/reflex-packages/dep/reflex`. This will check out the reflex source code into the `haskell-overlays/reflex-packages/dep/reflex` directory. You can then point that checkout at your fork, make changes, etc. Use the `./try-reflex` or `./scripts/work-on` scripts to start a shell in which you can test your changes.

19−

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 @@

2 "owner": "reflex-frp",

3 "repo": "reflex-platform",

4− "branch": "master",

4+ "branch": "develop",

5− "rev": "510b990d0b11f0626afbec5fe8575b5b2395391b",

5+ "rev": "f628398d076243a0851b27e625b37f65dff9b89b",

6− "sha256": "09cmahsbxr0963wq171c7j139iyzz49hramr4v9nsf684wcwkngv"

6+ "sha256": "0sl0hf1glgyb1vmf2mhw4r9ipmcqk1y19d3wsic7dix2jwywzrh9"

reflex.cabal+92−35

@@ -1,7 +1,17 @@

1Name: reflex

2−Version: 0.6.3

2+Version: 0.8.2.0

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+ .

4−Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system

11+ Reflex is a fully-deterministic, higher-order Functional Reactive Programming

12+ interface and an engine that efficiently implements that interface.

13+ .

14+ <https://reflex-frp.org>

5License: BSD3

15License: BSD3

6License-file: LICENSE

16License-file: LICENSE

7Author: Ryan Trinkle

17Author: Ryan Trinkle

@@ -9,7 +19,7 @@ Maintainer: ryan.trinkle@gmail.com

9Stability: Experimental

19Stability: Experimental

10Category: FRP

20Category: FRP

11Build-type: Simple

21Build-type: Simple

12−Cabal-version: >=1.9.2

22+Cabal-version: 1.22

13homepage: https://reflex-frp.org

23homepage: https://reflex-frp.org

14bug-reports: https://github.com/reflex-frp/reflex/issues

24bug-reports: https://github.com/reflex-frp/reflex/issues

15extra-source-files:

25extra-source-files:

@@ -18,8 +28,8 @@ extra-source-files:

18 ChangeLog.md

28 ChangeLog.md

20tested-with:

30tested-with:

21− GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.1,

31+ GHC ==8.4.4 || ==8.6.5 || ==8.8.1 || ==8.10.2,

22− GHCJS ==8.4

32+ GHCJS ==8.6

24flag use-reflex-optimizer

34flag use-reflex-optimizer

25 description: Use the GHC plugin Reflex.Optimizer on some of the modules in the package. This is still experimental.

35 description: Use the GHC plugin Reflex.Optimizer on some of the modules in the package. This is still experimental.

@@ -51,30 +61,33 @@ flag debug-cycles

51 default: False

61 default: False

52 manual: True

62 manual: True

54−

55flag split-these

64flag split-these

56 description: Use split these/semialign packages

65 description: Use split these/semialign packages

57 manual: False

66 manual: False

58 default: True

67 default: True

60library

69library

70+ default-language: Haskell2010

61 hs-source-dirs: src

71 hs-source-dirs: src

62 build-depends:

72 build-depends:

63 MemoTrie == 0.6.*,

73 MemoTrie == 0.6.*,

64− base >= 4.9 && < 4.14,

74+ base >= 4.11 && < 4.15,

65 bifunctors >= 5.2 && < 5.6,

75 bifunctors >= 5.2 && < 5.6,

66 comonad >= 5.0.4 && < 5.1,

76 comonad >= 5.0.4 && < 5.1,

77+ constraints >= 0.10 && <0.14,

67 constraints-extras >= 0.3 && < 0.4,

78 constraints-extras >= 0.3 && < 0.4,

68 containers >= 0.6 && < 0.7,

79 containers >= 0.6 && < 0.7,

69 data-default >= 0.5 && < 0.8,

80 data-default >= 0.5 && < 0.8,

70− dependent-map >= 0.3 && < 0.4,

81+ dependent-map >= 0.3 && < 0.5,

71 exception-transformers == 0.4.*,

82 exception-transformers == 0.4.*,

72 lens >= 4.7 && < 5,

83 lens >= 4.7 && < 5,

84+ mmorph >= 1.0 && < 1.2,

73 monad-control >= 1.0.1 && < 1.1,

85 monad-control >= 1.0.1 && < 1.1,

74 mtl >= 2.1 && < 2.3,

86 mtl >= 2.1 && < 2.3,

87+ patch >= 0.0.1 && < 0.1,

75− prim-uniq >= 0.1.0.1 && < 0.2,

88+ prim-uniq >= 0.1.0.1 && < 0.3,

76 primitive >= 0.5 && < 0.8,

89 primitive >= 0.5 && < 0.8,

77− profunctors >= 5.3 && < 5.6,

90+ profunctors >= 5.3 && < 5.7,

78 random == 1.1.*,

91 random == 1.1.*,

79 ref-tf == 0.4.*,

92 ref-tf == 0.4.*,

80 reflection == 2.1.*,

93 reflection == 2.1.*,

@@ -84,10 +97,10 @@ library

84 time >= 1.4 && < 1.10,

97 time >= 1.4 && < 1.10,

85 transformers >= 0.5.6.0 && < 0.6,

98 transformers >= 0.5.6.0 && < 0.6,

86 unbounded-delays >= 0.1.0.0 && < 0.2,

99 unbounded-delays >= 0.1.0.0 && < 0.2,

87− witherable >= 0.3 && < 0.3.2

100+ witherable >= 0.3 && < 0.5

101

89 if flag(split-these)

102 if flag(split-these)

90− build-depends: these >= 1 && <1.1,

103+ build-depends: these >= 1 && <1.2,

91 semialign >=1 && <1.2,

104 semialign >=1 && <1.2,

92 monoidal-containers >= 0.6 && < 0.7

105 monoidal-containers >= 0.6 && < 0.7

93 else

106 else

@@ -99,7 +112,6 @@ library

99 Data.AppendMap,

112 Data.AppendMap,

100 Data.FastMutableIntMap,

113 Data.FastMutableIntMap,

101 Data.FastWeakBag,

114 Data.FastWeakBag,

102− Data.Functor.Misc,

103 Data.Map.Misc,

115 Data.Map.Misc,

104 Data.WeakBag,

116 Data.WeakBag,

105 Reflex,

117 Reflex,

@@ -119,15 +131,9 @@ library

119 Reflex.FastWeak,

131 Reflex.FastWeak,

120 Reflex.FunctorMaybe,

132 Reflex.FunctorMaybe,

121 Reflex.Host.Class,

133 Reflex.Host.Class,

134+ Reflex.Host.Headless,

122 Reflex.Network,

135 Reflex.Network,

123 Reflex.NotReady.Class,

136 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,

131 Reflex.PerformEvent.Base,

137 Reflex.PerformEvent.Base,

132 Reflex.PerformEvent.Class,

138 Reflex.PerformEvent.Class,

133 Reflex.PostBuild.Base,

139 Reflex.PostBuild.Base,

@@ -146,12 +152,22 @@ library

146 Reflex.Widget.Basic,

152 Reflex.Widget.Basic,

147 Reflex.Workflow

153 Reflex.Workflow

148

154

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+

149− -- ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively

165+ ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively

150− ghc-options: -O0

151

166

152 if flag(debug-trace-events)

167 if flag(debug-trace-events)

153 cpp-options: -DDEBUG_TRACE_EVENTS

168 cpp-options: -DDEBUG_TRACE_EVENTS

154− build-depends: bytestring

169+ build-depends:

170+ bytestring >= 0.10.8 && < 0.11

155

171

156 if flag(use-reflex-optimizer)

172 if flag(use-reflex-optimizer)

157 cpp-options: -DUSE_REFLEX_OPTIMIZER

173 cpp-options: -DUSE_REFLEX_OPTIMIZER

@@ -159,7 +175,7 @@ library

159 exposed-modules: Reflex.Optimizer

175 exposed-modules: Reflex.Optimizer

160

176

161 if flag(debug-propagation)

177 if flag(debug-propagation)

162− cpp-options: -DDEBUG

178+ cpp-options: -DDEBUG -DDEBUG_TRACE_PROPAGATION -DDEBUG_TRACE_INVALIDATION

163

179

164 if flag(debug-cycles)

180 if flag(debug-cycles)

165 cpp-options: -DDEBUG_CYCLES

181 cpp-options: -DDEBUG_CYCLES

@@ -167,26 +183,26 @@ library

167 if flag(use-template-haskell)

183 if flag(use-template-haskell)

168 cpp-options: -DUSE_TEMPLATE_HASKELL

184 cpp-options: -DUSE_TEMPLATE_HASKELL

169 build-depends:

185 build-depends:

170− dependent-sum >= 0.6 && < 0.7,

186+ dependent-sum >= 0.6 && < 0.8,

171− haskell-src-exts >= 1.16 && < 1.23,

187+ haskell-src-exts >= 1.16 && < 1.24,

172 haskell-src-meta >= 0.6 && < 0.9,

188 haskell-src-meta >= 0.6 && < 0.9,

173− template-haskell >= 2.9 && < 2.16

189+ template-haskell >= 2.9 && < 2.17

174 exposed-modules:

190 exposed-modules:

175 Reflex.Dynamic.TH

191 Reflex.Dynamic.TH

176 other-extensions: TemplateHaskell

192 other-extensions: TemplateHaskell

177 else

193 else

178 build-depends:

194 build-depends:

179− dependent-sum >= 0.6 && < 0.7

195+ dependent-sum >= 0.6 && < 0.8

180

196

181 if flag(fast-weak) && impl(ghcjs)

197 if flag(fast-weak) && impl(ghcjs)

182 cpp-options: -DGHCJS_FAST_WEAK

198 cpp-options: -DGHCJS_FAST_WEAK

183

199

184 if impl(ghcjs)

200 if impl(ghcjs)

185− build-depends: ghcjs-base

201+ build-depends:

186−

202+ ghcjs-base == 0.2.*

187−

188

203

189test-suite semantics

204test-suite semantics

205+ default-language: Haskell2010

190 type: exitcode-stdio-1.0

206 type: exitcode-stdio-1.0

191 main-is: semantics.hs

207 main-is: semantics.hs

192 hs-source-dirs: test

208 hs-source-dirs: test

@@ -212,6 +228,7 @@ test-suite semantics

212 Reflex.TestPlan

228 Reflex.TestPlan

213

229

214test-suite CrossImpl

230test-suite CrossImpl

231+ default-language: Haskell2010

215 type: exitcode-stdio-1.0

232 type: exitcode-stdio-1.0

216 main-is: Reflex/Test/CrossImpl.hs

233 main-is: Reflex/Test/CrossImpl.hs

217 hs-source-dirs: test

234 hs-source-dirs: test

@@ -233,6 +250,7 @@ test-suite CrossImpl

233 Reflex.Plan.Pure

250 Reflex.Plan.Pure

234

251

235test-suite hlint

252test-suite hlint

253+ default-language: Haskell2010

236 type: exitcode-stdio-1.0

254 type: exitcode-stdio-1.0

237 main-is: hlint.hs

255 main-is: hlint.hs

238 hs-source-dirs: test

256 hs-source-dirs: test

@@ -240,11 +258,15 @@ test-suite hlint

240 , directory

258 , directory

241 , filepath

259 , filepath

242 , filemanip

260 , filemanip

243− , hlint < 2.1 || >= 2.2.2

261+ if impl(ghc >= 8.8)

262+ build-depends: hlint >= 3 && < 4

263+ else

264+ build-depends: hlint (< 2.1 || >= 2.2.2) && < 4

244 if impl(ghcjs)

265 if impl(ghcjs)

245 buildable: False

266 buildable: False

246

267

247test-suite EventWriterT

268test-suite EventWriterT

269+ default-language: Haskell2010

248 type: exitcode-stdio-1.0

270 type: exitcode-stdio-1.0

249 main-is: EventWriterT.hs

271 main-is: EventWriterT.hs

250 hs-source-dirs: test

272 hs-source-dirs: test

@@ -268,6 +290,7 @@ test-suite EventWriterT

268

290

269

291

270test-suite DebugCycles

292test-suite DebugCycles

293+ default-language: Haskell2010

271 type: exitcode-stdio-1.0

294 type: exitcode-stdio-1.0

272 main-is: DebugCycles.hs

295 main-is: DebugCycles.hs

273 hs-source-dirs: test

296 hs-source-dirs: test

@@ -296,20 +319,24 @@ test-suite DebugCycles

296

319

297

320

298test-suite RequesterT

321test-suite RequesterT

322+ default-language: Haskell2010

299 type: exitcode-stdio-1.0

323 type: exitcode-stdio-1.0

300 main-is: RequesterT.hs

324 main-is: RequesterT.hs

301 hs-source-dirs: test

325 hs-source-dirs: test

302 build-depends: base

326 build-depends: base

327+ , constraints

328+ , constraints-extras

303 , containers

329 , containers

304 , deepseq

330 , deepseq

305− , dependent-sum

306 , dependent-map

331 , dependent-map

332+ , dependent-sum

307 , lens

333 , lens

308 , mtl

334 , mtl

335+ , ref-tf

336+ , reflex

337+ , text

309 , these

338 , these

310 , transformers

339 , transformers

311− , reflex

312− , ref-tf

313

340

314 if flag(split-these)

341 if flag(split-these)

315 build-depends: these-lens

342 build-depends: these-lens

@@ -319,7 +346,31 @@ test-suite RequesterT

319 Reflex.Plan.Pure

346 Reflex.Plan.Pure

320 Test.Run

347 Test.Run

321

348

349+test-suite Headless

350+ default-language: Haskell2010

351+ type: exitcode-stdio-1.0

352+ main-is: Headless.hs

353+ hs-source-dirs: test

354+ build-depends: base

355+ , reflex

356+

357+test-suite Adjustable

358+ default-language: Haskell2010

359+ type: exitcode-stdio-1.0

360+ main-is: Adjustable.hs

361+ hs-source-dirs: test

362+ build-depends: base

363+ , containers

364+ , dependent-sum

365+ , reflex

366+ , ref-tf

367+ , these

368+

369+ other-modules:

370+ Test.Run

371+

322test-suite QueryT

372test-suite QueryT

373+ default-language: Haskell2010

323 type: exitcode-stdio-1.0

374 type: exitcode-stdio-1.0

324 main-is: QueryT.hs

375 main-is: QueryT.hs

325 hs-source-dirs: test

376 hs-source-dirs: test

@@ -331,6 +382,7 @@ test-suite QueryT

331 , lens

382 , lens

332 , monoidal-containers

383 , monoidal-containers

333 , mtl

384 , mtl

385+ , patch

334 , ref-tf

386 , ref-tf

335 , reflex

387 , reflex

336 , these

388 , these

@@ -346,6 +398,7 @@ test-suite QueryT

346 Reflex.Plan.Pure

398 Reflex.Plan.Pure

347

399

348test-suite GC-Semantics

400test-suite GC-Semantics

401+ default-language: Haskell2010

349 type: exitcode-stdio-1.0

402 type: exitcode-stdio-1.0

350 main-is: GC.hs

403 main-is: GC.hs

351 hs-source-dirs: test

404 hs-source-dirs: test

@@ -355,6 +408,7 @@ test-suite GC-Semantics

355 , dependent-map

408 , dependent-map

356 , deepseq

409 , deepseq

357 , mtl

410 , mtl

411+ , patch

358 , these

412 , these

359 , transformers

413 , transformers

360 , reflex

414 , reflex

@@ -370,6 +424,7 @@ test-suite GC-Semantics

370 Test.Run

424 Test.Run

371

425

372test-suite rootCleanup

426test-suite rootCleanup

427+ default-language: Haskell2010

373 type: exitcode-stdio-1.0

428 type: exitcode-stdio-1.0

374 main-is: rootCleanup.hs

429 main-is: rootCleanup.hs

375 hs-source-dirs: test

430 hs-source-dirs: test

@@ -387,6 +442,7 @@ test-suite rootCleanup

387 Test.Run

442 Test.Run

388

443

389benchmark spider-bench

444benchmark spider-bench

445+ default-language: Haskell2010

390 type: exitcode-stdio-1.0

446 type: exitcode-stdio-1.0

391 hs-source-dirs: bench test

447 hs-source-dirs: bench test

392 main-is: Main.hs

448 main-is: Main.hs

@@ -411,6 +467,7 @@ benchmark spider-bench

411 Reflex.Bench.Focused

467 Reflex.Bench.Focused

412

468

413benchmark saulzar-bench

469benchmark saulzar-bench

470+ default-language: Haskell2010

414 type: exitcode-stdio-1.0

471 type: exitcode-stdio-1.0

415 hs-source-dirs: bench test

472 hs-source-dirs: bench test

416 c-sources: bench-cbits/checkCapability.c

473 c-sources: bench-cbits/checkCapability.c

release.nix+2−2

@@ -1,12 +1,12 @@

1{ reflex-platform-fun ? import ./dep/reflex-platform

2+, supportedSystems ? ["x86_64-linux" "x86_64-darwin"]

2}:

3}:

4let

5let

5 native-reflex-platform = reflex-platform-fun {};

6 native-reflex-platform = reflex-platform-fun {};

6 inherit (native-reflex-platform.nixpkgs) lib;

7 inherit (native-reflex-platform.nixpkgs) lib;

7− systems = ["x86_64-linux" "x86_64-darwin"];

9− perPlatform = lib.genAttrs systems (system: let

9+ perPlatform = lib.genAttrs supportedSystems (system: let

10 reflex-platform = reflex-platform-fun { inherit system; };

11 compilers = [

12 "ghc"

src/Data/AppendMap.hs+1−1

@@ -71,7 +71,7 @@ mapMaybeNoNull f as =

71 then Nothing

72 else Just bs

74−-- TODO: Move instances to `Reflex.Patch`

74+-- TODO: Move instances to `Data.Patch`

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

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)

36import qualified Data.IntMap.Strict as IntMap

37import Data.IORef

38−import Reflex.Patch.Class

38+import Data.Patch.Class

39−import Reflex.Patch.IntMap

39+import Data.Patch.IntMap

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.

@@ -85,7 +85,7 @@ getFrozenAndClear (FastMutableIntMap r) = do

85 writeIORef r IntMap.empty

86 return result

88−-- | Updates the value of a 'FastMutableIntMap' with the given patch (see 'Reflex.Patch.IntMap'),

88+-- | Updates the value of a 'FastMutableIntMap' with the given patch (see 'Data.Patch.IntMap'),

89-- and returns an 'IntMap' with the modified keys and values.

90applyPatch :: FastMutableIntMap a -> PatchIntMap a -> IO (IntMap a)

91applyPatch (FastMutableIntMap r) p@(PatchIntMap m) = do

src/Data/Functor/Misc.hsdeleted−235

@@ -1,235 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveDataTypeable #-}

3−{-# LANGUAGE DeriveFunctor #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE GADTs #-}

7−{-# LANGUAGE LambdaCase #-}

8−{-# LANGUAGE MultiParamTypeClasses #-}

9−{-# LANGUAGE PatternSynonyms #-}

10−{-# LANGUAGE PolyKinds #-}

11−{-# LANGUAGE RankNTypes #-}

12−{-# LANGUAGE ScopedTypeVariables #-}

13−{-# LANGUAGE StandaloneDeriving #-}

14−#ifdef USE_REFLEX_OPTIMIZER

15−{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

16−#endif

17−-- | This module provides types and functions with no particular theme, but

18−-- which are relevant to the use of 'Functor'-based datastructures like

19−-- 'Data.Dependent.Map.DMap'.

20−module Data.Functor.Misc

21− ( -- * Const2

22− Const2 (..)

23− , unConst2

24− , dmapToMap

25− , dmapToIntMap

26− , dmapToMapWith

27− , mapToDMap

28− , weakenDMapWith

29− -- * WrapArg

30− , WrapArg (..)

31− -- * Convenience functions for DMap

32− , mapWithFunctorToDMap

33− , intMapWithFunctorToDMap

34− , mapKeyValuePairsMonotonic

35− , combineDMapsWithKey

36− , EitherTag (..)

37− , dmapToThese

38− , eitherToDSum

39− , dsumToEither

40− , ComposeMaybe (..)

41− ) where

42−

43−import Control.Applicative ((<$>))

44−import Control.Monad.Identity

45−import Data.Dependent.Map (DMap)

46−import qualified Data.Dependent.Map as DMap

47−import Data.Dependent.Sum

48−import Data.GADT.Compare

49−import Data.GADT.Show

50−import Data.IntMap (IntMap)

51−import qualified Data.IntMap as IntMap

52−import Data.Map (Map)

53−import qualified Data.Map as Map

54−import Data.Some (Some(Some))

55−import Data.These

56−import Data.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

44-- |Given a @'Map' k (Maybe v)@ representing keys to insert/update (@Just@) or delete (@Nothing@), produce a new map from the given input @'Map' k v@.

45--

46−-- See also 'Reflex.Patch.Map' and 'Reflex.Patch.MapWithMove'.

46+-- See also 'Data.Patch.Map' and 'Data.Patch.MapWithMove'.

47applyMap :: Ord k => Map k (Maybe v) -> Map k v -> Map k v

48applyMap patch old = insertions `Map.union` (old `Map.difference` deletions)

49 where (deletions, insertions) = Map.mapEither maybeToEither patch

src/Reflex/Adjustable/Class.hs+3−2

@@ -30,7 +30,8 @@ module Reflex.Adjustable.Class

31import Control.Monad.Identity

32import Control.Monad.Reader

33−import Data.Dependent.Map (DMap, GCompare (..))

33+import Data.Dependent.Map (DMap)

34+import Data.GADT.Compare (GCompare(..))

34import qualified Data.Dependent.Map as DMap

35import qualified Data.Dependent.Map as DMap

35import Data.Functor.Constant

36import Data.Functor.Constant

36import Data.Functor.Misc

37import Data.Functor.Misc

@@ -39,7 +40,7 @@ import qualified Data.IntMap.Strict as IntMap

39import Data.Map (Map)

40import Data.Map (Map)

41import Reflex.Class

42import Reflex.Class

42−import Reflex.Patch.DMapWithMove

43+import Data.Patch.DMapWithMove

44-- | A 'Monad' that supports adjustment over time. After an action has been

45-- | A 'Monad' that supports adjustment over time. After an action has been

45-- run, if the given events fire, it will adjust itself so that its net effect

46-- run, if the given events fire, it will adjust itself so that its net effect

src/Reflex/BehaviorWriter/Base.hs+16−7

@@ -1,6 +1,6 @@

1{-|

2Module: Reflex.BehaviorWriter.Base

3−Description: Implementation of MonadBehaviorWriter

3+Description: Implementation of BehaviorWriter

4-}

5{-# LANGUAGE CPP #-}

6{-# LANGUAGE FlexibleInstances #-}

@@ -24,6 +24,7 @@ module Reflex.BehaviorWriter.Base

24import Control.Monad.Exception

25import Control.Monad.Identity

26import Control.Monad.IO.Class

27+import Control.Monad.Morph

27import Control.Monad.Reader

28import Control.Monad.Reader

28import Control.Monad.Ref

29import Control.Monad.Ref

29import Control.Monad.State.Strict

30import Control.Monad.State.Strict

@@ -46,9 +47,20 @@ import Reflex.Query.Class

46import Reflex.Requester.Class

47import Reflex.Requester.Class

47import Reflex.TriggerEvent.Class

48import Reflex.TriggerEvent.Class

49−-- | A basic implementation of 'MonadBehaviorWriter'.

50+-- | A basic implementation of 'BehaviorWriter'.

50newtype BehaviorWriterT t w m a = BehaviorWriterT { unBehaviorWriterT :: StateT [Behavior t w] m a }

51newtype BehaviorWriterT t w m a = BehaviorWriterT { unBehaviorWriterT :: StateT [Behavior t w] m a }

51− deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadAsyncException, MonadException) -- The list is kept in reverse order

52+ -- The list is kept in reverse order

53+ deriving

54+ ( Functor

55+ , Applicative

56+ , Monad

57+ , MonadTrans

58+ , MFunctor

59+ , MonadIO

60+ , MonadFix

61+ , MonadAsyncException

62+ , MonadException

63+ )

53-- | Run a 'BehaviorWriterT' action. The behavior writer output will be provided

65-- | Run a 'BehaviorWriterT' action. The behavior writer output will be provided

54-- along with the result of the action.

66-- along with the result of the action.

@@ -73,9 +85,6 @@ withBehaviorWriterT f dw = do

73deriving instance MonadHold t m => MonadHold t (BehaviorWriterT t w m)

85deriving instance MonadHold t m => MonadHold t (BehaviorWriterT t w m)

74deriving instance MonadSample t m => MonadSample t (BehaviorWriterT t w m)

86deriving instance MonadSample t m => MonadSample t (BehaviorWriterT t w m)

76−instance MonadTrans (BehaviorWriterT t w) where

77− lift = BehaviorWriterT . lift

78−

79instance MonadRef m => MonadRef (BehaviorWriterT t w m) where

88instance MonadRef m => MonadRef (BehaviorWriterT t w m) where

80 type Ref (BehaviorWriterT t w m) = Ref m

89 type Ref (BehaviorWriterT t w m) = Ref m

81 newRef = lift . newRef

90 newRef = lift . newRef

@@ -89,7 +98,7 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (BehaviorWri

89 newEventWithTrigger = lift . newEventWithTrigger

98 newEventWithTrigger = lift . newEventWithTrigger

90 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

99 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

100

92−instance (Monad m, Monoid w, Reflex t) => MonadBehaviorWriter t w (BehaviorWriterT t w m) where

101+instance (Monad m, Monoid w, Reflex t) => BehaviorWriter t w (BehaviorWriterT t w m) where

93 tellBehavior w = BehaviorWriterT $ modify (w :)

102 tellBehavior w = BehaviorWriterT $ modify (w :)

103

95instance MonadReader r m => MonadReader r (BehaviorWriterT t w m) where

104instance MonadReader r m => MonadReader r (BehaviorWriterT t w m) where

src/Reflex/BehaviorWriter/Class.hs+11−5

@@ -1,8 +1,9 @@

1{-|

2Module: Reflex.BehaviorWriter.Class

3−Description: This module defines the 'MonadBehaviorWriter' class

3+Description: This module defines the 'BehaviorWriter' class

4-}

5{-# LANGUAGE CPP #-}

6+{-# LANGUAGE ConstraintKinds #-}

6{-# LANGUAGE FlexibleInstances #-}

7{-# LANGUAGE FlexibleInstances #-}

7{-# LANGUAGE FunctionalDependencies #-}

8{-# LANGUAGE FunctionalDependencies #-}

8{-# LANGUAGE UndecidableInstances #-}

9{-# LANGUAGE UndecidableInstances #-}

@@ -10,16 +11,21 @@ Description: This module defines the 'MonadBehaviorWriter' class

10{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

11{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

11#endif

12#endif

12module Reflex.BehaviorWriter.Class

13module Reflex.BehaviorWriter.Class

13− ( MonadBehaviorWriter (..)

14+ ( MonadBehaviorWriter

15+ , BehaviorWriter(..)

14 ) where

16 ) where

16import Control.Monad.Reader (ReaderT, lift)

18import Control.Monad.Reader (ReaderT, lift)

17import Reflex.Class (Behavior)

19import Reflex.Class (Behavior)

21+{-# DEPRECATED MonadBehaviorWriter "Use 'BehaviorWriter' instead" #-}

22+-- | Type synonym for 'BehaviorWriter'

23+type MonadBehaviorWriter = BehaviorWriter

24+

19−-- | 'MonadBehaviorWriter' efficiently collects 'Behavior' values using 'tellBehavior'

25+-- | 'BehaviorWriter' efficiently collects 'Behavior' values using 'tellBehavior'

20-- and combines them monoidally to provide a 'Behavior' result.

26-- and combines them monoidally to provide a 'Behavior' result.

21−class (Monad m, Monoid w) => MonadBehaviorWriter t w m | m -> t w where

27+class (Monad m, Monoid w) => BehaviorWriter t w m | m -> t w where

22 tellBehavior :: Behavior t w -> m ()

28 tellBehavior :: Behavior t w -> m ()

24−instance MonadBehaviorWriter t w m => MonadBehaviorWriter t w (ReaderT r m) where

30+instance BehaviorWriter t w m => BehaviorWriter t w (ReaderT r m) where

25 tellBehavior = lift . tellBehavior

31 tellBehavior = lift . tellBehavior

src/Reflex/Class.hs+26−6

@@ -29,7 +29,7 @@

29-- convenience functions for working with 'Event's, 'Behavior's, and other

30-- signals.

31module Reflex.Class

32− ( module Reflex.Patch

32+ ( module Data.Patch

33 -- * Primitives

34 , Reflex (..)

35 , mergeInt

@@ -180,7 +180,7 @@ import Prelude hiding (zip, zipWith)

180import Data.These.Combinators (justThese)

181#endif

182#if MIN_VERSION_semialign(1,1,0)

183−import Data.Zip (Zip (..))

183+import Data.Zip (Zip (..), Unzip (..))

184#endif

185#endif

186

@@ -196,7 +196,8 @@ import Data.Align

196import Data.Bifunctor

197import Data.Coerce

198import Data.Default

199−import Data.Dependent.Map (DMap, DSum (..))

199+import Data.Dependent.Map (DMap)

200+import Data.Dependent.Sum (DSum (..))

200import qualified Data.Dependent.Map as DMap

201import qualified Data.Dependent.Map as DMap

201import Data.Functor.Compose

202import Data.Functor.Compose

202import Data.Functor.Product

203import Data.Functor.Product

@@ -210,7 +211,7 @@ import Data.IntMap.Strict (IntMap)

210import qualified Data.IntMap.Strict as IntMap

211import qualified Data.IntMap.Strict as IntMap

211import Data.List.NonEmpty (NonEmpty (..))

212import Data.List.NonEmpty (NonEmpty (..))

212import Data.Map (Map)

213import Data.Map (Map)

213−import Data.Semigroup (Semigroup, sconcat, stimes, (<>))

214+import Data.Semigroup (Semigroup (..))

214import Data.Some (Some(Some))

215import Data.Some (Some(Some))

215import Data.String

216import Data.String

216import Data.These

217import Data.These

@@ -220,8 +221,8 @@ import Data.Witherable (Filterable(..))

220import qualified Data.Witherable as W

221import qualified Data.Witherable as W

221import Reflex.FunctorMaybe (FunctorMaybe)

222import Reflex.FunctorMaybe (FunctorMaybe)

222import qualified Reflex.FunctorMaybe

223import qualified Reflex.FunctorMaybe

223−import Reflex.Patch

224+import Data.Patch

224−import qualified Reflex.Patch.MapWithMove as PatchMapWithMove

225+import qualified Data.Patch.MapWithMove as PatchMapWithMove

225

226

226import Debug.Trace (trace)

227import Debug.Trace (trace)

227

228

@@ -420,6 +421,13 @@ class MonadSample t m => MonadHold t m where

420 -- | Create a new 'Event' that only occurs only once, on the first occurrence of

421 -- | Create a new 'Event' that only occurs only once, on the first occurrence of

421 -- the supplied 'Event'.

422 -- the supplied 'Event'.

422 headE :: Event t a -> m (Event t a)

423 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

423

431

424-- | Accumulate an 'Incremental' with the supplied initial value and the firings of the provided 'Event',

432-- | Accumulate an 'Incremental' with the supplied initial value and the firings of the provided 'Event',

425-- using the combining function to produce a patch.

433-- using the combining function to produce a patch.

@@ -565,6 +573,7 @@ instance MonadHold t m => MonadHold t (ReaderT r m) where

565 holdIncremental a0 = lift . holdIncremental a0

573 holdIncremental a0 = lift . holdIncremental a0

566 buildDynamic a0 = lift . buildDynamic a0

574 buildDynamic a0 = lift . buildDynamic a0

567 headE = lift . headE

575 headE = lift . headE

576+ now = lift now

568

577

569instance (MonadSample t m, Monoid r) => MonadSample t (WriterT r m) where

578instance (MonadSample t m, Monoid r) => MonadSample t (WriterT r m) where

570 sample = lift . sample

579 sample = lift . sample

@@ -575,6 +584,7 @@ instance (MonadHold t m, Monoid r) => MonadHold t (WriterT r m) where

575 holdIncremental a0 = lift . holdIncremental a0

584 holdIncremental a0 = lift . holdIncremental a0

576 buildDynamic a0 = lift . buildDynamic a0

585 buildDynamic a0 = lift . buildDynamic a0

577 headE = lift . headE

586 headE = lift . headE

587+ now = lift now

578

588

579instance MonadSample t m => MonadSample t (StateT s m) where

589instance MonadSample t m => MonadSample t (StateT s m) where

580 sample = lift . sample

590 sample = lift . sample

@@ -585,6 +595,7 @@ instance MonadHold t m => MonadHold t (StateT s m) where

585 holdIncremental a0 = lift . holdIncremental a0

595 holdIncremental a0 = lift . holdIncremental a0

586 buildDynamic a0 = lift . buildDynamic a0

596 buildDynamic a0 = lift . buildDynamic a0

587 headE = lift . headE

597 headE = lift . headE

598+ now = lift now

588

599

589instance MonadSample t m => MonadSample t (ExceptT e m) where

600instance MonadSample t m => MonadSample t (ExceptT e m) where

590 sample = lift . sample

601 sample = lift . sample

@@ -595,6 +606,7 @@ instance MonadHold t m => MonadHold t (ExceptT e m) where

595 holdIncremental a0 = lift . holdIncremental a0

606 holdIncremental a0 = lift . holdIncremental a0

596 buildDynamic a0 = lift . buildDynamic a0

607 buildDynamic a0 = lift . buildDynamic a0

597 headE = lift . headE

608 headE = lift . headE

609+ now = lift now

598

610

599instance (MonadSample t m, Monoid w) => MonadSample t (RWST r w s m) where

611instance (MonadSample t m, Monoid w) => MonadSample t (RWST r w s m) where

600 sample = lift . sample

612 sample = lift . sample

@@ -605,6 +617,7 @@ instance (MonadHold t m, Monoid w) => MonadHold t (RWST r w s m) where

605 holdIncremental a0 = lift . holdIncremental a0

617 holdIncremental a0 = lift . holdIncremental a0

606 buildDynamic a0 = lift . buildDynamic a0

618 buildDynamic a0 = lift . buildDynamic a0

607 headE = lift . headE

619 headE = lift . headE

620+ now = lift now

608

621

609instance MonadSample t m => MonadSample t (ContT r m) where

622instance MonadSample t m => MonadSample t (ContT r m) where

610 sample = lift . sample

623 sample = lift . sample

@@ -615,6 +628,7 @@ instance MonadHold t m => MonadHold t (ContT r m) where

615 holdIncremental a0 = lift . holdIncremental a0

628 holdIncremental a0 = lift . holdIncremental a0

616 buildDynamic a0 = lift . buildDynamic a0

629 buildDynamic a0 = lift . buildDynamic a0

617 headE = lift . headE

630 headE = lift . headE

631+ now = lift now

618

632

619--------------------------------------------------------------------------------

633--------------------------------------------------------------------------------

620-- Convenience functions

634-- Convenience functions

@@ -1091,6 +1105,12 @@ instance Reflex t => Zip (Event t) where

1091 zip x y = mapMaybe justThese $ align x y

1105 zip x y = mapMaybe justThese $ align x y

1092#endif

1106#endif

1093

1107

1108+#ifdef MIN_VERSION_semialign

1109+#if MIN_VERSION_semialign(1,1,0)

1110+instance Reflex t => Unzip (Event t) where

1111+ unzip = splitE

1112+#endif

1113+#endif

1094

1114

1095-- | Create a new 'Event' that only occurs if the supplied 'Event' occurs and

1115-- | Create a new 'Event' that only occurs if the supplied 'Event' occurs and

1096-- the 'Behavior' is true at the time of occurrence.

1116-- the 'Behavior' is true at the time of occurrence.

src/Reflex/Dynamic.hs+15−1

@@ -53,10 +53,12 @@ module Reflex.Dynamic

53 , foldDynMaybe

54 , foldDynMaybeM

55 , joinDynThroughMap

56+ , joinDynThroughIntMap

56 , traceDyn

57 , traceDyn

57 , traceDynWith

58 , traceDynWith

58 , splitDynPure

59 , splitDynPure

59 , distributeMapOverDynPure

60 , distributeMapOverDynPure

61+ , distributeIntMapOverDynPure

60 , distributeDMapOverDynPure

62 , distributeDMapOverDynPure

61 , distributeListOverDynPure

63 , distributeListOverDynPure

62 , Demux

64 , Demux

@@ -88,6 +90,8 @@ import Data.Dependent.Map (DMap)

88import qualified Data.Dependent.Map as DMap

90import qualified Data.Dependent.Map as DMap

89import Data.Dependent.Sum (DSum (..))

91import Data.Dependent.Sum (DSum (..))

90import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))

92import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))

93+import Data.IntMap (IntMap)

94+import qualified Data.IntMap as IntMap

91import Data.Map (Map)

95import Data.Map (Map)

92import Data.Maybe

96import Data.Maybe

93import Data.Monoid ((<>))

97import Data.Monoid ((<>))

@@ -202,6 +206,11 @@ splitDynPure d = (fmap fst d, fmap snd d)

202distributeMapOverDynPure :: (Reflex t, Ord k) => Map k (Dynamic t v) -> Dynamic t (Map k v)

206distributeMapOverDynPure :: (Reflex t, Ord k) => Map k (Dynamic t v) -> Dynamic t (Map k v)

203distributeMapOverDynPure = fmap dmapToMap . distributeDMapOverDynPure . mapWithFunctorToDMap

207distributeMapOverDynPure = fmap dmapToMap . distributeDMapOverDynPure . mapWithFunctorToDMap

204

208

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+

205-- | Convert a list with 'Dynamic' elements into a 'Dynamic' of a list with

214-- | Convert a list with 'Dynamic' elements into a 'Dynamic' of a list with

206-- non-'Dynamic' elements, preserving the order of the elements.

215-- non-'Dynamic' elements, preserving the order of the elements.

207{-# DEPRECATED distributeListOverDynPure "Use 'distributeListOverDyn' instead" #-}

216{-# DEPRECATED distributeListOverDynPure "Use 'distributeListOverDyn' instead" #-}

@@ -214,6 +223,11 @@ distributeListOverDynPure = distributeListOverDyn

214joinDynThroughMap :: forall t k a. (Reflex t, Ord k) => Dynamic t (Map k (Dynamic t a)) -> Dynamic t (Map k a)

223joinDynThroughMap :: forall t k a. (Reflex t, Ord k) => Dynamic t (Map k (Dynamic t a)) -> Dynamic t (Map k a)

215joinDynThroughMap = (distributeMapOverDynPure =<<)

224joinDynThroughMap = (distributeMapOverDynPure =<<)

216

225

226+-- | Combine a 'Dynamic' of an 'IntMap' of 'Dynamic's into a 'Dynamic'

227+-- with the current values of the 'Dynamic's in a map.

228+joinDynThroughIntMap :: forall t a. (Reflex t) => Dynamic t (IntMap (Dynamic t a)) -> Dynamic t (IntMap a)

229+joinDynThroughIntMap = (distributeIntMapOverDynPure =<<)

230+

217-- | Print the value of the 'Dynamic' when it is first read and on each

231-- | Print the value of the 'Dynamic' when it is first read and on each

218-- subsequent change that is observed (as 'traceEvent'), prefixed with the

232-- subsequent change that is observed (as 'traceEvent'), prefixed with the

219-- provided string. This should /only/ be used for debugging.

233-- provided string. This should /only/ be used for debugging.

@@ -334,7 +348,7 @@ factorDyn d = buildDynamic (sample (current d) >>= holdKey) update where

334--

348--

335-- > demuxed (demux d) k === fmap (== k) d

349-- > demuxed (demux d) k === fmap (== k) d

336--

350--

337−-- However, when getDemuxed is used multiple times, the complexity is only

351+-- However, when 'demuxed' is used multiple times, the complexity is only

338-- /O(log(n))/, rather than /O(n)/ for fmap.

352-- /O(log(n))/, rather than /O(n)/ for fmap.

339data Demux t k = Demux { demuxValue :: Behavior t k

353data Demux t k = Demux { demuxValue :: Behavior t k

340 , demuxSelector :: EventSelector t (Const2 k Bool)

354 , demuxSelector :: EventSelector t (Const2 k Bool)

src/Reflex/DynamicWriter/Base.hs+14−5

@@ -22,6 +22,7 @@ module Reflex.DynamicWriter.Base

22import Control.Monad.Exception

23import Control.Monad.Identity

24import Control.Monad.IO.Class

25+import Control.Monad.Morph

25import Control.Monad.Primitive

26import Control.Monad.Primitive

26import Control.Monad.Reader

27import Control.Monad.Reader

27import Control.Monad.Ref

28import Control.Monad.Ref

@@ -44,16 +45,13 @@ import Reflex.Class

44import Reflex.DynamicWriter.Class

45import Reflex.DynamicWriter.Class

45import Reflex.EventWriter.Class (EventWriter, tellEvent)

46import Reflex.EventWriter.Class (EventWriter, tellEvent)

46import Reflex.Host.Class

47import Reflex.Host.Class

47−import qualified Reflex.Patch.MapWithMove as MapWithMove

48+import qualified Data.Patch.MapWithMove as MapWithMove

48import Reflex.PerformEvent.Class

49import Reflex.PerformEvent.Class

49import Reflex.PostBuild.Class

50import Reflex.PostBuild.Class

50import Reflex.Query.Class

51import Reflex.Query.Class

51import Reflex.Requester.Class

52import Reflex.Requester.Class

52import Reflex.TriggerEvent.Class

53import Reflex.TriggerEvent.Class

54−instance MonadTrans (DynamicWriterT t w) where

55− lift = DynamicWriterT . lift

56−

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')

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')

58mapIncrementalMapValues f = unsafeMapIncremental (fmap f) (fmap f)

56mapIncrementalMapValues f = unsafeMapIncremental (fmap f) (fmap f)

@@ -90,7 +88,18 @@ mergeDynIncrementalWithMove a = unsafeBuildIncremental (mapM (sample . current)

91-- | A basic implementation of 'DynamicWriter'.

89-- | A basic implementation of 'DynamicWriter'.

92newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT [Dynamic t w] m a }

90newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT [Dynamic t w] m a }

93− deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadAsyncException, MonadException) -- The list is kept in reverse order

91+ -- The list is kept in reverse order

92+ deriving

93+ ( Functor

94+ , Applicative

95+ , Monad

96+ , MonadTrans

97+ , MFunctor

98+ , MonadIO

99+ , MonadFix

100+ , MonadAsyncException

101+ , MonadException

102+ )

103

95deriving instance MonadHold t m => MonadHold t (DynamicWriterT t w m)

104deriving instance MonadHold t m => MonadHold t (DynamicWriterT t w m)

96deriving instance MonadSample t m => MonadSample t (DynamicWriterT t w m)

105deriving instance MonadSample t m => MonadSample t (DynamicWriterT t w m)

src/Reflex/EventWriter/Base.hs+16−5

@@ -35,12 +35,14 @@ import Reflex.TriggerEvent.Class

36import Control.Monad.Exception

37import Control.Monad.Identity

38+import Control.Monad.Morph

38import Control.Monad.Primitive

39import Control.Monad.Primitive

39import Control.Monad.Reader

40import Control.Monad.Reader

40import Control.Monad.Ref

41import Control.Monad.Ref

41import Control.Monad.State.Strict

42import Control.Monad.State.Strict

42−import Data.Dependent.Map (DMap, DSum (..))

43+import Data.Dependent.Map (DMap)

43import qualified Data.Dependent.Map as DMap

44import qualified Data.Dependent.Map as DMap

45+import Data.Dependent.Sum (DSum (..))

44import Data.Functor.Compose

46import Data.Functor.Compose

45import Data.Functor.Misc

47import Data.Functor.Misc

46import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))

48import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))

@@ -96,7 +98,17 @@ data EventWriterState t w = EventWriterState

97-- | A basic implementation of 'EventWriter'.

99-- | A basic implementation of 'EventWriter'.

98newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (EventWriterState t w) m a }

100newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (EventWriterState t w) m a }

99− deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)

101+ deriving

102+ ( Functor

103+ , Applicative

104+ , Monad

105+ , MonadTrans

106+ , MFunctor

107+ , MonadFix

108+ , MonadIO

109+ , MonadException

110+ , MonadAsyncException

111+ )

100

112

101-- | Run a 'EventWriterT' action.

113-- | Run a 'EventWriterT' action.

102runEventWriterT :: forall t m w a. (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)

114runEventWriterT :: forall t m w a. (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)

@@ -116,9 +128,6 @@ instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m

116 , _eventWriterState_told = (tellId myId :=> w) : _eventWriterState_told old

128 , _eventWriterState_told = (tellId myId :=> w) : _eventWriterState_told old

117 }

129 }

118

130

119−instance MonadTrans (EventWriterT t w) where

120− lift = EventWriterT . lift

121−

122instance MonadSample t m => MonadSample t (EventWriterT t w m) where

131instance MonadSample t m => MonadSample t (EventWriterT t w m) where

123 sample = lift . sample

132 sample = lift . sample

124

133

@@ -133,6 +142,8 @@ instance MonadHold t m => MonadHold t (EventWriterT t w m) where

133 buildDynamic a0 = lift . buildDynamic a0

142 buildDynamic a0 = lift . buildDynamic a0

134 {-# INLINABLE headE #-}

143 {-# INLINABLE headE #-}

135 headE = lift . headE

144 headE = lift . headE

145+ {-# INLINABLE now #-}

146+ now = lift now

136

147

137instance (Reflex t, Adjustable t m, MonadHold t m, Semigroup w) => Adjustable t (EventWriterT t w m) where

148instance (Reflex t, Adjustable t m, MonadHold t m, Semigroup w) => Adjustable t (EventWriterT t w m) where

138 runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'

149 runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'

src/Reflex/FastWeak.hs+10

@@ -151,6 +151,16 @@ getFastWeakTicket w = do

151

152-- | Create a 'FastWeakTicket' directly from a value, creating a 'FastWeak' in the process

153-- which can be obtained with 'getFastWeakTicketValue'.

154+--

155+-- This function is marked NOINLINE so it is opaque to GHC.

156+-- If we do not do this, then GHC will sometimes fuse the constructor away

157+-- so any weak references that are attached to the ticket will have their

158+-- finalizer run. Using the opaque constructor, GHC does not see the

159+-- constructor application, so it behaves like an IORef and cannot be fused away.

160+--

161+-- The result is also evaluated to WHNF, since forcing a thunk invalidates

162+-- the weak pointer to it in some cases.

163+{-# NOINLINE mkFastWeakTicket #-}

154mkFastWeakTicket :: a -> IO (FastWeakTicket a)

164mkFastWeakTicket :: a -> IO (FastWeakTicket a)

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

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

156-- associated FastWeak to actually be weak

166-- associated FastWeak to actually be weak

src/Reflex/Host/Headless.hsnew file+128

@@ -0,0 +1,128 @@

1+{-# LANGUAGE LambdaCase #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE RankNTypes #-}

4+{-# LANGUAGE TypeFamilies #-}

5+{-# LANGUAGE ConstraintKinds #-}

7+module Reflex.Host.Headless where

9+import Control.Concurrent.Chan (newChan, readChan)

10+import Control.Monad (unless)

11+import Control.Monad.Fix (MonadFix, fix)

12+import Control.Monad.IO.Class (MonadIO, liftIO)

13+import Control.Monad.Primitive (PrimMonad)

14+import Control.Monad.Ref (MonadRef, Ref, readRef)

15+import Data.Dependent.Sum (DSum (..), (==>))

16+import Data.Foldable (for_)

17+import Data.Functor.Identity (Identity(..))

18+import Data.IORef (IORef, readIORef)

19+import Data.Maybe (catMaybes, fromMaybe)

20+import Data.Traversable (for)

21+

22+import Reflex

23+import Reflex.Host.Class

24+

25+type MonadHeadlessApp t m =

26+ ( Adjustable t m

27+ , MonadFix m

28+ , MonadHold t m

29+ , MonadIO (HostFrame t)

30+ , MonadIO (Performable m)

31+ , MonadIO m

32+ , MonadRef (HostFrame t)

33+ , NotReady t m

34+ , PerformEvent t m

35+ , PostBuild t m

36+ , PrimMonad (HostFrame t)

37+ , Ref (HostFrame t) ~ IORef

38+ , Ref m ~ IORef

39+ , Reflex t

40+ , ReflexHost t

41+ , TriggerEvent t m

42+ )

43+

44+-- | Run a headless FRP network. Inside the action, you will most probably use

45+-- the capabilities provided by the 'TriggerEvent' and 'PerformEvent' type

46+-- classes to interface the FRP network with the outside world. Useful for

47+-- testing. Each headless network runs on its own spider timeline.

48+runHeadlessApp

49+ :: (forall t m. MonadHeadlessApp t m => m (Event t ()))

50+ -- ^ The action to be run in the headless FRP network. The FRP network is

51+ -- closed at the first occurrence of the resulting 'Event'.

52+ -> IO ()

53+runHeadlessApp guest =

54+ -- We are using the 'Spider' implementation of reflex. Running the host

55+ -- allows us to take actions on the FRP timeline.

56+ withSpiderTimeline $ runSpiderHostForTimeline $ do

57+ -- Create the "post-build" event and associated trigger. This event fires

58+ -- once, when the application starts.

59+ (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

60+ -- Create a queue to which we will write 'Event's that need to be

61+ -- processed.

62+ events <- liftIO newChan

63+ -- Run the "guest" application, providing the appropriate context. We'll

64+ -- pure the result of the action, and a 'FireCommand' that will be used to

65+ -- trigger events.

66+ (result, fc@(FireCommand fire)) <- do

67+ hostPerformEventT $ -- Allows the guest app to run

68+ -- 'performEvent', so that actions

69+ -- (e.g., IO actions) can be run when

70+ -- 'Event's fire.

71+

72+ flip runPostBuildT postBuild $ -- Allows the guest app to access to

73+ -- a "post-build" 'Event'

74+

75+ flip runTriggerEventT events $ -- Allows the guest app to create new

76+ -- events and triggers and write

77+ -- those triggers to a channel from

78+ -- which they will be read and

79+ -- processed.

80+ guest

81+

82+ -- Read the trigger reference for the post-build event. This will be

83+ -- 'Nothing' if the guest application hasn't subscribed to this event.

84+ mPostBuildTrigger <- readRef postBuildTriggerRef

85+

86+ -- Subscribe to an 'Event' of that the guest application can use to

87+ -- request application shutdown. We'll check whether this 'Event' is firing

88+ -- to determine whether to terminate.

89+ shutdown <- subscribeEvent result

90+

91+ -- When there is a subscriber to the post-build event, fire the event.

92+ soa <- for mPostBuildTrigger $ \postBuildTrigger ->

93+ fire [postBuildTrigger :=> Identity ()] $ isFiring shutdown

94+

95+ -- The main application loop. We wait for new events and fire those that

96+ -- have subscribers. If we detect a shutdown request, the application

97+ -- terminates.

98+ unless (or (fromMaybe [] soa)) $ fix $ \loop -> do

99+ -- Read the next event (blocking).

100+ ers <- liftIO $ readChan events

101+ stop <- do

102+ -- Fire events that have subscribers.

103+ fireEventTriggerRefs fc ers $

104+ -- Check if the shutdown 'Event' is firing.

105+ isFiring shutdown

106+ if or stop

107+ then pure ()

108+ else loop

109+ where

110+ isFiring ev = readEvent ev >>= \case

111+ Nothing -> pure False

112+ Just _ -> pure True

113+ -- Use the given 'FireCommand' to fire events that have subscribers

114+ -- and call the callback for the 'TriggerInvocation' of each.

115+ fireEventTriggerRefs

116+ :: MonadIO m

117+ => FireCommand t m

118+ -> [DSum (EventTriggerRef t) TriggerInvocation]

119+ -> ReadPhase m a

120+ -> m [a]

121+ fireEventTriggerRefs (FireCommand fire) ers rcb = do

122+ mes <- liftIO $

123+ for ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do

124+ me <- readIORef er

125+ pure $ fmap (==> a) me

126+ a <- fire (catMaybes mes) rcb

127+ liftIO $ for_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb

128+ pure a

src/Reflex/Patch.hsdeleted−46

@@ -1,46 +0,0 @@

1−{-# LANGUAGE TypeFamilies #-}

2−-- |

3−-- Module:

4−-- Reflex.Patch

5−-- Description:

6−-- This module defines the 'Patch' class, which is used by Reflex to manage

7−-- changes to 'Reflex.Class.Incremental' values.

8−module Reflex.Patch

9− ( module Reflex.Patch

10− , module X

11− ) where

12−

13−import Reflex.Patch.Class as X

14−import Reflex.Patch.DMap as X hiding (getDeletions)

15−import Reflex.Patch.DMapWithMove as X (PatchDMapWithMove, const2PatchDMapWithMoveWith, mapPatchDMapWithMove,

16− patchDMapWithMoveToPatchMapWithMoveWith,

17− traversePatchDMapWithMoveWithKey, unPatchDMapWithMove,

18− unsafePatchDMapWithMove, weakenPatchDMapWithMoveWith)

19−import Reflex.Patch.IntMap as X hiding (getDeletions)

20−import Reflex.Patch.Map as X

21−import Reflex.Patch.MapWithMove as X (PatchMapWithMove, patchMapWithMoveNewElements,

22− patchMapWithMoveNewElementsMap, unPatchMapWithMove,

23− unsafePatchMapWithMove)

24−import Data.Map.Monoidal (MonoidalMap)

25−import Data.Semigroup (Semigroup (..), (<>))

26−

27−-- | A 'Group' is a 'Monoid' where every element has an inverse.

28−class (Semigroup q, Monoid q) => Group q where

29− negateG :: q -> q

30− (~~) :: q -> q -> q

31− r ~~ s = r <> negateG s

32−

33−-- | An 'Additive' 'Semigroup' is one where (<>) is commutative

34−class Semigroup q => Additive q where

35−

36−-- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type.

37−newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }

38−

39−instance Additive p => Patch (AdditivePatch p) where

40− type PatchTarget (AdditivePatch p) = p

41− apply (AdditivePatch p) q = Just $ p <> q

42−

43−instance (Ord k, Group q) => Group (MonoidalMap k q) where

44− negateG = fmap negateG

45−

46−instance (Ord k, Additive q) => Additive (MonoidalMap k q)

src/Reflex/Patch/Class.hsdeleted−34

@@ -1,34 +0,0 @@

1−{-# LANGUAGE TypeFamilies #-}

2−-- | The interface for types which represent changes made to other types

3−module Reflex.Patch.Class where

4−

5−import Control.Monad.Identity

6−import Data.Maybe

7−import Data.Semigroup (Semigroup(..))

8−

9−-- | A 'Patch' type represents a kind of change made to a datastructure.

10−--

11−-- If an instance of 'Patch' is also an instance of 'Semigroup', it should obey

12−-- the law that @applyAlways (f <> g) == applyAlways f . applyAlways g@.

13−class Patch p where

14− type PatchTarget p :: *

15− -- | Apply the patch @p a@ to the value @a@. If no change is needed, return

16− -- 'Nothing'.

17− apply :: p -> PatchTarget p -> Maybe (PatchTarget p)

18−

19−-- | Apply a 'Patch'; if it does nothing, return the original value

20−applyAlways :: Patch p => p -> PatchTarget p -> PatchTarget p

21−applyAlways p t = fromMaybe t $ apply p t

22−

23−-- | 'Identity' can be used as a 'Patch' that always fully replaces the value

24−instance Patch (Identity a) where

25− type PatchTarget (Identity a) = a

26− apply (Identity a) _ = Just a

27−

28−-- | Like '(.)', but composes functions that return patches rather than

29−-- functions that return new values. The Semigroup instance for patches must

30−-- apply patches right-to-left, like '(.)'.

31−composePatchFunctions :: (Patch p, Semigroup p) => (PatchTarget p -> p) -> (PatchTarget p -> p) -> PatchTarget p -> p

32−composePatchFunctions g f a =

33− let fp = f a

34− in g (applyAlways fp a) <> fp

src/Reflex/Patch/DMap.hsdeleted−82

@@ -1,82 +0,0 @@

1−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2−{-# LANGUAGE LambdaCase #-}

3−{-# LANGUAGE PolyKinds #-}

4−{-# LANGUAGE Rank2Types #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE StandaloneDeriving #-}

7−{-# LANGUAGE TypeFamilies #-}

8−-- | 'Patch'es on 'DMap' that consist only of insertions (or overwrites) and deletions.

9−module Reflex.Patch.DMap where

10−

11−import Reflex.Patch.Class

12−import Reflex.Patch.IntMap

13−import Reflex.Patch.Map

14−

15−import Data.Dependent.Map (DMap, DSum (..), GCompare (..))

16−import qualified Data.Dependent.Map as DMap

17−import Data.Functor.Constant

18−import Data.Functor.Misc

19−import qualified Data.IntMap as IntMap

20−import qualified Data.Map as Map

21−import Data.Semigroup (Semigroup (..))

22−import Data.Some (Some)

23−

24−-- | A set of changes to a 'DMap'. Any element may be inserted/updated or deleted.

25−-- Insertions are represented as @'ComposeMaybe' (Just value)@,

26−-- while deletions are represented as @'ComposeMaybe' Nothing@.

27−newtype PatchDMap k v = PatchDMap { unPatchDMap :: DMap k (ComposeMaybe v) }

28−

29−deriving instance GCompare k => Semigroup (PatchDMap k v)

30−

31−deriving instance GCompare k => Monoid (PatchDMap k v)

32−

33−-- | Apply the insertions or deletions to a given 'DMap'.

34−instance GCompare k => Patch (PatchDMap k v) where

35− type PatchTarget (PatchDMap k v) = DMap k v

36− apply (PatchDMap diff) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?

37− where insertions = DMap.mapMaybeWithKey (const $ getComposeMaybe) diff

38− deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getComposeMaybe) diff

39− nothingToJust = \case

40− Nothing -> Just $ Constant ()

41− Just _ -> Nothing

42−

43−-- | Map a function @v a -> v' a@ over any inserts/updates in the given

44−-- @'PatchDMap' k v@ to produce a @'PatchDMap' k v'@.

45−mapPatchDMap :: (forall a. v a -> v' a) -> PatchDMap k v -> PatchDMap k v'

46−mapPatchDMap f (PatchDMap p) = PatchDMap $ DMap.map (ComposeMaybe . fmap f . getComposeMaybe) p

47−

48−-- | Map an effectful function @v a -> f (v' a)@ over any inserts/updates in the given

49−-- @'PatchDMap' k v@ to produce a @'PatchDMap' k v'@.

50−traversePatchDMap :: Applicative f => (forall a. v a -> f (v' a)) -> PatchDMap k v -> f (PatchDMap k v')

51−traversePatchDMap f = traversePatchDMapWithKey $ const f

52−

53−-- | Map an effectful function @k a -> v a -> f (v' a)@ over any inserts/updates

54−-- in the given @'PatchDMap' k v@ to produce a @'PatchDMap' k v'@.

55−traversePatchDMapWithKey :: Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v')

56−traversePatchDMapWithKey f (PatchDMap p) = PatchDMap <$> DMap.traverseWithKey (\k (ComposeMaybe v) -> ComposeMaybe <$> traverse (f k) v) p

57−

58−-- | Weaken a @'PatchDMap' k v@ to a @'PatchMap' (Some k) v'@ using a function

59−-- @v a -> v'@ to weaken each value contained in the patch.

60−weakenPatchDMapWith :: (forall a. v a -> v') -> PatchDMap k v -> PatchMap (Some k) v'

61−weakenPatchDMapWith f (PatchDMap p) = PatchMap $ weakenDMapWith (fmap f . getComposeMaybe) p

62−

63−-- | Convert a weak @'PatchDMap' ('Const2' k a) v@ where the @a@ is known by way of

64−-- the @Const2@ into a @'PatchMap' k v'@ using a rank 1 function @v a -> v'@.

65−patchDMapToPatchMapWith :: (v a -> v') -> PatchDMap (Const2 k a) v -> PatchMap k v'

66−patchDMapToPatchMapWith f (PatchDMap p) = PatchMap $ dmapToMapWith (fmap f . getComposeMaybe) p

67−

68−-- | Convert a @'PatchMap' k v@ into a @'PatchDMap' ('Const2' k a) v'@ using a function @v -> v' a@.

69−const2PatchDMapWith :: forall k v v' a. (v -> v' a) -> PatchMap k v -> PatchDMap (Const2 k a) v'

70−const2PatchDMapWith f (PatchMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> Map.toAscList p

71− where g :: (k, Maybe v) -> DSum (Const2 k a) (ComposeMaybe v')

72− g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)

73−

74−-- | Convert a @'PatchIntMap' v@ into a @'PatchDMap' ('Const2' Int a) v'@ using a function @v -> v' a@.

75−const2IntPatchDMapWith :: forall v f a. (v -> f a) -> PatchIntMap v -> PatchDMap (Const2 IntMap.Key a) f

76−const2IntPatchDMapWith f (PatchIntMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> IntMap.toAscList p

77− where g :: (IntMap.Key, Maybe v) -> DSum (Const2 IntMap.Key a) (ComposeMaybe f)

78− g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)

79−

80−-- | Get the values that will be replaced or deleted if the given patch is applied to the given 'DMap'.

81−getDeletions :: GCompare k => PatchDMap k v -> DMap k v' -> DMap k v'

82−getDeletions (PatchDMap p) m = DMap.intersectionWithKey (\_ v _ -> v) m p

src/Reflex/Patch/DMapWithMove.hsdeleted−363

@@ -1,363 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE FlexibleInstances #-}

4−{-# LANGUAGE GADTs #-}

5−{-# LANGUAGE LambdaCase #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

7−{-# LANGUAGE PatternGuards #-}

8−{-# LANGUAGE PolyKinds #-}

9−{-# LANGUAGE Rank2Types #-}

10−{-# LANGUAGE ScopedTypeVariables #-}

11−{-# LANGUAGE TypeFamilies #-}

12−{-# LANGUAGE UndecidableInstances #-}

13−

14−-- |Module containing @'PatchDMapWithMove' k v@ and associated functions, which represents a 'Patch' to a @'DMap' k v@ which can insert, update, delete, and

15−-- move values between keys.

16−module Reflex.Patch.DMapWithMove where

17−

18−import Reflex.Patch.Class

19−import Reflex.Patch.MapWithMove (PatchMapWithMove (..))

20−import qualified Reflex.Patch.MapWithMove as MapWithMove

21−

22−import Data.Constraint.Extras

23−import Data.Dependent.Map (DMap, DSum (..), GCompare (..))

24−import qualified Data.Dependent.Map as DMap

25−import Data.Functor.Constant

26−import Data.Functor.Misc

27−import Data.Functor.Product

28−import Data.GADT.Compare (GEq (..))

29−import Data.GADT.Show (GShow, gshow)

30−import qualified Data.Map as Map

31−import Data.Maybe

32−import Data.Semigroup (Semigroup (..), (<>))

33−import Data.Some (Some(Some))

34−import Data.These

35−

36−-- | Like 'PatchMapWithMove', but for 'DMap'. Each key carries a 'NodeInfo' which describes how it will be changed by the patch and connects move sources and

37−-- destinations.

38−--

39−-- Invariants:

40−--

41−-- * A key should not move to itself.

42−-- * A move should always be represented with both the destination key (as a 'From_Move') and the source key (as a @'ComposeMaybe' ('Just' destination)@)

43−newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))

44−

45−-- |Structure which represents what changes apply to a particular key. @_nodeInfo_from@ specifies what happens to this key, and in particular what other key

46−-- the current key is moving from, while @_nodeInfo_to@ specifies what key the current key is moving to if involved in a move.

47−data NodeInfo k v a = NodeInfo

48− { _nodeInfo_from :: !(From k v a)

49− -- ^Change applying to the current key, be it an insert, move, or delete.

50− , _nodeInfo_to :: !(To k a)

51− -- ^Where this key is moving to, if involved in a move. Should only be @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.

52− }

53− deriving (Show)

54−

55−-- |Structure describing a particular change to a key, be it inserting a new key (@From_Insert@), updating an existing key (@From_Insert@ again), deleting a

56−-- key (@From_Delete@), or moving a key (@From_Move@).

57−data From (k :: a -> *) (v :: a -> *) :: a -> * where

58− -- |Insert a new or update an existing key with the given value @v a@

59− From_Insert :: v a -> From k v a

60− -- |Delete the existing key

61− From_Delete :: From k v a

62− -- |Move the value from the given key @k a@ to this key. The source key should also have an entry in the patch giving the current key as @_nodeInfo_to@,

63− -- usually but not necessarily with @From_Delete@.

64− From_Move :: !(k a) -> From k v a

65− deriving (Show, Read, Eq, Ord)

66−

67−-- |Type alias for the "to" part of a 'NodeInfo'. @'ComposeMaybe' ('Just' k)@ means the key is moving to another key, @ComposeMaybe Nothing@ for any other

68−-- operation.

69−type To = ComposeMaybe

70−

71−-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.

72−validPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Bool

73−validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove

74−

75−-- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid.

76−validationErrorsForPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> [String]

77−validationErrorsForPatchDMapWithMove m =

78− noSelfMoves <> movesBalanced

79− where

80− noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m

81− selfMove (dst :=> NodeInfo (From_Move src) _) | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"

82− selfMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"

83− selfMove _ = Nothing

84− movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m

85− unbalancedMove (dst :=> NodeInfo (From_Move src) _) =

86− case DMap.lookup src m of

87− Nothing -> Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key is not in the patch"

88− Just (NodeInfo _ (ComposeMaybe (Just dst'))) ->

89− if isNothing (dst' `geq` dst)

90− then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead"

91− else Nothing

92− _ ->

93− Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key has no move to key"

94− unbalancedMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) =

95− case DMap.lookup dst m of

96− Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch"

97− Just (NodeInfo (From_Move src') _) ->

98− if isNothing (src' `geq` src)

99− then Just $ "unbalanced move at source key " <> gshow src <> " to " <> gshow dst <> " is coming from " <> gshow src' <> " instead"

100− else Nothing

101−

102− _ ->

103− Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"

104− unbalancedMove _ = Nothing

105−

106−-- |Test whether two @'PatchDMapWithMove' k v@ contain the same patch operations.

107−instance (GEq k, Has' Eq k (NodeInfo k v)) => Eq (PatchDMapWithMove k v) where

108− PatchDMapWithMove a == PatchDMapWithMove b = a == b

109−

110−-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9

111−data Pair1 f g a = Pair1 (f a) (g a)

112−

113−-- |Helper data structure used for composing patches using the monoid instance.

114−data Fixup k v a

115− = Fixup_Delete

116− | Fixup_Update (These (From k v a) (To k a))

117−

118−-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@

119−instance GCompare k => Semigroup (PatchDMapWithMove k v) where

120− PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m

121− where

122− connections = DMap.toList $ DMap.intersectionWithKey (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b)) ma mb

123− h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)]

124− h (_ :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case (mToAfter, editBefore) of

125− (Just toAfter, From_Move fromBefore)

126− | isJust $ fromBefore `geq` toAfter

127− -> [toAfter :=> Fixup_Delete]

128− | otherwise

129− -> [ toAfter :=> Fixup_Update (This editBefore)

130− , fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))

131− ]

132− (Nothing, From_Move fromBefore) -> [fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map

133− (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)]

134− (Nothing, _) -> []

135− mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete

136− mergeFixups _ (Fixup_Update a) (Fixup_Update b)

137− | This x <- a, That y <- b

138− = Fixup_Update $ These x y

139− | That y <- a, This x <- b

140− = Fixup_Update $ These x y

141− mergeFixups _ _ _ = error "PatchDMapWithMove: incompatible fixups"

142− fixups = DMap.fromListWithKey mergeFixups $ concatMap h connections

143− combineNodeInfos _ nia nib = NodeInfo

144− { _nodeInfo_from = _nodeInfo_from nia

145− , _nodeInfo_to = _nodeInfo_to nib

146− }

147− applyFixup _ ni = \case

148− Fixup_Delete -> Nothing

149− Fixup_Update u -> Just $ NodeInfo

150− { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u

151− , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u

152− }

153− m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups

154− getHere :: These a b -> Maybe a

155− getHere = \case

156− This a -> Just a

157− These a _ -> Just a

158− That _ -> Nothing

159− getThere :: These a b -> Maybe b

160− getThere = \case

161− This _ -> Nothing

162− These _ b -> Just b

163− That b -> Just b

164−

165−-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@

166−instance GCompare k => Monoid (PatchDMapWithMove k v) where

167− mempty = PatchDMapWithMove mempty

168− mappend = (<>)

169−

170−{-

171−mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v

172−PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src

173− where

174− getDstAction k m = fromMaybe (From_Move k) $ DMap.lookup k m -- Any key that isn't present is treated as that key moving to itself

175− removeRedundantDst toKey (From_Move fromKey) | isJust (toKey `geq` fromKey) = Nothing

176− removeRedundantDst _ a = Just a

177− f :: forall a. k a -> From k v a -> Maybe (From k v a)

178− f toKey _ = removeRedundantDst toKey $ case getDstAction toKey dstAfter of

179− From_Move fromKey -> getDstAction fromKey dstBefore

180− nonMove -> nonMove

181− dst = DMap.mapMaybeWithKey f $ DMap.union dstAfter dstBefore

182− getSrcAction k m = fromMaybe (ComposeMaybe $ Just k) $ DMap.lookup k m

183− removeRedundantSrc fromKey (ComposeMaybe (Just toKey)) | isJust (fromKey `geq` toKey) = Nothing

184− removeRedundantSrc _ a = Just a

185− g :: forall a. k a -> ComposeMaybe k a -> Maybe (ComposeMaybe k a)

186− g fromKey _ = removeRedundantSrc fromKey $ case getSrcAction fromKey srcBefore of

187− ComposeMaybe Nothing -> ComposeMaybe Nothing

188− ComposeMaybe (Just toKeyBefore) -> getSrcAction toKeyBefore srcAfter

189− src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore

190−-}

191−

192−-- |Make a @'PatchDMapWithMove' k v@ which has the effect of inserting or updating a value @v a@ to the given key @k a@, like 'DMap.insert'.

193−insertDMapKey :: k a -> v a -> PatchDMapWithMove k v

194−insertDMapKey k v =

195− PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing)

196−

197−-- |Make a @'PatchDMapWithMove' k v@ which has the effect of moving the value from the first key @k a@ to the second key @k a@, equivalent to:

198−--

199−-- @

200−-- 'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap))

201−-- @

202−moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v

203−moveDMapKey src dst = case src `geq` dst of

204− Nothing -> PatchDMapWithMove $ DMap.fromList

205− [ dst :=> NodeInfo (From_Move src) (ComposeMaybe Nothing)

206− , src :=> NodeInfo From_Delete (ComposeMaybe $ Just dst)

207− ]

208− Just _ -> mempty

209−

210−-- |Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:

211−--

212−-- @

213−-- let aMay = DMap.lookup a dmap

214−-- bMay = DMap.lookup b dmap

215−-- in maybe id (DMap.insert a) (bMay `mplus` aMay)

216−-- . maybe id (DMap.insert b) (aMay `mplus` bMay)

217−-- . DMap.delete a . DMap.delete b $ dmap

218−-- @

219−swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v

220−swapDMapKey src dst = case src `geq` dst of

221− Nothing -> PatchDMapWithMove $ DMap.fromList

222− [ dst :=> NodeInfo (From_Move src) (ComposeMaybe $ Just src)

223− , src :=> NodeInfo (From_Move dst) (ComposeMaybe $ Just dst)

224− ]

225− Just _ -> mempty

226−

227−-- |Make a @'PatchDMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'DMap.delete'.

228−deleteDMapKey :: k a -> PatchDMapWithMove k v

229−deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete $ ComposeMaybe Nothing

230−

231−{-

232−k1, k2 :: Const2 Int () ()

233−k1 = Const2 1

234−k2 = Const2 2

235−p1, p2 :: PatchDMapWithMove (Const2 Int ()) Identity

236−p1 = moveDMapKey k1 k2

237−p2 = moveDMapKey k2 k1

238−p12 = p1 <> p2

239−p21 = p2 <> p1

240−p12Slow = p1 `mappendPatchDMapWithMoveSlow` p2

241−p21Slow = p2 `mappendPatchDMapWithMoveSlow` p1

242−

243−testPatchDMapWithMove = do

244− print p1

245− print p2

246− print $ p12 == deleteDMapKey k1

247− print $ p21 == deleteDMapKey k2

248− print $ p12Slow == deleteDMapKey k1

249− print $ p21Slow == deleteDMapKey k2

250−

251−dst (PatchDMapWithMove x _) = x

252−src (PatchDMapWithMove _ x) = x

253−-}

254−

255−-- |Extract the 'DMap' representing the patch changes from the 'PatchDMapWithMove'.

256−unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)

257−unPatchDMapWithMove (PatchDMapWithMove p) = p

258−

259−-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove', without checking any invariants.

260−--

261−-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchDMapWithMove' are preserved; they will not be checked.

262−unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v

263−unsafePatchDMapWithMove = PatchDMapWithMove

264−

265−-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while checking invariants. If the invariants are satisfied, @Right p@ is returned

266−-- otherwise @Left errors@.

267−patchDMapWithMove :: (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)

268−patchDMapWithMove dm =

269− case validationErrorsForPatchDMapWithMove dm of

270− [] -> Right $ unsafePatchDMapWithMove dm

271− errs -> Left errs

272−

273−-- |Map a natural transform @v -> v'@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.

274−mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'

275−mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $

276− DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p

277− where g :: forall a. From k v a -> From k v' a

278− g = \case

279− From_Insert v -> From_Insert $ f v

280− From_Delete -> From_Delete

281− From_Move k -> From_Move k

282−

283−-- |Traverse an effectful function @forall a. v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.

284−traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')

285−traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f

286−

287−-- |Map an effectful function @forall a. k a -> v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.

288−traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')

289−traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p

290− where g :: forall a. k a -> From k v a -> m (From k v' a)

291− g k = \case

292− From_Insert v -> From_Insert <$> f k v

293− From_Delete -> pure From_Delete

294− From_Move fromKey -> pure $ From_Move fromKey

295−

296−-- |Map a function which transforms @'From' k v a@ into a @'From' k v' a@ over a @'NodeInfo' k v a@.

297−nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a

298−nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }

299−

300−-- |Map an effectful function which transforms @'From' k v a@ into a @f ('From' k v' a)@ over a @'NodeInfo' k v a@.

301−nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a)

302−nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni

303−

304−-- |Weaken a 'PatchDMapWithMove' to a 'PatchMapWithMove' by weakening the keys from @k a@ to @'Some' k@ and applying a given weakening function @v a -> v'@ to

305−-- values.

306−weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'

307−weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p

308− where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) v'

309− g ni = MapWithMove.NodeInfo

310− { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of

311− From_Insert v -> MapWithMove.From_Insert $ f v

312− From_Delete -> MapWithMove.From_Delete

313− From_Move k -> MapWithMove.From_Move $ Some k

314− , MapWithMove._nodeInfo_to = Some <$> getComposeMaybe (_nodeInfo_to ni)

315− }

316−

317−-- |"Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k v'@. Weaken is in scare quotes because the 'Const2' has already disabled any

318−-- dependency in the typing and all points are already @a@, hence the function to map each value to @v'@ is not higher rank.

319−patchDMapWithMoveToPatchMapWithMoveWith :: forall k v v' a. (v a -> v') -> PatchDMapWithMove (Const2 k a) v -> PatchMapWithMove k v'

320−patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p

321− where g :: NodeInfo (Const2 k a) v a -> MapWithMove.NodeInfo k v'

322− g ni = MapWithMove.NodeInfo

323− { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of

324− From_Insert v -> MapWithMove.From_Insert $ f v

325− From_Delete -> MapWithMove.From_Delete

326− From_Move (Const2 k) -> MapWithMove.From_Move k

327− , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)

328− }

329−

330−-- |"Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove ('Const2' k a)@; that is, turn a non-dependently-typed patch into a dependently typed

331−-- one but which always has a constant key type represented by 'Const2'. Apply the given function to each @v@ to produce a @v' a@.

332−-- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'

333−const2PatchDMapWithMoveWith :: forall k v v' a. (v -> v' a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) v'

334−const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p

335− where g :: (k, MapWithMove.NodeInfo k v) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v')

336− g (k, ni) = Const2 k :=> NodeInfo

337− { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of

338− MapWithMove.From_Insert v -> From_Insert $ f v

339− MapWithMove.From_Delete -> From_Delete

340− MapWithMove.From_Move fromKey -> From_Move $ Const2 fromKey

341− , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni

342− }

343−

344−-- | Apply the insertions, deletions, and moves to a given 'DMap'.

345−instance GCompare k => Patch (PatchDMapWithMove k v) where

346− type PatchTarget (PatchDMapWithMove k v) = DMap k v

347− apply (PatchDMapWithMove p) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?

348− where insertions = DMap.mapMaybeWithKey insertFunc p

349− insertFunc :: forall a. k a -> NodeInfo k v a -> Maybe (v a)

350− insertFunc _ ni = case _nodeInfo_from ni of

351− From_Insert v -> Just v

352− From_Move k -> DMap.lookup k old

353− From_Delete -> Nothing

354− deletions = DMap.mapMaybeWithKey deleteFunc p

355− deleteFunc :: forall a. k a -> NodeInfo k v a -> Maybe (Constant () a)

356− deleteFunc _ ni = case _nodeInfo_from ni of

357− From_Delete -> Just $ Constant ()

358− _ -> Nothing

359−

360−-- | Get the values that will be replaced, deleted, or moved if the given patch is applied to the given 'DMap'.

361−getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))

362−getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p

363− where f _ v ni = Pair v $ _nodeInfo_to ni

src/Reflex/Patch/IntMap.hsdeleted−59

@@ -1,59 +0,0 @@

1−{-# LANGUAGE DeriveFoldable #-}

2−{-# LANGUAGE DeriveFunctor #-}

3−{-# LANGUAGE DeriveTraversable #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5−{-# LANGUAGE TypeFamilies #-}

6−-- | Module containing 'PatchIntMap', a 'Patch' for 'IntMap' which allows for

7−-- insert/update or delete of associations.

8−module Reflex.Patch.IntMap where

9−

10−import Data.IntMap.Strict (IntMap)

11−import qualified Data.IntMap.Strict as IntMap

12−import Data.Maybe

13−import Data.Semigroup

14−import Reflex.Patch.Class

15−

16−-- | 'Patch' for 'IntMap' which represents insertion or deletion of keys in the mapping.

17−-- Internally represented by 'IntMap (Maybe a)', where @Just@ means insert/update

18−-- and @Nothing@ means delete.

19−newtype PatchIntMap a = PatchIntMap (IntMap (Maybe a)) deriving (Functor, Foldable, Traversable, Monoid)

20−

21−-- | Apply the insertions or deletions to a given 'IntMap'.

22−instance Patch (PatchIntMap a) where

23− type PatchTarget (PatchIntMap a) = IntMap a

24− apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $

25− let removes = IntMap.filter isNothing p

26− adds = IntMap.mapMaybe id p

27− in IntMap.union adds $ v `IntMap.difference` removes

28−

29−-- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@.

30−-- If the same key is modified by both patches, the one on the left will take

31−-- precedence.

32−instance Semigroup (PatchIntMap v) where

33− PatchIntMap a <> PatchIntMap b = PatchIntMap $ a `mappend` b --TODO: Add a semigroup instance for Map

34− -- PatchMap is idempotent, so stimes n is id for every n

35− stimes = stimesIdempotentMonoid

36−

37−-- | Map a function @Int -> a -> b@ over all @a@s in the given @'PatchIntMap' a@

38−-- (that is, all inserts/updates), producing a @PatchIntMap b@.

39−mapIntMapPatchWithKey :: (Int -> a -> b) -> PatchIntMap a -> PatchIntMap b

40−mapIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap $ IntMap.mapWithKey (\ k mv -> f k <$> mv) m

41−

42−-- | Map an effectful function @Int -> a -> f b@ over all @a@s in the given @'PatchIntMap' a@

43−-- (that is, all inserts/updates), producing a @f (PatchIntMap b)@.

44−traverseIntMapPatchWithKey :: Applicative f => (Int -> a -> f b) -> PatchIntMap a -> f (PatchIntMap b)

45−traverseIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap <$> IntMap.traverseWithKey (\k mv -> traverse (f k) mv) m

46−

47−-- | Extract all @a@s inserted/updated by the given @'PatchIntMap' a@.

48−patchIntMapNewElements :: PatchIntMap a -> [a]

49−patchIntMapNewElements (PatchIntMap m) = catMaybes $ IntMap.elems m

50−

51−-- | Convert the given @'PatchIntMap' a@ into an @'IntMap' a@ with all

52−-- the inserts/updates in the given patch.

53−patchIntMapNewElementsMap :: PatchIntMap a -> IntMap a

54−patchIntMapNewElementsMap (PatchIntMap m) = IntMap.mapMaybe id m

55−

56−-- | Subset the given @'IntMap' a@ to contain only the keys that would be

57−-- deleted by the given @'PatchIntMap' a@.

58−getDeletions :: PatchIntMap v -> IntMap v' -> IntMap v'

59−getDeletions (PatchIntMap m) v = IntMap.intersection v m

src/Reflex/Patch/Map.hsdeleted−55

@@ -1,55 +0,0 @@

1−{-# LANGUAGE LambdaCase #-}

2−{-# LANGUAGE TypeFamilies #-}

3−-- | 'Patch'es on 'Map' that consist only of insertions (including overwrites)

4−-- and deletions

5−module Reflex.Patch.Map where

6−

7−import Reflex.Patch.Class

8−

9−import Data.Map (Map)

10−import qualified Data.Map as Map

11−import Data.Maybe

12−import Data.Semigroup

13−

14−-- | A set of changes to a 'Map'. Any element may be inserted/updated or

15−-- deleted. Insertions are represented as values wrapped in 'Just', while

16−-- deletions are represented as 'Nothing's

17−newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }

18− deriving (Show, Read, Eq, Ord)

19−

20−-- | Apply the insertions or deletions to a given 'Map'.

21−instance Ord k => Patch (PatchMap k v) where

22− type PatchTarget (PatchMap k v) = Map k v

23− {-# INLINABLE apply #-}

24− apply (PatchMap p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?

25− where insertions = Map.mapMaybeWithKey (const id) p

26− deletions = Map.mapMaybeWithKey (const nothingToJust) p

27− nothingToJust = \case

28− Nothing -> Just ()

29− Just _ -> Nothing

30−

31−-- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@.

32−-- If the same key is modified by both patches, the one on the left will take

33−-- precedence.

34−instance Ord k => Semigroup (PatchMap k v) where

35− PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map

36− -- PatchMap is idempotent, so stimes n is id for every n

37− stimes = stimesIdempotentMonoid

38−

39−-- | The empty 'PatchMap' contains no insertions or deletions

40−instance Ord k => Monoid (PatchMap k v) where

41− mempty = PatchMap mempty

42− mappend = (<>)

43−

44−-- | 'fmap'ping a 'PatchMap' will alter all of the values it will insert.

45−-- Deletions are unaffected.

46−instance Functor (PatchMap k) where

47− fmap f = PatchMap . fmap (fmap f) . unPatchMap

48−

49−-- | Returns all the new elements that will be added to the 'Map'

50−patchMapNewElements :: PatchMap k v -> [v]

51−patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p

52−

53−-- | Returns all the new elements that will be added to the 'Map'

54−patchMapNewElementsMap :: PatchMap k v -> Map k v

55−patchMapNewElementsMap (PatchMap p) = Map.mapMaybe id p

src/Reflex/Patch/MapWithMove.hsdeleted−270

@@ -1,270 +0,0 @@

1−{-# LANGUAGE DeriveFoldable #-}

2−{-# LANGUAGE DeriveFunctor #-}

3−{-# LANGUAGE DeriveTraversable #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE LambdaCase #-}

6−{-# LANGUAGE PatternGuards #-}

7−{-# LANGUAGE ScopedTypeVariables #-}

8−{-# LANGUAGE TypeFamilies #-}

9−-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to

10−-- another

11−module Reflex.Patch.MapWithMove where

12−

13−import Reflex.Patch.Class

14−

15−import Control.Arrow

16−import Control.Monad.State

17−import Data.Foldable

18−import Data.Function

19−import Data.List

20−import Data.Map (Map)

21−import qualified Data.Map as Map

22−import Data.Maybe

23−import Data.Semigroup (Semigroup (..), (<>))

24−import qualified Data.Set as Set

25−import Data.These (These(..))

26−import Data.Tuple

27−

28−-- | Patch a DMap with additions, deletions, and moves. Invariant: If key @k1@

29−-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,

30−-- and vice versa. There should never be any unpaired From/To keys.

31−newtype PatchMapWithMove k v = PatchMapWithMove (Map k (NodeInfo k v)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable)

32−

33−-- | Holds the information about each key: where its new value should come from,

34−-- and where its old value should go to

35−data NodeInfo k v = NodeInfo

36− { _nodeInfo_from :: !(From k v)

37− -- ^ Where do we get the new value for this key?

38− , _nodeInfo_to :: !(To k)

39− -- ^ If the old value is being kept (i.e. moved rather than deleted or

40− -- replaced), where is it going?

41− }

42− deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)

43−

44−-- | Describe how a key's new value should be produced

45−data From k v

46− = From_Insert v -- ^ Insert the given value here

47− | From_Delete -- ^ Delete the existing value, if any, from here

48− | From_Move !k -- ^ Move the value here from the given key

49− deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)

50−

51−-- | Describe where a key's old value will go. If this is 'Just', that means

52−-- the key's old value will be moved to the given other key; if it is 'Nothing',

53−-- that means it will be deleted.

54−type To = Maybe

55−

56−-- | Create a 'PatchMapWithMove', validating it

57−patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)

58−patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing

59− where valid = forwardLinks == backwardLinks

60− forwardLinks = Map.mapMaybe _nodeInfo_to m

61− backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, v) ->

62− case _nodeInfo_from v of

63− From_Move from -> Just (from, to)

64− _ -> Nothing

65−

66−-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'

67−patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v

68−patchMapWithMoveInsertAll m = PatchMapWithMove $ flip fmap m $ \v -> NodeInfo

69− { _nodeInfo_from = From_Insert v

70− , _nodeInfo_to = Nothing

71− }

72−

73−-- | Extract the internal representation of the 'PatchMapWithMove'

74−unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)

75−unPatchMapWithMove (PatchMapWithMove p) = p

76−

77−-- | Make a @'PatchMapWithMove' k v@ which has the effect of inserting or updating a value @v@ to the given key @k@, like 'Map.insert'.

78−insertMapKey :: k -> v -> PatchMapWithMove k v

79−insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing

80−

81−-- |Make a @'PatchMapWithMove' k v@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to:

82−--

83−-- @

84−-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))

85−-- @

86−moveMapKey :: Ord k => k -> k -> PatchMapWithMove k v

87−moveMapKey src dst

88− | src == dst = mempty

89− | otherwise =

90− PatchMapWithMove $ Map.fromList

91− [ (dst, NodeInfo (From_Move src) Nothing)

92− , (src, NodeInfo From_Delete (Just dst))

93− ]

94−

95−-- |Make a @'PatchMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:

96−--

97−-- @

98−-- let aMay = Map.lookup a map

99−-- bMay = Map.lookup b map

100−-- in maybe id (Map.insert a) (bMay `mplus` aMay)

101−-- . maybe id (Map.insert b) (aMay `mplus` bMay)

102−-- . Map.delete a . Map.delete b $ map

103−-- @

104−swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v

105−swapMapKey src dst

106− | src == dst = mempty

107− | otherwise =

108− PatchMapWithMove $ Map.fromList

109− [ (dst, NodeInfo (From_Move src) (Just src))

110− , (src, NodeInfo (From_Move dst) (Just dst))

111− ]

112−

113−-- |Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'Map.delete'.

114−deleteMapKey :: k -> PatchMapWithMove k v

115−deleteMapKey k = PatchMapWithMove . Map.singleton k $ NodeInfo From_Delete Nothing

116−

117−-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants.

118−--

119−-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithMove' are preserved; they will not be checked.

120−unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v

121−unsafePatchMapWithMove = PatchMapWithMove

122−

123−-- | Apply the insertions, deletions, and moves to a given 'Map'

124−instance Ord k => Patch (PatchMapWithMove k v) where

125− type PatchTarget (PatchMapWithMove k v) = Map k v

126− apply (PatchMapWithMove p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?

127− where insertions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of

128− From_Insert v -> Just v

129− From_Move k -> Map.lookup k old

130− From_Delete -> Nothing

131− deletions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of

132− From_Delete -> Just ()

133− _ -> Nothing

134−

135−-- | Returns all the new elements that will be added to the 'Map'.

136−patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]

137−patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap

138−

139−-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@.

140−patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v

141−patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p

142− where f ni = case _nodeInfo_from ni of

143− From_Insert v -> Just v

144− From_Move _ -> Nothing

145− From_Delete -> Nothing

146−

147−-- | Create a 'PatchMapWithMove' that, if applied to the given 'Map', will sort

148−-- its values using the given ordering function. The set keys of the 'Map' is

149−-- not changed.

150−patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v

151−patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted

152− where unsorted = Map.toList m

153− sorted = sortBy (cmp `on` snd) unsorted

154− f (to, _) (from, _) = if to == from then Nothing else

155− Just (from, to)

156− reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted

157− g (to, _) (from, _) = if to == from then Nothing else

158− let Just movingTo = Map.lookup to reverseMapping

159− in Just (to, NodeInfo (From_Move from) $ Just movingTo)

160−

161−-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,

162−-- will produce a 'Map' with the same values as the second 'Map' but with the

163−-- values sorted with the given ordering function.

164−patchThatChangesAndSortsMapWith :: forall k v. (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v

165−patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex

166− where newList = Map.toList newByIndexUnsorted

167− newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList

168−

169−-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,

170−-- will produce the second 'Map'.

171−patchThatChangesMap :: (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v

172−patchThatChangesMap oldByIndex newByIndex = patch

173− where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex

174− (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do

175− let f k v = do

176− remainingValues <- get

177− let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys

178− then Map.delete v remainingValues

179− else Map.insert v remainingKeys remainingValues

180− case Map.lookup v remainingValues of

181− Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take

182− Just fromKs ->

183− if k `Set.member` fromKs

184− then do

185− putRemainingKeys $ Set.delete k fromKs

186− return $ NodeInfo (From_Move k) $ Just undefined -- There's an existing value, and it's here, so no patch necessary

187− else do

188− (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here

189− putRemainingKeys remainingKeys

190− return $ NodeInfo (From_Move fromK) $ Just undefined

191− Map.traverseWithKey f newByIndex

192− unusedOldKeys = fold unusedValuesByValue

193− pointlessMove k = \case

194− From_Move k' | k == k' -> True

195− _ -> False

196− keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)

197− then Just undefined

198− else Nothing

199− patch = unsafePatchMapWithMove $ Map.filterWithKey (\k -> not . pointlessMove k . _nodeInfo_from) $ Map.mergeWithKey (\k a _ -> Just $ nodeInfoSetTo (keyWasMoved k) a) (Map.mapWithKey $ \k -> nodeInfoSetTo $ keyWasMoved k) (Map.mapWithKey $ \k _ -> NodeInfo From_Delete $ keyWasMoved k) insertsAndMoves oldByIndex

200−

201−-- | Change the 'From' value of a 'NodeInfo'

202−nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v

203−nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }

204−

205−-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or

206−-- 'Applicative', 'Monad', etc.) action to get the new value

207−nodeInfoMapMFrom :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)

208−nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni

209−

210−-- | Set the 'To' field of a 'NodeInfo'

211−nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v

212−nodeInfoSetTo to ni = ni { _nodeInfo_to = to }

213−

214−-- |Helper data structure used for composing patches using the monoid instance.

215−data Fixup k v

216− = Fixup_Delete

217− | Fixup_Update (These (From k v) (To k))

218−

219−-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@

220−instance Ord k => Semigroup (PatchMapWithMove k v) where

221− PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m

222− where

223− connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb

224− h :: (k, (Maybe k, From k v)) -> [(k, Fixup k v)]

225− h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of

226− (Just toAfter, From_Move fromBefore)

227− | fromBefore == toAfter

228− -> [(toAfter, Fixup_Delete)]

229− | otherwise

230− -> [ (toAfter, Fixup_Update (This editBefore))

231− , (fromBefore, Fixup_Update (That mToAfter))

232− ]

233− (Nothing, From_Move fromBefore) -> [(fromBefore, Fixup_Update (That mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map

234− (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]

235− (Nothing, _) -> []

236− mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete

237− mergeFixups _ (Fixup_Update a) (Fixup_Update b)

238− | This x <- a, That y <- b

239− = Fixup_Update $ These x y

240− | That y <- a, This x <- b

241− = Fixup_Update $ These x y

242− mergeFixups _ _ _ = error "PatchMapWithMove: incompatible fixups"

243− fixups = Map.fromListWithKey mergeFixups $ concatMap h connections

244− combineNodeInfos _ nia nib = NodeInfo

245− { _nodeInfo_from = _nodeInfo_from nia

246− , _nodeInfo_to = _nodeInfo_to nib

247− }

248− applyFixup _ ni = \case

249− Fixup_Delete -> Nothing

250− Fixup_Update u -> Just $ NodeInfo

251− { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u

252− , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u

253− }

254− m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups

255− getHere :: These a b -> Maybe a

256− getHere = \case

257− This a -> Just a

258− These a _ -> Just a

259− That _ -> Nothing

260− getThere :: These a b -> Maybe b

261− getThere = \case

262− This _ -> Nothing

263− These _ b -> Just b

264− That b -> Just b

265−

266−--TODO: Figure out how to implement this in terms of PatchDMapWithMove rather than duplicating it here

267−-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@

268−instance Ord k => Monoid (PatchMapWithMove k v) where

269− mempty = PatchMapWithMove mempty

270− mappend = (<>)

src/Reflex/PerformEvent/Base.hs+2

@@ -164,6 +164,8 @@ instance (ReflexHost t, MonadHold t m) => MonadHold t (PerformEventT t m) where

164 buildDynamic getV0 v' = PerformEventT $ lift $ buildDynamic getV0 v'

165 {-# INLINABLE headE #-}

166 headE = PerformEventT . lift . headE

167+ {-# INLINABLE now #-}

168+ now = PerformEventT . lift $ now

167

169

168instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m) where

170instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m) where

169 type Ref (PerformEventT t m) = Ref (HostFrame t)

171 type Ref (PerformEventT t m) = Ref (HostFrame t)

src/Reflex/PerformEvent/Class.hs+6−1

@@ -8,7 +8,6 @@

8{-# LANGUAGE RankNTypes #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE TypeFamilies #-}

11−{-# LANGUAGE TypeOperators #-}

12{-# LANGUAGE UndecidableInstances #-}

11{-# LANGUAGE UndecidableInstances #-}

13#ifdef USE_REFLEX_OPTIMIZER

12#ifdef USE_REFLEX_OPTIMIZER

14{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

13{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

@@ -22,6 +21,7 @@ import Reflex.Class

22import Reflex.TriggerEvent.Class

21import Reflex.TriggerEvent.Class

24import Control.Monad.Reader

23import Control.Monad.Reader

24+import Control.Monad.Trans.Maybe (MaybeT (..))

26-- | 'PerformEvent' represents actions that can trigger other actions based on

27-- 'Event's.

@@ -61,3 +61,8 @@ instance PerformEvent t m => PerformEvent t (ReaderT r m) where

61 performEvent e = do

62 r <- ask

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+2−1

@@ -9,7 +9,6 @@

9{-# LANGUAGE RecursiveDo #-}

10{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE TypeFamilies #-}

12−{-# LANGUAGE TypeOperators #-}

13{-# LANGUAGE UndecidableInstances #-}

12{-# LANGUAGE UndecidableInstances #-}

14#ifdef USE_REFLEX_OPTIMIZER

13#ifdef USE_REFLEX_OPTIMIZER

15{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

14{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

@@ -84,6 +83,8 @@ instance MonadHold t m => MonadHold t (PostBuildT t m) where

84 buildDynamic a0 = lift . buildDynamic a0

83 buildDynamic a0 = lift . buildDynamic a0

85 {-# INLINABLE headE #-}

84 {-# INLINABLE headE #-}

86 headE = lift . headE

85 headE = lift . headE

86+ {-# INLINABLE now #-}

87+ now = lift now

88instance PerformEvent t m => PerformEvent t (PostBuildT t m) where

89instance PerformEvent t m => PerformEvent t (PostBuildT t m) where

89 type Performable (PostBuildT t m) = Performable m

90 type Performable (PostBuildT t m) = Performable m

src/Reflex/PostBuild/Class.hs−1

@@ -6,7 +6,6 @@

6{-# LANGUAGE FunctionalDependencies #-}

7{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE TypeFamilies #-}

9−{-# LANGUAGE TypeOperators #-}

10{-# LANGUAGE UndecidableInstances #-}

9{-# LANGUAGE UndecidableInstances #-}

11#ifdef USE_REFLEX_OPTIMIZER

10#ifdef USE_REFLEX_OPTIMIZER

12{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

11{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

src/Reflex/Profiled.hs+59−5

@@ -26,8 +26,10 @@ import Control.Monad.Primitive

26import Control.Monad.Reader

27import Control.Monad.Ref

28import Control.Monad.State.Strict (StateT, execStateT, modify)

29+import Data.Bifunctor

29import Data.Coerce

30import Data.Coerce

30−import Data.Dependent.Map (DMap, GCompare)

31+import Data.Dependent.Map (DMap)

32+import Data.GADT.Compare (GCompare)

31import Data.FastMutableIntMap

33import Data.FastMutableIntMap

32import Data.IORef

34import Data.IORef

33import Data.List

35import Data.List

@@ -42,12 +44,20 @@ import Foreign.Ptr

42import GHC.Foreign

44import GHC.Foreign

43import GHC.IO.Encoding

45import GHC.IO.Encoding

44import GHC.Stack

46import GHC.Stack

47+import Reflex.Adjustable.Class

48+import Reflex.BehaviorWriter.Class

45import Reflex.Class

49import Reflex.Class

50+import Reflex.DynamicWriter.Class

51+import Reflex.EventWriter.Class

46import Reflex.Host.Class

52import Reflex.Host.Class

53+import Reflex.NotReady.Class

47import Reflex.PerformEvent.Class

54import Reflex.PerformEvent.Class

55+import Reflex.PostBuild.Class

56+import Reflex.Query.Class

57+import Reflex.Requester.Class

58+import Reflex.TriggerEvent.Class

49import System.IO.Unsafe

60import System.IO.Unsafe

50−import Unsafe.Coerce

52data ProfiledTimeline t

62data ProfiledTimeline t

@@ -137,7 +147,7 @@ instance Reflex t => Reflex (ProfiledTimeline t) where

137 pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e

147 pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e

138 pull = Behavior_Profiled . pull . coerce

148 pull = Behavior_Profiled . pull . coerce

139 fanG (Event_Profiled e) = EventSelectorG $ coerce $ selectG (fanG $ profileEvent e)

149 fanG (Event_Profiled e) = EventSelectorG $ coerce $ selectG (fanG $ profileEvent e)

140− mergeG :: forall (k :: z -> *) q v. GCompare k

150+ mergeG :: forall z (k :: z -> *) q v. GCompare k

141 => (forall a. q a -> Event (ProfiledTimeline t) (v a))

151 => (forall a. q a -> Event (ProfiledTimeline t) (v a))

142 -> DMap k q -> Event (ProfiledTimeline t) (DMap k v)

152 -> DMap k q -> Event (ProfiledTimeline t) (DMap k v)

143 mergeG nt = Event_Profiled #. mergeG (coerce nt)

153 mergeG nt = Event_Profiled #. mergeG (coerce nt)

@@ -147,8 +157,8 @@ instance Reflex t => Reflex (ProfiledTimeline t) where

147 updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d

157 updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d

148 unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'

158 unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'

149 unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'

159 unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'

150− mergeIncrementalG nt = (Event_Profiled . coerce) #. mergeIncrementalG nt

160+ mergeIncrementalG nt res = Event_Profiled $ mergeIncrementalG (coerce nt) (coerce res)

151− mergeIncrementalWithMoveG nt = (Event_Profiled . coerce) #. mergeIncrementalWithMoveG nt

161+ mergeIncrementalWithMoveG nt res = Event_Profiled $ mergeIncrementalWithMoveG (coerce nt) (coerce res)

152 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i

162 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i

153 updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i

163 updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i

154 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i

164 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i

@@ -174,10 +184,21 @@ instance MonadHold t m => MonadHold (ProfiledTimeline t) (ProfiledM m) where

174 holdIncremental v0 (Event_Profiled v') = ProfiledM $ Incremental_Profiled <$> holdIncremental v0 v'

184 holdIncremental v0 (Event_Profiled v') = ProfiledM $ Incremental_Profiled <$> holdIncremental v0 v'

175 buildDynamic (ProfiledM v0) (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> buildDynamic v0 v'

185 buildDynamic (ProfiledM v0) (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> buildDynamic v0 v'

176 headE (Event_Profiled e) = ProfiledM $ Event_Profiled <$> headE e

186 headE (Event_Profiled e) = ProfiledM $ Event_Profiled <$> headE e

187+ now = ProfiledM $ Event_Profiled <$> now

177

188

178instance MonadSample t m => MonadSample (ProfiledTimeline t) (ProfiledM m) where

189instance MonadSample t m => MonadSample (ProfiledTimeline t) (ProfiledM m) where

179 sample (Behavior_Profiled b) = ProfiledM $ sample b

190 sample (Behavior_Profiled b) = ProfiledM $ sample b

180

191

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+

181instance MonadTrans ProfiledM where

202instance MonadTrans ProfiledM where

182 lift = ProfiledM

203 lift = ProfiledM

183

204

@@ -189,6 +210,39 @@ instance PerformEvent t m => PerformEvent (ProfiledTimeline t) (ProfiledM m) whe

189 performEvent_ = lift . performEvent_ . coerce

210 performEvent_ = lift . performEvent_ . coerce

190 performEvent = lift . fmap coerce . performEvent . coerce

211 performEvent = lift . fmap coerce . performEvent . coerce

191

212

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+

192instance MonadRef m => MonadRef (ProfiledM m) where

246instance MonadRef m => MonadRef (ProfiledM m) where

193 type Ref (ProfiledM m) = Ref m

247 type Ref (ProfiledM m) = Ref m

194 newRef = lift . newRef

248 newRef = lift . newRef

src/Reflex/Pure.hs+6−1

@@ -32,7 +32,8 @@ module Reflex.Pure

32 ) where

34import Control.Monad

35−import Data.Dependent.Map (DMap, GCompare)

35+import Data.Dependent.Map (DMap)

36+import Data.GADT.Compare (GCompare)

36import qualified Data.Dependent.Map as DMap

37import qualified Data.Dependent.Map as DMap

37import Data.IntMap (IntMap)

38import Data.IntMap (IntMap)

38import qualified Data.IntMap as IntMap

39import qualified Data.IntMap as IntMap

@@ -210,3 +211,7 @@ instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where

210 Just x -> fromMaybe lastValue $ apply x lastValue

211 Just x -> fromMaybe lastValue $ apply x lastValue

211

212

212 headE = slowHeadE

213 headE = slowHeadE

214+ now t = Event $ guard . (t ==)

215+

216+

217+

src/Reflex/Query/Base.hs+10−4

@@ -22,16 +22,19 @@ module Reflex.Query.Base

22import Control.Applicative (liftA2)

23import Control.Monad.Exception

24import Control.Monad.Fix

25+import Control.Monad.Morph

25import Control.Monad.Primitive

26import Control.Monad.Primitive

26import Control.Monad.Reader

27import Control.Monad.Reader

27import Control.Monad.Ref

28import Control.Monad.Ref

28import Control.Monad.State.Strict

29import Control.Monad.State.Strict

29import Data.Align

30import Data.Align

30−import Data.Dependent.Map (DMap, DSum (..))

31+import Data.Dependent.Map (DMap)

31import qualified Data.Dependent.Map as DMap

32import qualified Data.Dependent.Map as DMap

33+import Data.Dependent.Sum (DSum(..))

32import Data.Foldable

34import Data.Foldable

33import Data.Functor.Compose

35import Data.Functor.Compose

34import Data.Functor.Misc

36import Data.Functor.Misc

37+import Data.GADT.Compare (GCompare)

35import Data.IntMap (IntMap)

38import Data.IntMap (IntMap)

36import qualified Data.IntMap as IntMap

39import qualified Data.IntMap as IntMap

37import Data.Map (Map)

40import Data.Map (Map)

@@ -47,7 +50,7 @@ import Reflex.DynamicWriter.Class

47import Reflex.EventWriter.Base

50import Reflex.EventWriter.Base

48import Reflex.EventWriter.Class

51import Reflex.EventWriter.Class

49import Reflex.Host.Class

52import Reflex.Host.Class

50−import qualified Reflex.Patch.MapWithMove as MapWithMove

53+import qualified Data.Patch.MapWithMove as MapWithMove

51import Reflex.PerformEvent.Class

54import Reflex.PerformEvent.Class

52import Reflex.PostBuild.Class

55import Reflex.PostBuild.Class

53import Reflex.Query.Class

56import Reflex.Query.Class

@@ -135,7 +138,7 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t

135 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch

138 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch

136 return (liftedResult0, liftedResult')

139 return (liftedResult0, liftedResult')

137

140

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'))

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'))

139 traverseDMapWithKeyWithAdjust f dm0 dm' = do

142 traverseDMapWithKeyWithAdjust f dm0 dm' = do

140 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)

143 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)

141 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v

144 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v

@@ -180,7 +183,7 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t

180 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch

183 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch

181 return (liftedResult0, liftedResult')

184 return (liftedResult0, liftedResult')

182

185

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'))

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'))

184 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do

187 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do

185 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)

188 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)

186 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v

189 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v

@@ -237,6 +240,9 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t

237instance MonadTrans (QueryT t q) where

240instance MonadTrans (QueryT t q) where

238 lift = QueryT . lift . lift . lift

241 lift = QueryT . lift . lift . lift

239

242

243+instance MFunctor (QueryT t q) where

244+ hoist = mapQueryT

245+

240instance PrimMonad m => PrimMonad (QueryT t q m) where

246instance PrimMonad m => PrimMonad (QueryT t q m) where

241 type PrimState (QueryT t q m) = PrimState m

247 type PrimState (QueryT t q m) = PrimState m

242 primitive = lift . primitive

248 primitive = lift . primitive

src/Reflex/Query/Class.hs+44−4

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DeriveDataTypeable #-}

2{-# LANGUAGE DeriveDataTypeable #-}

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

@@ -21,6 +22,7 @@ module Reflex.Query.Class

21 , MonadQuery (..)

22 , MonadQuery (..)

22 , tellQueryDyn

23 , tellQueryDyn

23 , queryDyn

24 , queryDyn

25+ , subQuery

24 , mapQuery

26 , mapQuery

25 , mapQueryResult

27 , mapQueryResult

26 ) where

28 ) where

@@ -35,6 +37,9 @@ import Data.Map.Monoidal (MonoidalMap)

35import qualified Data.Map.Monoidal as MonoidalMap

37import qualified Data.Map.Monoidal as MonoidalMap

36import Data.Semigroup (Semigroup(..))

38import Data.Semigroup (Semigroup(..))

37import Foreign.Storable

39import Foreign.Storable

40+import Data.Void

41+import Data.Monoid hiding ((<>))

42+import Control.Applicative

39import Reflex.Class

44import Reflex.Class

@@ -50,6 +55,37 @@ instance (Ord k, Query v) => Query (MonoidalMap k v) where

50 type QueryResult (MonoidalMap k v) = MonoidalMap k (QueryResult v)

55 type QueryResult (MonoidalMap k v) = MonoidalMap k (QueryResult v)

51 crop q r = MonoidalMap.intersectionWith (flip crop) r q

56 crop q r = MonoidalMap.intersectionWith (flip crop) r q

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+

53-- | QueryMorphism's must be group homomorphisms when acting on the query type

89-- | QueryMorphism's must be group homomorphisms when acting on the query type

54-- and compatible with the query relationship when acting on the query result.

90-- and compatible with the query relationship when acting on the query result.

55data QueryMorphism q q' = QueryMorphism

91data QueryMorphism q q' = QueryMorphism

@@ -89,7 +125,7 @@ instance Group SelectedCount where

125

90instance Additive SelectedCount

126instance Additive SelectedCount

127

92−-- | The Semigroup/Monoid/Group instances for a Query containing 'SelectedCount's should use

128+-- | The Semigroup\/Monoid\/Group instances for a Query containing 'SelectedCount's should use

93-- this function which returns Nothing if the result is 0. This allows the pruning of leaves

129-- this function which returns Nothing if the result is 0. This allows the pruning of leaves

94-- of the 'Query' that are no longer wanted.

130-- of the 'Query' that are no longer wanted.

95combineSelectedCounts :: SelectedCount -> SelectedCount -> Maybe SelectedCount

131combineSelectedCounts :: SelectedCount -> SelectedCount -> Maybe SelectedCount

@@ -97,12 +133,12 @@ combineSelectedCounts (SelectedCount i) (SelectedCount j) = if i == negate j the

133

98-- | A class that allows sending of 'Query's and retrieval of 'QueryResult's. See 'queryDyn' for a commonly

134-- | A class that allows sending of 'Query's and retrieval of 'QueryResult's. See 'queryDyn' for a commonly

99-- used interface.

135-- used interface.

100−class (Group q, Additive q, Query q) => MonadQuery t q m | m -> q t where

136+class (Group q, Additive q, Query q, Monad m) => MonadQuery t q m | m -> q t where

101 tellQueryIncremental :: Incremental t (AdditivePatch q) -> m ()

137 tellQueryIncremental :: Incremental t (AdditivePatch q) -> m ()

102 askQueryResult :: m (Dynamic t (QueryResult q))

138 askQueryResult :: m (Dynamic t (QueryResult q))

103 queryIncremental :: Incremental t (AdditivePatch q) -> m (Dynamic t (QueryResult q))

139 queryIncremental :: Incremental t (AdditivePatch q) -> m (Dynamic t (QueryResult q))

104

140

105−instance (Monad m, MonadQuery t q m) => MonadQuery t q (ReaderT r m) where

141+instance MonadQuery t q m => MonadQuery t q (ReaderT r m) where

106 tellQueryIncremental = lift . tellQueryIncremental

142 tellQueryIncremental = lift . tellQueryIncremental

107 askQueryResult = lift askQueryResult

143 askQueryResult = lift askQueryResult

108 queryIncremental = lift . queryIncremental

144 queryIncremental = lift . queryIncremental

@@ -112,7 +148,11 @@ tellQueryDyn :: (Reflex t, MonadQuery t q m) => Dynamic t q -> m ()

112tellQueryDyn d = tellQueryIncremental $ unsafeBuildIncremental (sample (current d)) $ attachWith (\old new -> AdditivePatch $ new ~~ old) (current d) (updated d)

148tellQueryDyn d = tellQueryIncremental $ unsafeBuildIncremental (sample (current d)) $ attachWith (\old new -> AdditivePatch $ new ~~ old) (current d) (updated d)

113

149

114-- | Retrieve 'Dynamic'ally updating 'QueryResult's for a 'Dynamic'ally updating 'Query'.

150-- | Retrieve 'Dynamic'ally updating 'QueryResult's for a 'Dynamic'ally updating 'Query'.

115−queryDyn :: (Reflex t, Monad m, MonadQuery t q m) => Dynamic t q -> m (Dynamic t (QueryResult q))

151+queryDyn :: (Reflex t, MonadQuery t q m) => Dynamic t q -> m (Dynamic t (QueryResult q))

116queryDyn q = do

152queryDyn q = do

117 tellQueryDyn q

153 tellQueryDyn q

118 zipDynWith crop q <$> askQueryResult

154 zipDynWith crop q <$> askQueryResult

155+

156+-- | Use a query morphism to operate on a smaller version of a query.

157+subQuery :: (Reflex t, MonadQuery t q2 m) => QueryMorphism q1 q2 -> Dynamic t q1 -> m (Dynamic t (QueryResult q1))

158+subQuery (QueryMorphism f g) x = fmap g <$> queryDyn (fmap f x)

src/Reflex/Requester/Base.hs+97−27

@@ -1,6 +1,7 @@

1-- | This module provides 'RequesterT', the standard implementation of

2-- 'Requester'.

3{-# LANGUAGE AllowAmbiguousTypes #-}

4+{-# LANGUAGE ApplicativeDo #-}

4{-# LANGUAGE CPP #-}

5{-# LANGUAGE CPP #-}

5{-# LANGUAGE EmptyDataDecls #-}

6{-# LANGUAGE EmptyDataDecls #-}

6{-# LANGUAGE ExistentialQuantification #-}

7{-# LANGUAGE ExistentialQuantification #-}

@@ -32,6 +33,7 @@ module Reflex.Requester.Base

32 , requesterDataToList

33 , requesterDataToList

33 , singletonRequesterData

34 , singletonRequesterData

34 , matchResponsesWithRequests

35 , matchResponsesWithRequests

36+ , matchResponseMapWithRequests

35 , multiEntry

37 , multiEntry

36 , unMultiEntry

38 , unMultiEntry

37 , requesting'

39 , requesting'

@@ -49,14 +51,17 @@ import Reflex.TriggerEvent.Class

49import Control.Applicative (liftA2)

51import Control.Applicative (liftA2)

50import Control.Monad.Exception

52import Control.Monad.Exception

51import Control.Monad.Identity

53import Control.Monad.Identity

54+import Control.Monad.Morph

52import Control.Monad.Primitive

55import Control.Monad.Primitive

53import Control.Monad.Reader

56import Control.Monad.Reader

54import Control.Monad.Ref

57import Control.Monad.Ref

55import Control.Monad.State.Strict

58import Control.Monad.State.Strict

56import Data.Bits

59import Data.Bits

57import Data.Coerce

60import Data.Coerce

61+import Data.Constraint

58−import Data.Dependent.Map (DMap, DSum (..))

62+import Data.Dependent.Map (DMap)

59import qualified Data.Dependent.Map as DMap

63import qualified Data.Dependent.Map as DMap

64+import Data.Dependent.Sum (DSum (..))

60import Data.Functor.Compose

65import Data.Functor.Compose

61import Data.Functor.Misc

66import Data.Functor.Misc

62import Data.IntMap.Strict (IntMap)

67import Data.IntMap.Strict (IntMap)

@@ -79,19 +84,51 @@ newtype TagMap (f :: * -> *) = TagMap (IntMap Any)

80newtype RequesterData f = RequesterData (TagMap (Entry f))

85newtype RequesterData f = RequesterData (TagMap (Entry f))

87+emptyRequesterData :: RequesterData f

88+emptyRequesterData = RequesterData $ TagMap IntMap.empty

89+

82data RequesterDataKey a where

90data RequesterDataKey a where

83 RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a

91 RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a

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

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

85− RequesterDataKey_Multi2 :: {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a

93+ RequesterDataKey_Multi2 :: GCompare k => {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a

86 RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a

94 RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a

88singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f

96singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f

89singletonRequesterData rdk v = case rdk of

97singletonRequesterData rdk v = case rdk of

90 RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v

98 RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v

91 RequesterDataKey_Multi k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v

99 RequesterDataKey_Multi k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v

92− RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v

100+ RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Multi2Contents

101+ { _multi2Contents_values = Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v

102+ , _multi2Contents_dict = Dict

103+ }

93 RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v

104 RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v

105

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+

95requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]

132requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]

96requesterDataToList (RequesterData m) = do

133requesterDataToList (RequesterData m) = do

97 k :=> Entry e <- tagMapToList m

134 k :=> Entry e <- tagMapToList m

@@ -101,11 +138,12 @@ requesterDataToList (RequesterData m) = do

101 (k', e') <- IntMap.toList e

138 (k', e') <- IntMap.toList e

102 k'' :=> e'' <- requesterDataToList e'

139 k'' :=> e'' <- requesterDataToList e'

103 return $ RequesterDataKey_Multi k k' k'' :=> e''

140 return $ RequesterDataKey_Multi k k' k'' :=> e''

104− MyTagType_Multi2 -> do

141+ MyTagType_Multi2 -> case _multi2Contents_dict e of

142+ Dict -> do

105− (k', e') <- Map.toList e

143+ (k', e') <- Map.toList $ _multi2Contents_values e

106− (k'', e'') <- IntMap.toList e'

144+ (k'', e'') <- IntMap.toList e'

107− k''' :=> e''' <- requesterDataToList e''

145+ k''' :=> e''' <- requesterDataToList e''

108− return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''

146+ return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''

109 MyTagType_Multi3 -> do

147 MyTagType_Multi3 -> do

110 (k', e') <- IntMap.toList e

148 (k', e') <- IntMap.toList e

111 (k'', e'') <- IntMap.toList e'

149 (k'', e'') <- IntMap.toList e'

@@ -133,7 +171,13 @@ traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWith

133 go k (Entry request) = Entry <$> case myKeyType k of

171 go k (Entry request) = Entry <$> case myKeyType k of

134 MyTagType_Single -> f request

172 MyTagType_Single -> f request

135 MyTagType_Multi -> traverse (traverseRequesterData f) request

173 MyTagType_Multi -> traverse (traverseRequesterData f) request

174+ MyTagType_Multi2 -> case request of

175+ Multi2Contents { _multi2Contents_values = request', _multi2Contents_dict = Dict } -> do

136− MyTagType_Multi2 -> traverse (traverse (traverseRequesterData f)) request

176+ v <- traverse (traverse (traverseRequesterData f)) request'

177+ pure $ Multi2Contents

178+ { _multi2Contents_values = v

179+ , _multi2Contents_dict = Dict

180+ }

137 MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request

181 MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request

138

182

139-- | 'traverseRequesterData' with its arguments flipped

183-- | 'traverseRequesterData' with its arguments flipped

@@ -177,9 +221,14 @@ instance MyTagTypeOffset Multi3 where

177type family EntryContents request a where

221type family EntryContents request a where

178 EntryContents request (Single a) = request a

222 EntryContents request (Single a) = request a

179 EntryContents request Multi = IntMap (RequesterData request)

223 EntryContents request Multi = IntMap (RequesterData request)

180− EntryContents request (Multi2 k) = Map (Some k) (IntMap (RequesterData request))

224+ EntryContents request (Multi2 k) = Multi2Contents k request

181 EntryContents request Multi3 = IntMap (IntMap (RequesterData request))

225 EntryContents request Multi3 = IntMap (IntMap (RequesterData request))

182

226

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+

183newtype Entry request x = Entry { unEntry :: EntryContents request x }

232newtype Entry request x = Entry { unEntry :: EntryContents request x }

184

233

185{-# INLINE singleEntry #-}

234{-# INLINE singleEntry #-}

@@ -308,7 +357,7 @@ tagRequest req = do

308 return t

357 return t

309

358

310{-# INLINE responseFromTag #-}

359{-# INLINE responseFromTag #-}

311−responseFromTag :: Monad m => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))

360+responseFromTag :: forall m t request response x. Monad m => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))

312responseFromTag (MyTagWrap t) = do

361responseFromTag (MyTagWrap t) = do

313 responses :: EventSelectorInt t Any <- RequesterT ask

362 responses :: EventSelectorInt t Any <- RequesterT ask

314 return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t

363 return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t

@@ -316,6 +365,9 @@ responseFromTag (MyTagWrap t) = do

316instance MonadTrans (RequesterT t request response) where

365instance MonadTrans (RequesterT t request response) where

317 lift = RequesterT . lift . lift

366 lift = RequesterT . lift . lift

318

367

368+instance MFunctor (RequesterT t request response) where

369+ hoist f = RequesterT . hoist (hoist f) . unRequesterT

370+

319instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where

371instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where

320 type Performable (RequesterT t request response m) = Performable m

372 type Performable (RequesterT t request response m) = Performable m

321 performEvent_ = lift . performEvent_

373 performEvent_ = lift . performEvent_

@@ -435,9 +487,9 @@ traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchN

435 let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))

487 let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))

436 responses = fanMap $ fmapCheap unpack response

488 responses = fanMap $ fmapCheap unpack response

437 unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))

489 unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))

438− unpack = unEntry

490+ unpack = _multi2Contents_values . unEntry

439 pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)

491 pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)

440− pack = Entry

492+ pack m = Entry $ Multi2Contents { _multi2Contents_values = m, _multi2Contents_dict = Dict }

441 f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)

493 f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)

442 f' k (Compose (n, v)) = do

494 f' k (Compose (n, v)) = do

443 (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some k))

495 (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some k))

@@ -458,9 +510,6 @@ traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchN

458data Decoder rawResponse response =

510data Decoder rawResponse response =

459 forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)

511 forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)

460

512

461−-- | Matches incoming responses with previously-sent requests

462−-- and uses the provided request "decoder" function to process

463−-- incoming responses.

464matchResponsesWithRequests

513matchResponsesWithRequests

465 :: forall t rawRequest rawResponse request response m.

514 :: forall t rawRequest rawResponse request response m.

466 ( MonadFix m

515 ( MonadFix m

@@ -479,7 +528,30 @@ matchResponsesWithRequests

479 )

528 )

480 -- ^ A map of outgoing wire-format requests and an event of responses keyed

529 -- ^ A map of outgoing wire-format requests and an event of responses keyed

481 -- by the 'RequesterData' key of the associated outgoing request

530 -- by the 'RequesterData' key of the associated outgoing request

482−matchResponsesWithRequests f send recv = do

531+matchResponsesWithRequests f send recv = matchResponseMapWithRequests f send $ uncurry Map.singleton <$> recv

532+

533+-- | Matches incoming responses with previously-sent requests

534+-- and uses the provided request "decoder" function to process

535+-- incoming responses.

536+matchResponseMapWithRequests

537+ :: forall t rawRequest rawResponse request response m.

538+ ( MonadFix m

539+ , MonadHold t m

540+ , Reflex t

541+ )

542+ => (forall a. request a -> (rawRequest, rawResponse -> response a))

543+ -- ^ Given a request (from 'Requester'), produces the wire format of the

544+ -- request and a function used to process the associated response

545+ -> Event t (RequesterData request)

546+ -- ^ The outgoing requests

547+ -> Event t (Map Int rawResponse)

548+ -- ^ A map of incoming responses, tagged by an identifying key

549+ -> m ( Event t (Map Int rawRequest)

550+ , Event t (RequesterData response)

551+ )

552+ -- ^ A map of outgoing wire-format requests and an event of responses keyed

553+ -- by the 'RequesterData' key of the associated outgoing request

554+matchResponseMapWithRequests f send recv = do

483 rec nextId <- hold 1 $ fmap (\(next, _, _) -> next) outgoing

555 rec nextId <- hold 1 $ fmap (\(next, _, _) -> next) outgoing

484 waitingFor :: Incremental t (PatchMap Int (Decoder rawResponse response)) <-

556 waitingFor :: Incremental t (PatchMap Int (Decoder rawResponse response)) <-

485 holdIncremental mempty $ leftmost

557 holdIncremental mempty $ leftmost

@@ -521,17 +593,15 @@ matchResponsesWithRequests f send recv = do

521 processIncoming

593 processIncoming

522 :: Incremental t (PatchMap Int (Decoder rawResponse response))

594 :: Incremental t (PatchMap Int (Decoder rawResponse response))

523 -- A map of outstanding expected responses

595 -- A map of outstanding expected responses

524− -> Event t (Int, rawResponse)

596+ -> Event t (Map Int rawResponse)

525 -- A incoming response paired with its identifying key

597 -- A incoming response paired with its identifying key

526 -> Event t (RequesterData response, PatchMap Int v)

598 -> Event t (RequesterData response, PatchMap Int v)

527 -- The decoded response and a patch that clears the outstanding responses queue

599 -- The decoded response and a patch that clears the outstanding responses queue

528− processIncoming waitingFor inc = flip push inc $ \(n, rawRsp) -> do

600+ processIncoming waitingFor inc = flip push inc $ \rspMap -> do

529 wf <- sample $ currentIncremental waitingFor

601 wf <- sample $ currentIncremental waitingFor

530− case Map.lookup n wf of

531− Nothing -> return Nothing -- TODO How should lookup failures be handled here? They shouldn't ever happen..

532− Just (Decoder k rspF) -> do

602+ let match rawRsp (Decoder k rspF) =

533− let rsp = rspF rawRsp

603+ let rsp = rspF rawRsp

534− return $ Just

535− ( singletonRequesterData k rsp

604+ in singletonRequesterData k rsp

536− , PatchMap $ Map.singleton n Nothing

605+ matches = Map.intersectionWith match rspMap wf

537− )

606+ pure $ if Map.null matches then Nothing else Just

607+ (Map.foldl' mergeRequesterData emptyRequesterData matches, PatchMap $ Nothing <$ matches)

src/Reflex/Spider/Internal.hs+103−33

@@ -9,7 +9,6 @@

9{-# LANGUAGE GADTs #-}

10{-# LANGUAGE GeneralizedNewtypeDeriving #-}

11{-# LANGUAGE LambdaCase #-}

12−{-# LANGUAGE MultiWayIf #-}

13{-# LANGUAGE RankNTypes #-}

12{-# LANGUAGE RankNTypes #-}

14{-# LANGUAGE RoleAnnotations #-}

13{-# LANGUAGE RoleAnnotations #-}

15{-# LANGUAGE ScopedTypeVariables #-}

14{-# LANGUAGE ScopedTypeVariables #-}

@@ -20,6 +19,7 @@

20{-# LANGUAGE DeriveFunctor #-}

19{-# LANGUAGE DeriveFunctor #-}

21{-# LANGUAGE StandaloneDeriving #-}

20{-# LANGUAGE StandaloneDeriving #-}

22{-# LANGUAGE InstanceSigs #-}

21{-# LANGUAGE InstanceSigs #-}

22+{-# LANGUAGE MultiWayIf #-}

24#ifdef USE_REFLEX_OPTIMIZER

25{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

@@ -38,7 +38,6 @@ import Control.Monad hiding (forM, forM_, mapM, mapM_)

38import Control.Monad.Exception

39import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)

40import Control.Monad.Primitive

41−--import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_)

42import Control.Monad.Reader.Class

41import Control.Monad.Reader.Class

43import Control.Monad.IO.Class

42import Control.Monad.IO.Class

44import Control.Monad.ReaderIO

43import Control.Monad.ReaderIO

@@ -47,8 +46,9 @@ import Control.Monad.Fail (MonadFail)

47import qualified Control.Monad.Fail as MonadFail

46import qualified Control.Monad.Fail as MonadFail

48import Data.Align

47import Data.Align

49import Data.Coerce

48import Data.Coerce

50−import Data.Dependent.Map (DMap, DSum (..))

49+import Data.Dependent.Map (DMap)

51import qualified Data.Dependent.Map as DMap

50import qualified Data.Dependent.Map as DMap

51+import Data.Dependent.Sum (DSum (..))

52import Data.FastMutableIntMap (FastMutableIntMap, PatchIntMap (..))

53import qualified Data.FastMutableIntMap as FastMutableIntMap

54import Data.Foldable hiding (concat, elem, sequence_)

@@ -106,15 +106,21 @@ import qualified Reflex.Class

106import qualified Reflex.Class as R

107import qualified Reflex.Host.Class

108import Reflex.NotReady.Class

109−import Reflex.Patch

109+import Data.Patch

110−import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove

110+import qualified Data.Patch.DMapWithMove as PatchDMapWithMove

111import Reflex.PerformEvent.Base (PerformEventT)

112

113#ifdef DEBUG_TRACE_EVENTS

114import qualified Data.ByteString.Char8 as BS8

115import System.IO (stderr)

116import Data.List (isPrefixOf)

117+#endif

117

118

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

118withStackOneLine :: (BS8.ByteString -> a) -> a

124withStackOneLine :: (BS8.ByteString -> a) -> a

119withStackOneLine expr = unsafePerformIO $ do

125withStackOneLine expr = unsafePerformIO $ do

120 stack <- currentCallStack

126 stack <- currentCallStack

@@ -123,9 +129,33 @@ withStackOneLine expr = unsafePerformIO $ do

123

129

124#endif

130#endif

125

131

132+debugPropagate :: Bool

133+

134+debugInvalidateHeight :: Bool

135+

136+debugInvalidate :: Bool

137+

126#ifdef DEBUG

138#ifdef DEBUG

127#define DEBUG_NODEIDS

139#define DEBUG_NODEIDS

128

140

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+

129class HasNodeId a where

159class HasNodeId a where

130 getNodeId :: a -> Int

160 getNodeId :: a -> Int

131

161

@@ -163,6 +193,10 @@ showNodeId' = ("#"<>) . show

163

193

164#else

194#else

165

195

196+debugPropagate = False

197+debugInvalidateHeight = False

198+debugInvalidate = False

199+

166-- This must be inline, or error messages will cause memory leaks due to retaining the node in question

200-- This must be inline, or error messages will cause memory leaks due to retaining the node in question

167{-# INLINE showNodeId #-}

201{-# INLINE showNodeId #-}

168showNodeId :: a -> String

202showNodeId :: a -> String

@@ -219,11 +253,11 @@ subscribeAndRead = unEvent

219{-# INLINE [1] pushCheap #-}

253{-# INLINE [1] pushCheap #-}

220pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b

254pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b

221pushCheap !f e = Event $ \sub -> do

255pushCheap !f e = Event $ \sub -> do

222− (subscription, occ) <- subscribeAndRead e $ debugSubscriber' "push" (sub

256+ (subscription, occ) <- subscribeAndRead e $ debugSubscriber' "push" $ sub

223 { subscriberPropagate = \a -> do

257 { subscriberPropagate = \a -> do

224 mb <- f a

258 mb <- f a

225 mapM_ (subscriberPropagate sub) mb

259 mapM_ (subscriberPropagate sub) mb

226− })

260+ }

227 occ' <- join <$> mapM f occ

261 occ' <- join <$> mapM f occ

228 return (subscription, occ')

262 return (subscription, occ')

229

263

@@ -273,7 +307,20 @@ data CacheSubscribed x a

273#endif

307#endif

274 }

308 }

275

309

276−

310+nowSpiderEventM :: (HasSpiderTimeline x) => EventM x (R.Event (SpiderTimeline x) ())

311+nowSpiderEventM =

312+ SpiderEvent <$> now

313+

314+now :: (MonadIO m, Defer (Some Clear) m, HasSpiderTimeline x

315+ ) => m (Event x ())

316+now = do

317+ nowOrNot <- liftIO $ newIORef $ Just ()

318+ scheduleClear nowOrNot

319+ return . Event $ \_ -> do

320+ occ <- liftIO . readIORef $ nowOrNot

321+ return ( EventSubscription (return ()) eventSubscribedNow

322+ , occ

323+ )

277

324

278-- | Construct an 'Event' whose value is guaranteed not to be recomputed

325-- | Construct an 'Event' whose value is guaranteed not to be recomputed

279-- repeatedly

326-- repeatedly

@@ -417,16 +464,6 @@ data Subscriber x a = Subscriber

417 , subscriberRecalculateHeight :: !(Height -> IO ())

464 , subscriberRecalculateHeight :: !(Height -> IO ())

418 }

465 }

419

466

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−

430newSubscriberHold :: (HasSpiderTimeline x, Patch p) => Hold x p -> IO (Subscriber x p)

467newSubscriberHold :: (HasSpiderTimeline x, Patch p) => Hold x p -> IO (Subscriber x p)

431newSubscriberHold h = return $ Subscriber

468newSubscriberHold h = return $ Subscriber

432 { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h

469 { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h

@@ -570,6 +607,16 @@ eventSubscribedNever = EventSubscribed

570 , eventSubscribedWhoCreated = return ["never"]

607 , eventSubscribedWhoCreated = return ["never"]

571#endif

608#endif

572 }

609 }

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+ }

573

620

574eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x

621eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x

575eventSubscribedFan !subscribed = EventSubscribed

622eventSubscribedFan !subscribed = EventSubscribed

@@ -1299,7 +1346,7 @@ mkWeakPtrWithDebug x debugNote = do

1299 x' <- evaluate x

1346 x' <- evaluate x

1300 mkWeakPtr x' $

1347 mkWeakPtr x' $

1301 if debugFinalize

1348 if debugFinalize

1302− then Just $ putStrLn $ "finalizing: " ++ debugNote

1349+ then Just $ debugStrLn $ "finalizing: " ++ debugNote

1303 else Nothing

1350 else Nothing

1304

1351

1305type WeakList a = [Weak a]

1352type WeakList a = [Weak a]

@@ -1321,13 +1368,13 @@ debugSubscriber' description subscribed = Subscriber

1321 tracePropagate (Proxy :: Proxy x) ("subscriberPropagate: " <> description)

1368 tracePropagate (Proxy :: Proxy x) ("subscriberPropagate: " <> description)

1322 subscriberPropagate subscribed m

1369 subscriberPropagate subscribed m

1323 , subscriberInvalidateHeight = \old -> do

1370 , subscriberInvalidateHeight = \old -> do

1324− putStrLn $ "invalidateSubscriberHeight: " <> description <> ", old = " <> show (unHeight old)

1371+ traceInvalidateHeight $ "invalidateSubscriberHeight: " <> description <> ", old = " <> show (unHeight old)

1325 subscriberInvalidateHeight subscribed old

1372 subscriberInvalidateHeight subscribed old

1326− putStrLn $ "invalidateSubscriberHeight: " <> description <> ", done"

1373+ traceInvalidateHeight $ "invalidateSubscriberHeight: " <> description <> ", done"

1327 , subscriberRecalculateHeight = \new -> do

1374 , subscriberRecalculateHeight = \new -> do

1328− putStrLn $ "subscriberRecalculateHeight: " <> description <> ", new = " <> show (unHeight new)

1375+ traceInvalidateHeight $ "subscriberRecalculateHeight: " <> description <> ", new = " <> show (unHeight new)

1329 subscriberRecalculateHeight subscribed new

1376 subscriberRecalculateHeight subscribed new

1330− putStrLn $ "subscriberRecalculateHeight: " <> description <> ", done"

1377+ traceInvalidateHeight $ "subscriberRecalculateHeight: " <> description <> ", done"

1331 }

1378 }

1332

1379

1333

1380

@@ -1341,11 +1388,15 @@ withIncreasedDepth _ a = do

1341

1388

1342{-# INLINE tracePropagate #-}

1389{-# INLINE tracePropagate #-}

1343tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()

1390tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()

1344−tracePropagate p = trace p

1391+tracePropagate p = when debugPropagate . trace p

1345

1392

1346{-# INLINE traceInvalidate #-}

1393{-# INLINE traceInvalidate #-}

1347traceInvalidate :: String -> IO ()

1394traceInvalidate :: String -> IO ()

1348−traceInvalidate = liftIO . putStrLn

1395+traceInvalidate = when debugInvalidate . liftIO . debugStrLn

1396+

1397+{-# INLINE traceInvalidateHeight #-}

1398+traceInvalidateHeight :: String -> IO ()

1399+traceInvalidateHeight = when debugInvalidateHeight . liftIO . debugStrLn

1349

1400

1350{-# INLINE trace #-}

1401{-# INLINE trace #-}

1351trace :: (CanTrace x m) => proxy x -> String -> m ()

1402trace :: (CanTrace x m) => proxy x -> String -> m ()

@@ -1356,7 +1407,7 @@ traceM :: forall x proxy m. (CanTrace x m) => proxy x -> m String -> m ()

1356traceM _ getMessage = do

1407traceM _ getMessage = do

1357 message <- getMessage

1408 message <- getMessage

1358 d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)

1409 d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)

1359− liftIO $ putStrLn $ replicate d ' ' <> message

1410+ liftIO $ debugStrLn $ replicate d ' ' <> message

1360

1411

1361#else

1412#else

1362

1413

@@ -1372,6 +1423,10 @@ tracePropagate _ _ = return ()

1372traceInvalidate :: String -> IO ()

1423traceInvalidate :: String -> IO ()

1373traceInvalidate _ = return ()

1424traceInvalidate _ = return ()

1374

1425

1426+{-# INLINE traceInvalidateHeight #-}

1427+traceInvalidateHeight :: String -> IO ()

1428+traceInvalidateHeight _ = return ()

1429+

1375{-# INLINE debugSubscriber #-}

1430{-# INLINE debugSubscriber #-}

1376debugSubscriber :: String -> Subscriber x a -> IO (Subscriber x a)

1431debugSubscriber :: String -> Subscriber x a -> IO (Subscriber x a)

1377debugSubscriber _ = return

1432debugSubscriber _ = return

@@ -1412,8 +1467,11 @@ showStacks :: [[String]] -> String

1412showStacks = drawForest . listsToForest . fmap (filterStack "Reflex.Spider.Internal")

1467showStacks = drawForest . listsToForest . fmap (filterStack "Reflex.Spider.Internal")

1413

1468

1414filterStack :: String -> [String] -> [String]

1469filterStack :: String -> [String] -> [String]

1470+#ifdef DEBUG_HIDE_INTERNALS

1415filterStack prefix = filter (not . (prefix `isPrefixOf`))

1471filterStack prefix = filter (not . (prefix `isPrefixOf`))

1416−

1472+#else

1473+filterStack prefix = id

1474+#endif

1417

1475

1418#ifdef DEBUG_CYCLES

1476#ifdef DEBUG_CYCLES

1419

1477

@@ -1440,7 +1498,7 @@ instance Show EventLoopException where

1440{-# INLINE propagateSubscriberHold #-}

1498{-# INLINE propagateSubscriberHold #-}

1441propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()

1499propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()

1442propagateSubscriberHold h a = do

1500propagateSubscriberHold h a = do

1443− traceM (Proxy :: Proxy x) $ liftIO $ do

1501+ {-# SCC "trace" #-} when debugPropagate $ traceM (Proxy :: Proxy x) $ liftIO $ do

1444 invalidators <- liftIO $ readIORef $ holdInvalidators h

1502 invalidators <- liftIO $ readIORef $ holdInvalidators h

1445 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)

1503 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)

1446

1504

@@ -1448,7 +1506,7 @@ propagateSubscriberHold h a = do

1448 case {-# SCC "apply" #-} apply a v of

1506 case {-# SCC "apply" #-} apply a v of

1449 Nothing -> return ()

1507 Nothing -> return ()

1450 Just v' -> do

1508 Just v' -> do

1451− withIncreasedDepth (Proxy :: Proxy x) $

1509+ {-# SCC "trace2" #-} withIncreasedDepth (Proxy :: Proxy x) $

1452 tracePropagate (Proxy :: Proxy x) ("propagateSubscriberHold: assigning Hold" <> showNodeId h)

1510 tracePropagate (Proxy :: Proxy x) ("propagateSubscriberHold: assigning Hold" <> showNodeId h)

1453 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h

1511 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h

1454 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h

1512 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h

@@ -1980,7 +2038,7 @@ revalidateMergeHeight m = do

1980 LT -> return ()

2038 LT -> return ()

1981 EQ -> do

2039 EQ -> do

1982 let height = succHeight $ heightBagMax heights

2040 let height = succHeight $ heightBagMax heights

1983− traceInvalidate $ "recalculateSubscriberHeight: height: " <> show height

2041+ traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height

1984 writeIORef (_merge_heightRef m) $! height

2042 writeIORef (_merge_heightRef m) $! height

1985 subscriberRecalculateHeight (_merge_sub m) height

2043 subscriberRecalculateHeight (_merge_sub m) height

1986 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"

2044 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"

@@ -2144,7 +2202,7 @@ mergeIntCheap d = Event $ \sub -> do

2144 LT -> return ()

2202 LT -> return ()

2145 EQ -> do

2203 EQ -> do

2146 let height = succHeight $ heightBagMax heights

2204 let height = succHeight $ heightBagMax heights

2147− traceInvalidate $ "recalculateSubscriberHeight: height: " <> show height

2205+ traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height

2148 writeIORef heightRef $! height

2206 writeIORef heightRef $! height

2149 subscriberRecalculateHeight sub height

2207 subscriberRecalculateHeight sub height

2150 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"

2208 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"

@@ -2327,7 +2385,7 @@ runFrame a = SpiderHost $ do

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

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

2328 {-

2386 {-

2329 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)

2387 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)

2330− liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of

2388+ liftIO $ debugStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of

2331 EventRoot _ -> "EventRoot"

2389 EventRoot _ -> "EventRoot"

2332 EventNever -> "EventNever"

2390 EventNever -> "EventNever"

2333 _ -> "something else"

2391 _ -> "something else"

@@ -2462,6 +2520,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Event

2462 {-# INLINABLE headE #-}

2520 {-# INLINABLE headE #-}

2463 headE = R.slowHeadE

2521 headE = R.slowHeadE

2464-- headE (SpiderEvent e) = SpiderEvent <$> Reflex.Spider.Internal.headE e

2522-- headE (SpiderEvent e) = SpiderEvent <$> Reflex.Spider.Internal.headE e

2523+ {-# INLINABLE now #-}

2524+ now = nowSpiderEventM

2465

2525

2466instance Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where

2526instance Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where

2467 {-# INLINABLE sample #-}

2527 {-# INLINABLE sample #-}

@@ -2483,6 +2543,9 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide

2483 {-# INLINABLE headE #-}

2543 {-# INLINABLE headE #-}

2484 headE = R.slowHeadE

2544 headE = R.slowHeadE

2485-- headE (SpiderEvent e) = SpiderPushM $ SpiderEvent <$> Reflex.Spider.Internal.headE e

2545-- headE (SpiderEvent e) = SpiderPushM $ SpiderEvent <$> Reflex.Spider.Internal.headE e

2546+ {-# INLINABLE now #-}

2547+ now = SpiderPushM nowSpiderEventM

2548+

2486

2549

2487instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where

2550instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where

2488 {-# INLINE return #-}

2551 {-# INLINE return #-}

@@ -2546,6 +2609,9 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide

2546 buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e

2609 buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e

2547 {-# INLINABLE headE #-}

2610 {-# INLINABLE headE #-}

2548 headE e = runFrame . runSpiderHostFrame $ Reflex.Class.headE e

2611 headE e = runFrame . runSpiderHostFrame $ Reflex.Class.headE e

2612+ {-# INLINABLE now #-}

2613+ now = runFrame . runSpiderHostFrame $ Reflex.Class.now

2614+

2549

2615

2550instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where

2616instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where

2551 sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can

2617 sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can

@@ -2562,6 +2628,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide

2562 {-# INLINABLE headE #-}

2628 {-# INLINABLE headE #-}

2563 headE = R.slowHeadE

2629 headE = R.slowHeadE

2564-- headE (SpiderEvent e) = SpiderHostFrame $ SpiderEvent <$> Reflex.Spider.Internal.headE e

2630-- headE (SpiderEvent e) = SpiderHostFrame $ SpiderEvent <$> Reflex.Spider.Internal.headE e

2631+ {-# INLINABLE now #-}

2632+ now = SpiderHostFrame Reflex.Class.now

2565

2633

2566instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where

2634instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where

2567 {-# INLINABLE sample #-}

2635 {-# INLINABLE sample #-}

@@ -2582,6 +2650,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Refle

2582 buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e

2650 buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e

2583 {-# INLINABLE headE #-}

2651 {-# INLINABLE headE #-}

2584 headE e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.headE e

2652 headE e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.headE e

2653+ {-# INLINABLE now #-}

2654+ now = Reflex.Spider.Internal.ReadPhase Reflex.Class.now

2585

2655

2586--------------------------------------------------------------------------------

2656--------------------------------------------------------------------------------

2587-- Deprecated items

2657-- Deprecated items

@@ -2705,7 +2775,7 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2705 fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))

2775 fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))

2706 {-# INLINABLE mergeG #-}

2776 {-# INLINABLE mergeG #-}

2707 mergeG

2777 mergeG

2708− :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k

2778+ :: forall k2 (k :: k2 -> *) q (v :: k2 -> *). GCompare k

2709 => (forall a. q a -> R.Event (SpiderTimeline x) (v a))

2779 => (forall a. q a -> R.Event (SpiderTimeline x) (v a))

2710 -> DMap k q

2780 -> DMap k q

2711 -> R.Event (SpiderTimeline x) (DMap k v)

2781 -> R.Event (SpiderTimeline x) (DMap k v)

src/Reflex/TriggerEvent/Base.hs+2

@@ -122,6 +122,8 @@ instance MonadHold t m => MonadHold t (TriggerEventT t m) where

122 buildDynamic a0 = lift . buildDynamic a0

123 {-# INLINABLE headE #-}

124 headE = lift . headE

125+ {-# INLINABLE now #-}

126+ now = lift now

125

127

126instance Adjustable t m => Adjustable t (TriggerEventT t m) where

128instance Adjustable t m => Adjustable t (TriggerEventT t m) where

127 {-# INLINABLE runWithReplace #-}

129 {-# INLINABLE runWithReplace #-}

src/Reflex/TriggerEvent/Class.hs+6

@@ -12,6 +12,7 @@ import Reflex.Class

12import Control.Monad.Reader

13import Control.Monad.State

14import qualified Control.Monad.State.Strict as Strict

15+import Control.Monad.Trans.Maybe (MaybeT)

16--TODO: Shouldn't have IO hard-coded

17--TODO: Shouldn't have IO hard-coded

17-- | 'TriggerEvent' represents actions that can create 'Event's that can be

18-- | 'TriggerEvent' represents actions that can create 'Event's that can be

@@ -47,3 +48,8 @@ instance TriggerEvent t m => TriggerEvent t (Strict.StateT s m) where

47 newTriggerEvent = lift newTriggerEvent

48 newTriggerEvent = lift newTriggerEvent

48 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

49 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

49 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

50 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)

14import Reflex.Class

15import Reflex.Adjustable.Class

16−import Reflex.Patch.MapWithMove

16+import Data.Patch.MapWithMove

19-- | Build sortable content in such a way that re-sorting it can cause minimal

test/Adjustable.hsnew file+62

@@ -0,0 +1,62 @@

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE LambdaCase #-}

3+{-# LANGUAGE RankNTypes #-}

4+{-# LANGUAGE RecursiveDo #-}

6+module Main where

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/GC.hs+2−1

@@ -18,9 +18,10 @@ import Data.GADT.Compare

18import Data.IORef

19import Data.Semigroup

20import Data.These

21+import Data.Type.Equality ((:~:)(Refl))

22import Data.Functor.Misc

23import Data.Functor.Misc

23−import Reflex.Patch

24+import Data.Patch

25import qualified Reflex.Host.Class as Host

26import qualified Reflex.Host.Class as Host

26import qualified Reflex.Spider.Internal as S

27import qualified Reflex.Spider.Internal as S

test/Headless.hsnew file+10

@@ -0,0 +1,10 @@

1+module Main where

3+import Reflex

4+import Reflex.Host.Headless (runHeadlessApp)

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

26import Reflex

27−import Reflex.Patch.MapWithMove

27+import Data.Patch.MapWithMove

28import Test.Run

30newtype MyQuery = MyQuery SelectedCount

test/Reflex/Plan/Pure.hs+1

@@ -41,6 +41,7 @@ instance MonadHold (Pure Int) PurePlan where

41 holdIncremental initial = liftPlan . holdIncremental initial

42 buildDynamic getInitial = liftPlan . buildDynamic getInitial

43 headE = liftPlan . headE

44+ now = liftPlan now

45instance MonadSample (Pure Int) PurePlan where

46instance MonadSample (Pure Int) PurePlan where

46 sample = liftPlan . sample

47 sample = liftPlan . sample

test/Reflex/Test/CrossImpl.hs+13−8

@@ -21,11 +21,12 @@ import Reflex.Dynamic

21import Reflex.Host.Class

22import qualified Reflex.Pure as P

23import qualified Reflex.Spider.Internal as S

24+import qualified Reflex.Profiled as Prof

25import Control.Arrow (second, (&&&))

26import Control.Arrow (second, (&&&))

26import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

27import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

27import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

28import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

28−import Data.Dependent.Map (DSum (..))

29+import Data.Dependent.Sum (DSum (..))

29import Data.Foldable

30import Data.Foldable

30import Data.Map.Strict (Map)

31import Data.Map.Strict (Map)

31import qualified Data.Map.Strict as Map

32import qualified Data.Map.Strict as Map

@@ -35,8 +36,6 @@ import Data.Traversable

35import System.Exit

36import System.Exit

36import System.Mem

37import System.Mem

38−import System.IO.Unsafe

39−

40mapToPureBehavior :: Map Int a -> Behavior PureReflexDomain a

39mapToPureBehavior :: Map Int a -> Behavior PureReflexDomain a

41mapToPureBehavior m = P.Behavior $ \t -> case Map.lookupLE t m of

40mapToPureBehavior m = P.Behavior $ \t -> case Map.lookupLE t m of

42 Nothing -> error $ "mapToPureBehavior: no value for time " <> show t

41 Nothing -> error $ "mapToPureBehavior: no value for time " <> show t

@@ -73,11 +72,14 @@ instance MapMSignals (Event t a) (Event t' a) t t' where

73instance (MapMSignals a a' t t', MapMSignals b b' t t') => MapMSignals (a, b) (a', b') t t' where

72instance (MapMSignals a a' t t', MapMSignals b b' t t') => MapMSignals (a, b) (a', b') t t' where

74 mapMSignals fb fe (a, b) = liftM2 (,) (mapMSignals fb fe a) (mapMSignals fb fe b)

73 mapMSignals fb fe (a, b) = liftM2 (,) (mapMSignals fb fe a) (mapMSignals fb fe b)

75+testTimeline

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)

76+ :: (forall m t. TestCaseConstraint t m => (Behavior t a, Event t b) -> m (Behavior t c, Event t d))

77+ -> (Map Int a, Map Int b)

78+ -> (forall m t. (MonadReflexHost t m, MonadIO m, MonadRef m, Ref m ~ Ref IO, MonadSample t m) => m (Map Int c, Map Int d))

77−testSpider builder (bMap, eMap) = unsafePerformIO $ S.runSpiderHost $ do

79+testTimeline builder (bMap, eMap) = do

78 (re, reTrigger) <- newEventWithTriggerRef

80 (re, reTrigger) <- newEventWithTriggerRef

79 (rb, rbTrigger) <- newEventWithTriggerRef

81 (rb, rbTrigger) <- newEventWithTriggerRef

80− b <- runHostFrame $ hold (error "testSpider: No value for input behavior yet") rb

82+ b <- runHostFrame $ hold (error "testTimeline: No value for input behavior yet") rb

81 (b', e') <- runHostFrame $ builder (b, re)

83 (b', e') <- runHostFrame $ builder (b, re)

82 e'Handle <- subscribeEvent e' --TODO: This should be unnecessary

84 e'Handle <- subscribeEvent e' --TODO: This should be unnecessary

83 let times = relevantTestingTimes (bMap, eMap)

85 let times = relevantTestingTimes (bMap, eMap)

@@ -102,9 +104,11 @@ testAgreement :: (Eq c, Eq d, Show c, Show d) => (forall m t. TestCaseConstraint

102testAgreement builder inputs = do

104testAgreement builder inputs = do

103 let identityResult = testPure builder inputs

105 let identityResult = testPure builder inputs

104 tracePerf "---------" $ return ()

106 tracePerf "---------" $ return ()

105− let spiderResult = testSpider builder inputs

107+ spiderResult <- S.runSpiderHost $ testTimeline builder inputs

108+ tracePerf "---------" $ return ()

109+ profiledResult <- S.runSpiderHost $ Prof.runProfiledM $ testTimeline builder inputs

106 tracePerf "---------" $ return ()

110 tracePerf "---------" $ return ()

107− let resultsAgree = identityResult == spiderResult

111+ let resultsAgree = identityResult == spiderResult && identityResult == profiledResult

108 if resultsAgree

112 if resultsAgree

109 then do --putStrLn "Success:"

113 then do --putStrLn "Success:"

110 --print identityResult

114 --print identityResult

@@ -112,6 +116,7 @@ testAgreement builder inputs = do

112 else do putStrLn "Failure:"

116 else do putStrLn "Failure:"

113 putStrLn $ "Pure result: " <> show identityResult

117 putStrLn $ "Pure result: " <> show identityResult

114 putStrLn $ "Spider result: " <> show spiderResult

118 putStrLn $ "Spider result: " <> show spiderResult

119+ putStrLn $ "Profiled result: " <> show profiledResult

115 return resultsAgree

120 return resultsAgree

116

121

117type TestCaseConstraint t m = (Reflex t, MonadSample t m, MonadHold t m, MonadFix m, MonadFix (PushM t))

122type TestCaseConstraint t m = (Reflex t, MonadSample t m, MonadHold t m, MonadFix m, MonadFix (PushM t))

test/Reflex/Test/Micro.hs+8−2

@@ -322,8 +322,14 @@ testCases =

322 let e = never <$ switch b

323 return $ void e

324 lazyHold

325−

325+ , testE "now-1" $ do

326−

326+ e1 <- events1

327+ switchHoldPromptly never . pushAlways (\a -> fmap (a <$) now) $ e1

328+ , testE "now-2" $ do

329+ e1 <- events1

330+ let e = pushAlways (\a -> if a == "a" then now else return never) e1

331+ x <- accumDyn (<>) never e

332+ return . coincidence $ updated x

327 ] where

333 ] where

328

334

329 events1, events2, events3 :: TestPlan t m => m (Event t String)

335 events1, events2, events3 :: TestPlan t m => m (Event t String)

test/RequesterT.hs+63−2

@@ -1,20 +1,36 @@

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE BangPatterns #-}

3{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE GADTs #-}

5{-# LANGUAGE GADTs #-}

5−{-# LANGUAGE RankNTypes #-}

6+{-# LANGUAGE LambdaCase #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE RecursiveDo #-}

8{-# LANGUAGE RecursiveDo #-}

7{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE TemplateHaskell #-}

11+{-# LANGUAGE TypeApplications #-}

12+{-# LANGUAGE TypeFamilies #-}

8module Main where

13module Main where

10−import Control.Lens

15+import Control.Lens hiding (has)

11import Control.Monad

16import Control.Monad

12import Control.Monad.Fix

17import 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

13import qualified Data.Dependent.Map as DMap

22import qualified Data.Dependent.Map as DMap

14import Data.Dependent.Sum

23import Data.Dependent.Sum

15import Data.Functor.Misc

24import Data.Functor.Misc

25+import Data.List (words)

26+import Data.Map (Map)

16import qualified Data.Map as M

27import qualified Data.Map as M

28+#if !MIN_VERSION_these(4,11,0)

29+import Data.Semigroup ((<>))

30+#endif

31+import Data.Text (Text)

17import Data.These

32import Data.These

33+import Text.Read (readMaybe)

19#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))

35#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))

20import Data.These.Lens

36import Data.These.Lens

@@ -49,12 +65,19 @@ main = do

49 print os5

65 print os5

50 os6 <- runApp' (unwrapApp delayedPulse) [Just ()]

66 os6 <- runApp' (unwrapApp delayedPulse) [Just ()]

51 print os6

67 print os6

68+ os7 <- runApp' testMatchRequestsWithResponses [ Just $ TestRequest_Increment 1 ]

69+ print os7

70+ os8 <- runApp' testMatchRequestsWithResponses [ Just $ TestRequest_Reverse "yoyo" ]

71+ print os8

52 let ![[Just [1,2,3,4,5,6,7,8,9,10]]] = os1 -- The order is reversed here: see the documentation for 'runRequesterT'

72 let ![[Just [1,2,3,4,5,6,7,8,9,10]]] = os1 -- The order is reversed here: see the documentation for 'runRequesterT'

53 let ![[Just [9,7,5,3,1]],[Nothing,Nothing],[Just [10,8,6,4,2]],[Just [10,8,6,4,2],Nothing]] = os2

73 let ![[Just [9,7,5,3,1]],[Nothing,Nothing],[Just [10,8,6,4,2]],[Just [10,8,6,4,2],Nothing]] = os2

54 let ![[Nothing, Just [2]]] = os3

74 let ![[Nothing, Just [2]]] = os3

55 let ![[Nothing, Just [2]]] = os4

75 let ![[Nothing, Just [2]]] = os4

56 let ![[Nothing, Just [1, 2]]] = os5

76 let ![[Nothing, Just [1, 2]]] = os5

57 -- let ![[Nothing, Nothing]] = os6 -- TODO re-enable this test after issue #233 has been resolved

77 -- let ![[Nothing, Nothing]] = os6 -- TODO re-enable this test after issue #233 has been resolved

78+ let !(Just [(1,"2")]) = M.toList <$> head (head os7)

79+ let !(Just [(1,"oyoy")]) = M.toList <$> head (head os8)

80+

58 return ()

81 return ()

60unwrapRequest :: DSum tag RequestInt -> Int

83unwrapRequest :: DSum tag RequestInt -> Int

@@ -172,3 +195,41 @@ delayedPulse pulse = void $ flip runWithReplace (pure () <$ pulse) $ do

172 -- This has the effect of delaying pulse' from pulse

195 -- This has the effect of delaying pulse' from pulse

173 (_, pulse') <- runWithReplace (pure ()) $ pure (RequestInt 1) <$ pulse

196 (_, pulse') <- runWithReplace (pure ()) $ pure (RequestInt 1) <$ pulse

174 requestingIdentity pulse'

197 requestingIdentity pulse'

198+

199+data TestRequest a where

200+ TestRequest_Reverse :: String -> TestRequest String

201+ TestRequest_Increment :: Int -> TestRequest Int

202+

203+testMatchRequestsWithResponses

204+ :: forall m t req a

205+ . ( MonadFix m

206+ , MonadHold t m

207+ , Reflex t

208+ , PerformEvent t m

209+ , MonadIO (Performable m)

210+ , ForallF Show req

211+ , Has Read req

212+ )

213+ => Event t (req a) -> m (Event t (Map Int String))

214+testMatchRequestsWithResponses pulse = mdo

215+ (_, requests) <- runRequesterT (requesting pulse) responses

216+ let rawResponses = M.map (\v ->

217+ case words v of

218+ ["reverse", str] -> reverse str

219+ ["increment", i] -> show $ succ $ (read i :: Int)

220+ ) <$> rawRequestMap

221+ (rawRequestMap, responses) <- matchResponsesWithRequests reqEncoder requests (head . M.toList <$> rawResponses)

222+ pure rawResponses

223+ where

224+ reqEncoder :: forall a. req a -> (String, String -> Maybe a)

225+ reqEncoder r =

226+ ( whichever @Show @req @a $ show r

227+ , \x -> has @Read r $ readMaybe x

228+ )

229+

230+deriveArgDict ''TestRequest

231+

232+instance Show (TestRequest a) where

233+ show = \case

234+ TestRequest_Reverse str -> "reverse " <> str

235+ TestRequest_Increment i -> "increment " <> show i

test/hlint.hs+2−1

@@ -1,7 +1,7 @@

1module Main where

3import Control.Monad

4−import Language.Haskell.HLint3 (hlint)

4+import Language.Haskell.HLint (hlint)

5import System.Directory

6import System.Exit (exitFailure, exitSuccess)

7import System.FilePath

@@ -22,6 +22,7 @@ main = do

22 , "--ignore=Use unless"

23 , "--ignore=Reduce duplication"

24 , "--cpp-define=USE_TEMPLATE_HASKELL"

25+ , "--cpp-define=DEBUG"

25 , "--ignore=Use tuple-section"

26 , "--ignore=Use tuple-section"

26 ]

27 ]

27 recurseInto = and <$> sequence

28 recurseInto = and <$> sequence