6d12ec3...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−175

@@ -1,175 +0,0 @@

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

2−#

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

4−#

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

6−#

7−# version: 0.3.20190815

8−#

9−language: c

10−dist: xenial

11−git:

12− # whether to recursively clone submodules

13− submodules: false

14−cache:

15− directories:

16− - $HOME/.cabal/packages

17− - $HOME/.cabal/store

18−before_cache:

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

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

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

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

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

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

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

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

27−matrix:

28− include:

29− - compiler: ghcjs-8.4

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

31− - compiler: ghc-8.6.5

32− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-2.4"]}}

33− - compiler: ghc-8.4.4

34− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-2.4"]}}

35− - compiler: ghc-8.2.2

36− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-2.4"]}}

37− - compiler: ghc-8.0.2

38− addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-2.4"]}}

39−before_install:

40− - |

41− if echo $CC | grep -q ghcjs; then

42− GHCJS=true;

43− else

44− GHCJS=false;

45− fi

46− - |

47− if [ "$TRAVIS_OS_NAME" = "linux" ]; then

48− if $GHCJS ; then sudo add-apt-repository -y ppa:hvr/ghcjs ; fi;

49− if $GHCJS ; then curl -s https://deb.nodesource.com/gpgkey/nodesource.gpg.key | sudo apt-key add - ; fi;

50− if $GHCJS ; then sudo apt-add-repository 'https://deb.nodesource.com/node_8.x xenial main' ; fi;

51− if $GHCJS ; then sudo apt-get update ; fi;

52− sudo apt-get install $CC;

53− if $GHCJS ; then sudo apt-get install -y nodejs cabal-install-3.0 ; fi;

54− fi

55− - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//')

56− - WITHCOMPILER="-w $HC"

57− - if $GHCJS ; then HC=${HC}js ; fi

58− - if $GHCJS ; then WITHCOMPILER="--ghcjs ${WITHCOMPILER}js" ; fi

59− - if $GHCJS ; then sudo apt-get install -y ghc-8.4.4 ; fi

60− - if $GHCJS ; then PATH="/opt/ghc/8.4.4/bin:$PATH" ; fi

61− - HCPKG="$HC-pkg"

62− - unset CC

63− - CABAL=/opt/ghc/bin/cabal

64− - CABALHOME=$HOME/.cabal

65− - export PATH="$CABALHOME/bin:$PATH"

66− - TOP=$(pwd)

67− - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')"

68− - echo $HCNUMVER

69− - CABAL="$CABAL -vnormal+nowrap+markoutput"

70− - set -o pipefail

71− - |

72− echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk

73− echo 'BEGIN { state = "output"; }' >> .colorful.awk

74− echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk

75− echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk

76− echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk

77− echo ' if (state == "cabal") {' >> .colorful.awk

78− echo ' print blue($0)' >> .colorful.awk

79− echo ' } else {' >> .colorful.awk

80− echo ' print $0' >> .colorful.awk

81− echo ' }' >> .colorful.awk

82− echo '}' >> .colorful.awk

83− - cat .colorful.awk

84− - |

85− color_cabal_output () {

86− awk -f $TOP/.colorful.awk

87− }

88− - echo text | color_cabal_output

89−install:

90− - ${CABAL} --version

91− - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"

92− - node --version

93− - echo $GHCJS

94− - TEST=--enable-tests

95− - BENCH=--enable-benchmarks

96− - BENCH=--disable-benchmarks

97− - HEADHACKAGE=false

98− - rm -f $CABALHOME/config

99− - |

100− echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config

101− echo "remote-build-reporting: anonymous" >> $CABALHOME/config

102− echo "write-ghc-environment-files: always" >> $CABALHOME/config

103− echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config

104− echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config

105− echo "world-file: $CABALHOME/world" >> $CABALHOME/config

106− echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config

107− echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config

108− echo "installdir: $CABALHOME/bin" >> $CABALHOME/config

109− echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config

110− echo "store-dir: $CABALHOME/store" >> $CABALHOME/config

111− echo "install-dirs user" >> $CABALHOME/config

112− echo " prefix: $CABALHOME" >> $CABALHOME/config

113− echo "repository hackage.haskell.org" >> $CABALHOME/config

114− echo " url: http://hackage.haskell.org/" >> $CABALHOME/config

115− - cat $CABALHOME/config

116− - rm -fv cabal.project cabal.project.local cabal.project.freeze

117− - travis_retry ${CABAL} v2-update -v

118− - if $GHCJS ; then (cd /tmp && ${CABAL} v2-install -w ghc-8.4.4 happy) ; fi

119− # Generate cabal.project

120− - rm -rf cabal.project cabal.project.local cabal.project.freeze

121− - touch cabal.project

122− - |

123− echo "packages: ." >> cabal.project

124− - |

125− - cat cabal.project || true

126− - cat cabal.project.local || true

127− - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi

128− - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output

129− - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'"

130− - rm cabal.project.freeze

131−script:

132− - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)

133− # Packaging...

134− - ${CABAL} v2-sdist all | color_cabal_output

135− # Unpacking...

136− - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/

137− - cd ${DISTDIR} || false

138− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \;

139− - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \;

140− - PKGDIR_reflex="$(find . -maxdepth 1 -type d -regex '.*/reflex-[0-9.]*')"

141− # Generate cabal.project

142− - rm -rf cabal.project cabal.project.local cabal.project.freeze

143− - touch cabal.project

144− - |

145− echo "packages: ${PKGDIR_reflex}" >> cabal.project

146− - |

147− - cat cabal.project || true

148− - cat cabal.project.local || true

149− # Building...

150− # this builds all libraries and executables (without tests/benchmarks)

151− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output

152− # Building with tests and benchmarks...

153− # build & run tests, build benchmarks

154− - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output

155− # Testing...

156− - if ! $GHCJS ; then ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi

157− # cabal check...

158− - (cd ${PKGDIR_reflex} && ${CABAL} -vnormal check)

159− # haddock...

160− - if ! $GHCJS ; then ${CABAL} v2-haddock $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi

161− # Constraint sets

162− - rm -rf cabal.project.local

163− # Constraint set no-th

164− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='reflex -use-template-haskell' all | color_cabal_output

165− # Constraint set old-these

166− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='these <1' all | color_cabal_output

167− # Constraint set old-witherable

168− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='witherable <0.3.2' all | color_cabal_output

169− # Constraint set debug-propagation

170− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='reflex +debug-propagation' all | color_cabal_output

171− # Constraint set debug-cycles

172− - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='reflex +debug-cycles' all | color_cabal_output

173−

174−# REGENDATA ["reflex.cabal","--config","cabal.haskell-ci"]

175−# EOF

ChangeLog.md+106−4

@@ -1,9 +1,101 @@

1# Revision history for reflex

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

63+

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

65+

66+* The `Reflex.Patch.*` modules were moved to the `patch` library.

67+ They are `Data.Patch.*` there, but reexported under their old names for backwards compatability here.

68+

69+* Additional instances for `Query` classes for basic types.

70+

71+* Add cabal flags `debug-propagation` and `debug-event-cycles` to build in debugging

72+ code for performance and for cyclic dependencies between events

73+

74+## 0.6.3

75+

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

77+ They are replaced with `Data.WeakBag.traverse_` and `Data.FastWeakBag.traverse_`, respectively.

78+

79+* Fixes a bug in `Reflex.Patch.MapWithMove.patchThatSortsMapWith` that was producing invalid `PatchMapWithMove`.

80+

81+* Add missing `NotReady` instances:

82+ - `instance NotReady (SpiderTimeline x) (SpiderHost x)`

83+ - `instance HasSpiderTimeline x => NotReady (SpiderTimeline x) (PerformEventT (SpiderTimeline x) (SpiderHost x))`

84+

85+## 0.6.2.4

86+

87+* Update to monoidal-containers 0.6

88+

89+## 0.6.2.3

90+

91+* Add an upper-bound to witherable

92+

3## 0.6.2.2

93## 0.6.2.2

5* Support these >= 1. Add `split-these` flag to control whether to use new these/semialign combination or not.

95* Support these >= 1. Add `split-these` flag to control whether to use new these/semialign combination or not.

96+

6* Update version bounds to fix some CI failures

97* Update version bounds to fix some CI failures

98+

7* Add travis CI configuration

99* Add travis CI configuration

100

9## 0.6.2.1

101## 0.6.2.1

@@ -18,32 +110,42 @@

18 * Add incrementalCoercion/coerceIncremental to go with dynamicCoercion/coerceDynamic

110 * Add incrementalCoercion/coerceIncremental to go with dynamicCoercion/coerceDynamic

111

20* Generalize merging functions:

112* Generalize merging functions:

21− `merge` to `mergeG`,

113+ `merge` to `mergeG`,

22− `mergeIncremental` to `mergeIncrementalG`,

114+ `mergeIncremental` to `mergeIncrementalG`,

23− `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`.

115+ `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`.

116

25* Generalize distribute function:

117* Generalize distribute function:

26 `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`,

118 `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`,

119

28## 0.6.2.0

120## 0.6.2.0

121

30−* Fix `holdDyn` so that it is lazy in its event argument

122+* Fix `holdDyn` so that it is lazy in its event argument

31 These produce `DMap`s whose values needn't be `Identity`.

123 These produce `DMap`s whose values needn't be `Identity`.

124+

32* Stop using the now-deprecated `*Tag` classes (e.g., `ShowTag`).

125* Stop using the now-deprecated `*Tag` classes (e.g., `ShowTag`).

126+

33* Fix `holdDyn` so that it is lazy in its event argument.

127* Fix `holdDyn` so that it is lazy in its event argument.

128

35## 0.6.1.0

129## 0.6.1.0

130

37* Re-export all of `Data.Map.Monoidal`

131* Re-export all of `Data.Map.Monoidal`

132+

38* Fix `QueryT` and `RequesterT` tests

133* Fix `QueryT` and `RequesterT` tests

134

40## 0.6.0.0 -- 2019-03-20

135## 0.6.0.0 -- 2019-03-20

136

42* Deprecate `FunctorMaybe` in favor of `Data.Witherable.Filterable`. We still export `fmapMaybe`, `ffilter`, etc., but they all rely on `Filterable` now.

137* Deprecate `FunctorMaybe` in favor of `Data.Witherable.Filterable`. We still export `fmapMaybe`, `ffilter`, etc., but they all rely on `Filterable` now.

138+

43* Rename `MonadDynamicWriter` to `DynamicWriter` and add a deprecation for the old name.

139* Rename `MonadDynamicWriter` to `DynamicWriter` and add a deprecation for the old name.

140+

44* Remove many deprecated functions.

141* Remove many deprecated functions.

142+

45* Add a `Num` instance for `Dynamic`.

143* Add a `Num` instance for `Dynamic`.

144+

46* Add `matchRequestsWithResponses` to make it easier to use `Requester` with protocols that don't do this matching for you.

145* Add `matchRequestsWithResponses` to make it easier to use `Requester` with protocols that don't do this matching for you.

146+

47* Add `withRequesterT` to map functions over the request and response of a `RequesterT`.

147* Add `withRequesterT` to map functions over the request and response of a `RequesterT`.

148+

48* Suppress nil patches in `QueryT` as an optimization. The `Query` type must now have an `Eq` instance.

149* Suppress nil patches in `QueryT` as an optimization. The `Query` type must now have an `Eq` instance.

150+

49* Add `throttleBatchWithLag` to `Reflex.Time`. See that module for details.

151* Add `throttleBatchWithLag` to `Reflex.Time`. See that module for details.

Quickref.md+15−11

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

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)

@@ -198,7 +199,7 @@ For Events, the returned Event fires whenever the latest Event supplied by the w

198The functions mentioned above are used to create a static FRP network.

199The functions mentioned above are used to create a static FRP network.

199There are additional typeclasses that can be used to modify the FRP network, to have it interact with IO action, or to introspect the building of the network.

200There are additional typeclasses that can be used to modify the FRP network, to have it interact with IO action, or to introspect the building of the network.

200

201

201−Th typeclasses and their associated annotations include:

202+The typeclasses and their associated annotations include:

202

203

203- `PostBuild`

204- `PostBuild`

204 Fire an Event when an FRP network has been set up.

205 Fire an Event when an FRP network has been set up.

@@ -206,7 +207,7 @@ Th typeclasses and their associated annotations include:

206 [B] -- Function runs in any monad supporting PostBuild

207 [B] -- Function runs in any monad supporting PostBuild

207 ```

208 ```

208

209

209−- `Adjustable`

210+- `Adjustable`

210 Use Events to add or remove pieces of an FRP network.

211 Use Events to add or remove pieces of an FRP network.

211 ```haskell

212 ```haskell

212 [A] -- Function runs in any monad supporting Adjustable

213 [A] -- Function runs in any monad supporting Adjustable

@@ -271,7 +272,7 @@ Th typeclasses and their associated annotations include:

271```haskell

272```haskell

272-- Run side-effecting actions in Event when it occurs; returned Event contains

273-- Run side-effecting actions in Event when it occurs; returned Event contains

273-- results. Side effects run in the (Performable m) monad which is associated with

274-- results. Side effects run in the (Performable m) monad which is associated with

274−-- the (PerformEvent t m) typeclass constraint.

275+-- the (PerformEvent t m) typeclass constraint.

275-- This allows for working with IO when a ((MonadIO (Performable m)) constraint is available.

276-- This allows for working with IO when a ((MonadIO (Performable m)) constraint is available.

276[P] performEvent :: Event (Performable m a ) -> m (Event a)

277[P] performEvent :: Event (Performable m a ) -> m (Event a)

277

278

@@ -295,17 +296,20 @@ Th typeclasses and their associated annotations include:

295## Networks

296## Networks

296

297

297```haskell

298```haskell

298−-- Functions from Reflex.Network used to deal with Dynamics/Events carrying (m a)

299+-- Functions from Reflex.Adjustable / Reflex.Network used to deal with Dynamics/Events carrying (m a)

299

300

301+[A] runWithReplace :: m a -> Event t (m b) -> m (a, Event t b)

302+

300−-- Given a Dynamic of network-creating actions, create a network that is recreated whenever the Dynamic updates.

303+-- Given a Dynamic of network-creating actions, create a network that is recreated whenever the Dynamic updates.

301−-- The returned Event of network results occurs when the Dynamic does. Note: Often, the type a is an Event,

304+-- The returned Event of network results occurs when the Dynamic does. Note: Often, the type a is an Event,

302-- in which case the return value is an Event-of-Events that would typically be flattened (via switchHold).

305-- in which case the return value is an Event-of-Events that would typically be flattened (via switchHold).

303−[P,A] networkView :: Dynamic (m a) -> m (Event a)

306+[P,A] networkView :: Dynamic (m a) -> m (Event a)

304

307

305−-- Given an initial network and an Event of network-creating actions, create a network that is recreated whenever the

308+-- Given an initial network and an Event of network-creating actions, create a network that is recreated whenever the

306−-- Event fires. The returned Dynamic of network results occurs when the Event does. Note: Often, the type a is an

309+-- Event fires. The returned Dynamic of network results occurs when the Event does. Note: Often, the type a is an

307-- Event, in which case the return value is a Dynamic-of-Events that would typically be flattened.

310-- Event, in which case the return value is a Dynamic-of-Events that would typically be flattened.

308−[H,A] networkHold :: m a -> Event (m a) -> m (Dynamic a)

311+[H,A] networkHold :: m a -> Event (m a) -> m (Dynamic a)

309

312

310-- Render a placeholder network to be shown while another network is not yet done building

313-- Render a placeholder network to be shown while another network is not yet done building

311−[P,A] untilReady :: m a -> m b -> m (a, Event b)

314+[P,A] untilReady :: m a -> m b -> m (a, Event b)

315+```

README.md+15−17

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

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

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

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.

cabal.haskell-ci+1

@@ -10,6 +10,7 @@ constraint-set no-th

10 constraints: reflex -use-template-haskell

12constraint-set old-these

13+ ghc: <8.8

13 constraints: these <1

14 constraints: these <1

15constraint-set old-witherable

16constraint-set old-witherable

default.nixdeleted−43

@@ -1,43 +0,0 @@

1−{ mkDerivation, ghc, base, bifunctors, containers, deepseq

2−, dependent-map, dependent-sum, exception-transformers

3−, haskell-src-exts, haskell-src-meta, hlint, lens, MemoTrie

4−, monad-control, mtl, primitive, random, ref-tf

5−, semigroupoids , semigroups, split, stdenv, stm, syb

6−, template-haskell , these, time, transformers

7−, transformers-compat, unbounded-delays, prim-uniq

8−, data-default, filepath, directory, filemanip, ghcjs-base

9−, monoidal-containers, witherable, profunctors

10−, semialign ? null, splitThese ? (semialign != null)

11−, useTemplateHaskell ? true

12−}:

13−mkDerivation {

14− pname = "reflex";

15− version = "0.6.2.2";

16− src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.;

17− libraryHaskellDepends = [

18− base bifunctors containers dependent-map dependent-sum

19− exception-transformers lens

20− MemoTrie monad-control mtl primitive ref-tf semigroupoids

21− semigroups stm syb template-haskell these transformers

22− transformers-compat prim-uniq

23− base bifunctors containers deepseq dependent-map dependent-sum

24− mtl ref-tf split transformers data-default

25− random time unbounded-delays monoidal-containers witherable

26− profunctors

27− ] ++ (if ghc.isGhcjs or false then [

28− ghcjs-base

29− ] else []) ++ (if !useTemplateHaskell then [] else [

30− haskell-src-exts haskell-src-meta

31− ]) ++ (if splitThese then [

32− semialign

33− ] else []);

34− testHaskellDepends = if ghc.isGhcjs or false then [] else [

35− hlint filepath directory filemanip

36− ];

37− configureFlags =

38− stdenv.lib.optional (!useTemplateHaskell) [ "-f-use-template-haskell" ] ++

39− stdenv.lib.optional (!splitThese) [ "-f-split-these" ];

40− homepage = "https://github.com/reflex-frp/reflex";

41− description = "Higher-order Functional Reactive Programming";

42− license = stdenv.lib.licenses.bsd3;

43−}

dep/reflex-platform/default.nixnew file+7

@@ -0,0 +1,7 @@

1+# DO NOT HAND-EDIT THIS FILE

2+import ((import <nixpkgs> {}).fetchFromGitHub (

3+ let json = builtins.fromJSON (builtins.readFile ./github.json);

4+ in { inherit (json) owner repo rev sha256;

5+ private = json.private or false;

6+ }

7+))

dep/reflex-platform/github.jsonnew file+7

@@ -0,0 +1,7 @@

1+{

2+ "owner": "reflex-frp",

3+ "repo": "reflex-platform",

4+ "branch": "develop",

5+ "rev": "f628398d076243a0851b27e625b37f65dff9b89b",

6+ "sha256": "0sl0hf1glgyb1vmf2mhw4r9ipmcqk1y19d3wsic7dix2jwywzrh9"

7+}

hydra.jsondeleted−29

@@ -1,29 +0,0 @@

1−{

2− "enabled": 1,

3− "hidden": true,

4− "description": "Jobsets",

5− "nixexprinput": "src",

6− "nixexprpath": "jobsets.nix",

7− "checkinterval": 300,

8− "schedulingshares": 100,

9− "enableemail": false,

10− "emailoverride": "",

11− "keepnr": 10,

12− "inputs": {

13− "src": {

14− "type": "git",

15− "value": "https://github.com/reflex-frp/reflex.git develop",

16− "emailresponsible": false

17− },

18− "nixpkgs": {

19− "type": "git",

20− "value": "https://github.com/NixOS/nixpkgs-channels nixos-unstable",

21− "emailresponsible": false

22− },

23− "prs": {

24− "type": "githubpulls",

25− "value": "reflex-frp reflex",

26− "emailresponsible": false

27− }

28− }

29−}

jobsets.nixdeleted−70

@@ -1,70 +0,0 @@

1−{ prs }:

2−

3−let

4− pkgs = (import ./reflex-platform.nix {}).nixpkgs;

5− mkFetchGithub = value: {

6− inherit value;

7− type = "git";

8− emailresponsible = false;

9− };

10−in

11−with pkgs.lib;

12−let

13− defaults = jobs: {

14− inherit (jobs) description;

15− enabled = 1;

16− hidden = false;

17− keepnr = 10;

18− schedulingshares = 100;

19− checkinterval = 120;

20− enableemail = false;

21− emailoverride = "";

22− nixexprinput = "reflex";

23− nixexprpath = "release.nix";

24− inputs = jobs.inputs // {

25− nixpkgs = {

26− type = "git";

27− value = "https://github.com/NixOS/nixpkgs-channels nixos-unstable";

28− emailresponsible = false;

29− };

30− config = {

31− type = "nix";

32− value = "{ android_sdk.accept_license = true; }";

33− emailresponsible = false;

34− };

35− };

36− };

37− branchJobset = branch: defaults {

38− description = "reflex-${branch}";

39− inputs = {

40− reflex = {

41− value = "https://github.com/reflex-frp/reflex ${branch}";

42− type = "git";

43− emailresponsible = false;

44− };

45− };

46− };

47− makePr = num: info: {

48− name = "reflex-pr-${num}";

49− value = defaults {

50− description = "#${num}: ${info.title}";

51− inputs = {

52− reflex = {

53− #NOTE: This should really use "pull/${num}/merge"; however, GitHub's

54− #status checks only operate on PR heads. This creates a race

55− #condition, which can currently only be solved by requiring PRs to be

56− #up to date before they're merged. See

57− #https://github.com/isaacs/github/issues/1002

58− value = "https://github.com/reflex-frp/reflex pull/${num}/head";

59− type = "git";

60− emailresponsible = false;

61− };

62− };

63− };

64− };

65− processedPrs = mapAttrs' makePr (builtins.fromJSON (builtins.readFile prs));

66− jobsetsAttrs = processedPrs //

67− genAttrs ["develop"] branchJobset;

68−in {

69− jobsets = pkgs.writeText "spec.json" (builtins.toJSON jobsetsAttrs);

70−}

reflex-platform.nixdeleted−8

@@ -1,8 +0,0 @@

1−let

2− reflex-platform-src = (import <nixpkgs> {}).fetchFromGitHub {

3− owner = "reflex-frp";

4− repo = "reflex-platform";

5− rev = "384cd850f3adf1d404bced2424b5f6efb0f415f2";

6− sha256 = "1ws77prqx8khmp8j6br1ij4k2v4dlgv170r9fmg0p1jivfbn8y9d";

7− };

8−in import reflex-platform-src

reflex.cabal+98−40

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

1Name: reflex

2−Version: 0.6.2.2

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,

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,56 +61,57 @@ 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: False

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.13,

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− profunctors >= 5.0 && < 5.5,

73 lens >= 4.7 && < 5,

83 lens >= 4.7 && < 5,

84+ mmorph >= 1.0 && < 1.2,

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

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

75 mtl >= 2.1 && < 2.3,

86 mtl >= 2.1 && < 2.3,

87+ patch >= 0.0.1 && < 0.1,

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

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

77 primitive >= 0.5 && < 0.8,

89 primitive >= 0.5 && < 0.8,

78− profunctors,

90+ profunctors >= 5.3 && < 5.7,

79 random == 1.1.*,

91 random == 1.1.*,

80 ref-tf == 0.4.*,

92 ref-tf == 0.4.*,

81 reflection == 2.1.*,

93 reflection == 2.1.*,

82 semigroupoids >= 4.0 && < 6,

94 semigroupoids >= 4.0 && < 6,

83 stm >= 2.4 && < 2.6,

95 stm >= 2.4 && < 2.6,

84 syb >= 0.5 && < 0.8,

96 syb >= 0.5 && < 0.8,

85− time >= 1.4 && < 1.9,

97+ time >= 1.4 && < 1.10,

86 transformers >= 0.5.6.0 && < 0.6,

98 transformers >= 0.5.6.0 && < 0.6,

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

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

88− witherable >= 0.2 && < 0.4

100+ witherable >= 0.3 && < 0.5

101

90 if flag(split-these)

102 if flag(split-these)

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

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

92− semialign >=1 && <1.1,

104+ semialign >=1 && <1.2,

93− monoidal-containers >= 0.5.0.1 && < 0.6

105+ monoidal-containers >= 0.6 && < 0.7

94 else

106 else

95 build-depends: these >= 0.4 && <0.9,

107 build-depends: these >= 0.4 && <0.9,

96− monoidal-containers == 0.5.0.0

108+ monoidal-containers == 0.4.0.0

109

98 exposed-modules:

110 exposed-modules:

99 Control.Monad.ReaderIO

111 Control.Monad.ReaderIO

100 Data.AppendMap,

112 Data.AppendMap,

101 Data.FastMutableIntMap,

113 Data.FastMutableIntMap,

102 Data.FastWeakBag,

114 Data.FastWeakBag,

103− Data.Functor.Misc,

104 Data.Map.Misc,

115 Data.Map.Misc,

105 Data.WeakBag,

116 Data.WeakBag,

106 Reflex,

117 Reflex,

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

120 Reflex.FastWeak,

131 Reflex.FastWeak,

121 Reflex.FunctorMaybe,

132 Reflex.FunctorMaybe,

122 Reflex.Host.Class,

133 Reflex.Host.Class,

134+ Reflex.Host.Headless,

123 Reflex.Network,

135 Reflex.Network,

124 Reflex.NotReady.Class,

136 Reflex.NotReady.Class,

125− Reflex.Patch,

126− Reflex.Patch.Class,

127− Reflex.Patch.DMap,

128− Reflex.Patch.DMapWithMove,

129− Reflex.Patch.IntMap,

130− Reflex.Patch.Map,

131− Reflex.Patch.MapWithMove,

132 Reflex.PerformEvent.Base,

137 Reflex.PerformEvent.Base,

133 Reflex.PerformEvent.Class,

138 Reflex.PerformEvent.Class,

134 Reflex.PostBuild.Base,

139 Reflex.PostBuild.Base,

@@ -147,11 +152,22 @@ library

147 Reflex.Widget.Basic,

152 Reflex.Widget.Basic,

148 Reflex.Workflow

153 Reflex.Workflow

149

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+

150 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

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.22,

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

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

@@ -277,6 +300,7 @@ test-suite DebugCycles

277 , deepseq

300 , deepseq

278 , dependent-map

301 , dependent-map

279 , dependent-sum

302 , dependent-sum

303+ , hspec

280 , lens

304 , lens

281 , mtl

305 , mtl

282 , these

306 , these

@@ -291,24 +315,28 @@ test-suite DebugCycles

291 build-depends: these-lens, semialign

315 build-depends: these-lens, semialign

292

316

293 other-modules:

317 other-modules:

294− Test.Run

318+ Test.Run

295

319

296

320

297test-suite RequesterT

321test-suite RequesterT

322+ default-language: Haskell2010

298 type: exitcode-stdio-1.0

323 type: exitcode-stdio-1.0

299 main-is: RequesterT.hs

324 main-is: RequesterT.hs

300 hs-source-dirs: test

325 hs-source-dirs: test

301 build-depends: base

326 build-depends: base

327+ , constraints

328+ , constraints-extras

302 , containers

329 , containers

303 , deepseq

330 , deepseq

304− , dependent-sum

305 , dependent-map

331 , dependent-map

332+ , dependent-sum

306 , lens

333 , lens

307 , mtl

334 , mtl

335+ , ref-tf

336+ , reflex

337+ , text

308 , these

338 , these

309 , transformers

339 , transformers

310− , reflex

311− , ref-tf

312

340

313 if flag(split-these)

341 if flag(split-these)

314 build-depends: these-lens

342 build-depends: these-lens

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

318 Reflex.Plan.Pure

346 Reflex.Plan.Pure

319 Test.Run

347 Test.Run

320

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+

321test-suite QueryT

372test-suite QueryT

373+ default-language: Haskell2010

322 type: exitcode-stdio-1.0

374 type: exitcode-stdio-1.0

323 main-is: QueryT.hs

375 main-is: QueryT.hs

324 hs-source-dirs: test

376 hs-source-dirs: test

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

330 , lens

382 , lens

331 , monoidal-containers

383 , monoidal-containers

332 , mtl

384 , mtl

385+ , patch

333 , ref-tf

386 , ref-tf

334 , reflex

387 , reflex

335 , these

388 , these

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

345 Reflex.Plan.Pure

398 Reflex.Plan.Pure

346

399

347test-suite GC-Semantics

400test-suite GC-Semantics

401+ default-language: Haskell2010

348 type: exitcode-stdio-1.0

402 type: exitcode-stdio-1.0

349 main-is: GC.hs

403 main-is: GC.hs

350 hs-source-dirs: test

404 hs-source-dirs: test

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

354 , dependent-map

408 , dependent-map

355 , deepseq

409 , deepseq

356 , mtl

410 , mtl

411+ , patch

357 , these

412 , these

358 , transformers

413 , transformers

359 , reflex

414 , reflex

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

369 Test.Run

424 Test.Run

370

425

371test-suite rootCleanup

426test-suite rootCleanup

427+ default-language: Haskell2010

372 type: exitcode-stdio-1.0

428 type: exitcode-stdio-1.0

373 main-is: rootCleanup.hs

429 main-is: rootCleanup.hs

374 hs-source-dirs: test

430 hs-source-dirs: test

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

386 Test.Run

442 Test.Run

387

443

388benchmark spider-bench

444benchmark spider-bench

445+ default-language: Haskell2010

389 type: exitcode-stdio-1.0

446 type: exitcode-stdio-1.0

390 hs-source-dirs: bench test

447 hs-source-dirs: bench test

391 main-is: Main.hs

448 main-is: Main.hs

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

410 Reflex.Bench.Focused

467 Reflex.Bench.Focused

411

468

412benchmark saulzar-bench

469benchmark saulzar-bench

470+ default-language: Haskell2010

413 type: exitcode-stdio-1.0

471 type: exitcode-stdio-1.0

414 hs-source-dirs: bench test

472 hs-source-dirs: bench test

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

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

release.nix+56−7

@@ -1,9 +1,58 @@

1−{ rp ? import ./reflex-platform.nix {}

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

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

2}:

3}:

3let

5let

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

4− inherit (rp.nixpkgs) lib;

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

5− compilers = ["ghc8_4" "ghc8_0" "ghcjs8_4" "ghcjs8_0"];

6−in lib.attrValues (lib.genAttrs compilers (ghc: {

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

7− reflex-useTemplateHaskell = rp.${ghc}.callPackage ./. { useTemplateHaskell = true; splitThese = false; };

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

8− reflex = rp.${ghc}.callPackage ./. { useTemplateHaskell = false; splitThese = false; };

11+ compilers = [

9−}))

12+ "ghc"

13+ "ghcjs"

14+ ] ++ lib.optionals (reflex-platform.androidSupport) [

15+ "ghcAndroidAarch64"

16+ "ghcAndroidAarch32"

17+ ] ++ lib.optionals (reflex-platform.iosSupport) [

18+ "ghcIosAarch64"

19+ ];

20+ variations = map (v: "reflex" + v) [

21+ "-dontUseTemplateHaskell"

22+ ""

23+ ];

24+ compilerPkgs = lib.genAttrs compilers (ghc: let

25+ variationPkgs = lib.genAttrs variations (variation: let

26+ reflex-platform = reflex-platform-fun {

27+ inherit system;

28+ __useTemplateHaskell = variation == "reflex"; # TODO hack

29+ haskellOverlays = [

30+ # Use this package's source for reflex

31+ (self: super: {

32+ _dep = super._dep // {

33+ reflex = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [

34+ "release.nix"

35+ ".git"

36+ "dist"

37+ "cabal.haskell-ci"

38+ "cabal.project"

39+ ".travis.yml"

40+ ])) ./.;

41+ };

42+ })

43+ ];

44+ };

45+ in reflex-platform.${ghc}.reflex);

46+ in variationPkgs // {

47+ cache = reflex-platform.pinBuildInputs "reflex-${system}-${ghc}"

48+ (builtins.attrValues variationPkgs);

49+ });

50+ in compilerPkgs // {

51+ cache = reflex-platform.pinBuildInputs "reflex-${system}"

52+ (map (a: a.cache) (builtins.attrValues compilerPkgs));

53+ });

54+

55+ metaCache = native-reflex-platform.pinBuildInputs "reflex-everywhere"

56+ (map (a: a.cache) (builtins.attrValues perPlatform));

57+

58+in perPlatform // { inherit metaCache; }

src/Control/Monad/ReaderIO.hs+1−1

@@ -37,7 +37,7 @@ instance Applicative (ReaderIO e) where

37#if MIN_VERSION_base(4,10,0)

38 liftA2 = liftM2

39 {-# INLINE liftA2 #-}

40−#endif

40+#endif

41 (*>) = (>>)

42 {-# INLINE (*>) #-}

src/Data/AppendMap.hs+5−3

@@ -20,7 +20,7 @@ module Data.AppendMap

20 , module Data.Map.Monoidal

21 ) where

23−import Prelude hiding (map, null)

23+import Prelude hiding (null)

25import Data.Coerce

26import Data.Default

@@ -32,6 +32,8 @@ import qualified Data.Map as Map (showTree, showTreeWith)

32#endif

33import qualified Data.Witherable as W

34import Data.Map.Monoidal

35+import qualified Data.Map.Monoidal as MonoidalMap

36+

36{-# DEPRECATED AppendMap "Use 'MonoidalMap' instead" #-}

38{-# DEPRECATED AppendMap "Use 'MonoidalMap' instead" #-}

37-- | AppendMap is a synonym for 'Data.Map.Monoidal.MonoidalMap'

39-- | AppendMap is a synonym for 'Data.Map.Monoidal.MonoidalMap'

@@ -48,7 +50,7 @@ pattern AppendMap m = MonoidalMap m

49#if !MIN_VERSION_witherable(0,3,2)

51#if !MIN_VERSION_witherable(0,3,2)

50instance W.Filterable (MonoidalMap k) where

52instance W.Filterable (MonoidalMap k) where

51− mapMaybe = mapMaybe

53+ mapMaybe = MonoidalMap.mapMaybe

52#endif

54#endif

54-- | Deletes a key, returning 'Nothing' if the result is empty.

56-- | Deletes a key, returning 'Nothing' if the result is empty.

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

69 then Nothing

71 then Nothing

70 else Just bs

72 else Just bs

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

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

73-- | Displays a 'MonoidalMap' as a tree. See 'Data.Map.Lazy.showTree' for details.

75-- | Displays a 'MonoidalMap' as a tree. See 'Data.Map.Lazy.showTree' for details.

74showTree :: forall k a. (Show k, Show a) => MonoidalMap k a -> String

76showTree :: forall k a. (Show k, Show a) => MonoidalMap k a -> String

75showTree = coerce (Map.showTree :: Map k a -> String)

77showTree = coerce (Map.showTree :: Map k a -> String)

src/Data/FastMutableIntMap.hs+3−3

@@ -35,8 +35,8 @@ import Data.Foldable (traverse_)

35import Data.IntMap.Strict (IntMap)

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/FastWeakBag.hs+9−4

@@ -18,6 +18,7 @@ module Data.FastWeakBag

18 , isEmpty

19 , insert

20 , traverse

21+ , traverse_

21 , remove

22 , remove

22 -- * Internal functions

23 -- * Internal functions

23 -- These will not always be available.

24 -- These will not always be available.

@@ -116,14 +117,14 @@ foreign import javascript unsafe "(function(){ for(var i = 0; i < $1.tickets.len

116isEmpty bag = {-# SCC "isEmpty" #-} IntMap.null <$> readIORef (_weakBag_children bag)

117isEmpty bag = {-# SCC "isEmpty" #-} IntMap.null <$> readIORef (_weakBag_children bag)

117#endif

118#endif

118

119

119−{-# INLINE traverse #-}

120+{-# INLINE traverse_ #-}

120-- | Visit every node in the given list. If new nodes are appended during the

121-- | Visit every node in the given list. If new nodes are appended during the

121-- traversal, they will not be visited. Every live node that was in the list

122-- traversal, they will not be visited. Every live node that was in the list

122-- when the traversal began will be visited exactly once; however, no guarantee

123-- when the traversal began will be visited exactly once; however, no guarantee

123-- is made about the order of the traversal.

124-- is made about the order of the traversal.

124−traverse :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m ()

125+traverse_ :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m ()

125#ifdef GHCJS_FAST_WEAK

126#ifdef GHCJS_FAST_WEAK

126−traverse wb f = do

127+traverse_ wb f = do

127 let go cursor = when (not $ js_isNull cursor) $ do

128 let go cursor = when (not $ js_isNull cursor) $ do

128 val <- liftIO $ js_getTicketValue cursor

129 val <- liftIO $ js_getTicketValue cursor

129 f $ unsafeFromRawJSVal val

130 f $ unsafeFromRawJSVal val

@@ -134,13 +135,17 @@ foreign import javascript unsafe "$r = $1.val;" js_getTicketValue :: JSVal -> IO

134--TODO: Fix the race condition where if a cursor is deleted (presumably using 'remove', below) while we're holding it, it can't find its way back to the correct bag

135--TODO: Fix the race condition where if a cursor is deleted (presumably using 'remove', below) while we're holding it, it can't find its way back to the correct bag

135foreign import javascript unsafe "(function(){ for(var i = $1.pos - 1; i >= 0; i--) { if($1.bag.tickets[i] !== null) { return $1.bag.tickets[i]; } }; return null; })()" js_getNext :: FastWeakBagTicket a -> IO JSVal --TODO: Clean up as we go along so this isn't O(n) every time -- Result can be null or a FastWeakBagTicket a

136foreign import javascript unsafe "(function(){ for(var i = $1.pos - 1; i >= 0; i--) { if($1.bag.tickets[i] !== null) { return $1.bag.tickets[i]; } }; return null; })()" js_getNext :: FastWeakBagTicket a -> IO JSVal --TODO: Clean up as we go along so this isn't O(n) every time -- Result can be null or a FastWeakBagTicket a

136#else

137#else

137−traverse (FastWeakBag _ children) f = {-# SCC "traverse" #-} do

138+traverse_ (FastWeakBag _ children) f = {-# SCC "traverse_" #-} do

138 cs <- liftIO $ readIORef children

139 cs <- liftIO $ readIORef children

139 forM_ cs $ \c -> do

140 forM_ cs $ \c -> do

140 ma <- liftIO $ deRefWeak c

141 ma <- liftIO $ deRefWeak c

141 mapM_ f ma

142 mapM_ f ma

142#endif

143#endif

143

144

145+{-# DEPRECATED traverse "Use 'traverse_' instead" #-}

146+traverse :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m ()

147+traverse = traverse_

148+

144-- | Remove an item from the 'FastWeakBag'; does nothing if invoked multiple times

149-- | Remove an item from the 'FastWeakBag'; does nothing if invoked multiple times

145-- on the same 'FastWeakBagTicket'.

150-- on the same 'FastWeakBagTicket'.

146{-# INLINE remove #-}

151{-# INLINE remove #-}

src/Data/Functor/Misc.hsdeleted−234

@@ -1,234 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveDataTypeable #-}

3−{-# LANGUAGE DeriveFunctor #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE GADTs #-}

7−{-# LANGUAGE LambdaCase #-}

8−{-# LANGUAGE MultiParamTypeClasses #-}

9−{-# LANGUAGE PatternSynonyms #-}

10−{-# LANGUAGE PolyKinds #-}

11−{-# LANGUAGE RankNTypes #-}

12−{-# LANGUAGE ScopedTypeVariables #-}

13−{-# LANGUAGE StandaloneDeriving #-}

14−#ifdef USE_REFLEX_OPTIMIZER

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

16−#endif

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

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

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

20−module Data.Functor.Misc

21− ( -- * Const2

22− Const2 (..)

23− , unConst2

24− , dmapToMap

25− , dmapToIntMap

26− , dmapToMapWith

27− , mapToDMap

28− , weakenDMapWith

29− -- * WrapArg

30− , WrapArg (..)

31− -- * Convenience functions for DMap

32− , mapWithFunctorToDMap

33− , intMapWithFunctorToDMap

34− , mapKeyValuePairsMonotonic

35− , combineDMapsWithKey

36− , EitherTag (..)

37− , dmapToThese

38− , eitherToDSum

39− , dsumToEither

40− , ComposeMaybe (..)

41− ) where

42−

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

44−import Control.Monad.Identity

45−import Data.Dependent.Map (DMap)

46−import qualified Data.Dependent.Map as DMap

47−import Data.Dependent.Sum

48−import Data.GADT.Compare

49−import Data.GADT.Show

50−import Data.IntMap (IntMap)

51−import qualified Data.IntMap as IntMap

52−import Data.Map (Map)

53−import qualified Data.Map as Map

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

55−import Data.These

56−import Data.Typeable hiding (Refl)

57−

58−--------------------------------------------------------------------------------

59−-- Const2

60−--------------------------------------------------------------------------------

61−

62−-- | 'Const2' stores a value of a given type 'k' and ensures that a particular

63−-- type 'v' is always given for the last type parameter

64−data Const2 :: * -> x -> x -> * where

65− Const2 :: k -> Const2 k v v

66− deriving (Typeable)

67−

68−-- | Extract the value from a Const2

69−unConst2 :: Const2 k v v' -> k

70−unConst2 (Const2 k) = k

71−

72−deriving instance Eq k => Eq (Const2 k v v')

73−deriving instance Ord k => Ord (Const2 k v v')

74−deriving instance Show k => Show (Const2 k v v')

75−deriving instance Read k => Read (Const2 k v v)

76−

77−instance Show k => GShow (Const2 k v) where

78− gshowsPrec n x@(Const2 _) = showsPrec n x

79−

80−instance Eq k => GEq (Const2 k v) where

81− geq (Const2 a) (Const2 b) =

82− if a == b

83− then Just Refl

84− else Nothing

85−

86−instance Ord k => GCompare (Const2 k v) where

87− gcompare (Const2 a) (Const2 b) = case compare a b of

88− LT -> GLT

89− EQ -> GEQ

90− GT -> GGT

91−

92−-- | Convert a 'DMap' to a regular 'Map'

93−dmapToMap :: DMap (Const2 k v) Identity -> Map k v

94−dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList

95−

96−-- | Convert a 'DMap' to an 'IntMap'

97−dmapToIntMap :: DMap (Const2 IntMap.Key v) Identity -> IntMap v

98−dmapToIntMap = IntMap.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList

99−

100−-- | Convert a 'DMap' to a regular 'Map', applying the given function to remove

101−-- the wrapping 'Functor'

102−dmapToMapWith :: (f v -> v') -> DMap (Const2 k v) f -> Map k v'

103−dmapToMapWith f = Map.fromDistinctAscList . map (\(Const2 k :=> v) -> (k, f v)) . DMap.toAscList

104−

105−-- | Convert a regular 'Map' to a 'DMap'

106−mapToDMap :: Map k v -> DMap (Const2 k v) Identity

107−mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> Identity v) . Map.toAscList

108−

109−-- | Convert a regular 'Map', where the values are already wrapped in a functor,

110−-- to a 'DMap'

111−mapWithFunctorToDMap :: Map k (f v) -> DMap (Const2 k v) f

112−mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . Map.toAscList

113−

114−-- | Convert a regular 'IntMap', where the values are already wrapped in a

115−-- functor, to a 'DMap'

116−intMapWithFunctorToDMap :: IntMap (f v) -> DMap (Const2 IntMap.Key v) f

117−intMapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . IntMap.toAscList

118−

119−-- | Convert a 'DMap' to a regular 'Map' by forgetting the types associated with

120−-- the keys, using a function to remove the wrapping 'Functor'

121−weakenDMapWith :: (forall a. v a -> v') -> DMap k v -> Map (Some k) v'

122−weakenDMapWith f = Map.fromDistinctAscList . map (\(k :=> v) -> (Some k, f v)) . DMap.toAscList

123−

124−--------------------------------------------------------------------------------

125−-- WrapArg

126−--------------------------------------------------------------------------------

127−

128−-- | 'WrapArg' can be used to tag a value in one functor with a type

129−-- representing another functor. This was primarily used with dependent-map <

130−-- 0.2, in which the value type was not wrapped in a separate functor.

131−data WrapArg :: (k -> *) -> (k -> *) -> * -> * where

132− WrapArg :: f a -> WrapArg g f (g a)

133−

134−deriving instance Eq (f a) => Eq (WrapArg g f (g' a))

135−deriving instance Ord (f a) => Ord (WrapArg g f (g' a))

136−deriving instance Show (f a) => Show (WrapArg g f (g' a))

137−deriving instance Read (f a) => Read (WrapArg g f (g a))

138−

139−instance GEq f => GEq (WrapArg g f) where

140− geq (WrapArg a) (WrapArg b) = (\Refl -> Refl) <$> geq a b

141−

142−instance GCompare f => GCompare (WrapArg g f) where

143− gcompare (WrapArg a) (WrapArg b) = case gcompare a b of

144− GLT -> GLT

145− GEQ -> GEQ

146− GGT -> GGT

147−

148−--------------------------------------------------------------------------------

149−-- Convenience functions for DMap

150−--------------------------------------------------------------------------------

151−

152−-- | Map over all key/value pairs in a 'DMap', potentially altering the key as

153−-- well as the value. The provided function MUST preserve the ordering of the

154−-- keys, or the resulting 'DMap' will be malformed.

155−mapKeyValuePairsMonotonic :: (DSum k v -> DSum k' v') -> DMap k v -> DMap k' v'

156−mapKeyValuePairsMonotonic f = DMap.fromDistinctAscList . map f . DMap.toAscList

157−

158−{-# INLINE combineDMapsWithKey #-}

159−-- | Union two 'DMap's of different types, yielding another type. Each key that

160−-- is present in either input map will be present in the output.

161−combineDMapsWithKey :: forall f g h i.

162− GCompare f

163− => (forall a. f a -> These (g a) (h a) -> i a)

164− -> DMap f g

165− -> DMap f h

166− -> DMap f i

167−combineDMapsWithKey f mg mh = DMap.fromList $ go (DMap.toList mg) (DMap.toList mh)

168− where go :: [DSum f g] -> [DSum f h] -> [DSum f i]

169− go [] hs = map (\(hk :=> hv) -> hk :=> f hk (That hv)) hs

170− go gs [] = map (\(gk :=> gv) -> gk :=> f gk (This gv)) gs

171− go gs@((gk :=> gv) : gs') hs@((hk :=> hv) : hs') = case gk `gcompare` hk of

172− GLT -> (gk :=> f gk (This gv)) : go gs' hs

173− GEQ -> (gk :=> f gk (These gv hv)) : go gs' hs'

174− GGT -> (hk :=> f hk (That hv)) : go gs hs'

175−

176−-- | Extract the values of a 'DMap' of 'EitherTag's.

177−dmapToThese :: DMap (EitherTag a b) Identity -> Maybe (These a b)

178−dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of

179− (Nothing, Nothing) -> Nothing

180− (Just (Identity a), Nothing) -> Just $ This a

181− (Nothing, Just (Identity b)) -> Just $ That b

182− (Just (Identity a), Just (Identity b)) -> Just $ These a b

183−

184−-- | Tag type for 'Either' to use it as a 'DSum'.

185−data EitherTag l r a where

186− LeftTag :: EitherTag l r l

187− RightTag :: EitherTag l r r

188− deriving (Typeable)

189−

190−deriving instance Show (EitherTag l r a)

191−deriving instance Eq (EitherTag l r a)

192−deriving instance Ord (EitherTag l r a)

193−

194−instance GEq (EitherTag l r) where

195− geq a b = case (a, b) of

196− (LeftTag, LeftTag) -> Just Refl

197− (RightTag, RightTag) -> Just Refl

198− _ -> Nothing

199−

200−instance GCompare (EitherTag l r) where

201− gcompare a b = case (a, b) of

202− (LeftTag, LeftTag) -> GEQ

203− (LeftTag, RightTag) -> GLT

204− (RightTag, LeftTag) -> GGT

205− (RightTag, RightTag) -> GEQ

206−

207−instance GShow (EitherTag l r) where

208− gshowsPrec _ a = case a of

209− LeftTag -> showString "LeftTag"

210− RightTag -> showString "RightTag"

211−

212−-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.

213−eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity

214−eitherToDSum = \case

215− Left a -> (LeftTag :=> Identity a)

216− Right b -> (RightTag :=> Identity b)

217−

218−-- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'.

219−dsumToEither :: DSum (EitherTag a b) Identity -> Either a b

220−dsumToEither = \case

221− (LeftTag :=> Identity a) -> Left a

222− (RightTag :=> Identity b) -> Right b

223−

224−--------------------------------------------------------------------------------

225−-- ComposeMaybe

226−--------------------------------------------------------------------------------

227−

228−-- | We can't use @Compose Maybe@ instead of 'ComposeMaybe', because that would

229−-- make the 'f' parameter have a nominal type role. We need f to be

230−-- representational so that we can use safe 'coerce'.

231−newtype ComposeMaybe f a =

232− ComposeMaybe { getComposeMaybe :: Maybe (f a) } deriving (Show, Eq, Ord)

233−

234−deriving instance Functor f => Functor (ComposeMaybe f)

src/Data/Map/Misc.hs+1−1

@@ -43,7 +43,7 @@ diffMap olds news = flip Map.mapMaybe (align olds news) $ \case

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/Data/WeakBag.hs+8−3

@@ -15,6 +15,7 @@ module Data.WeakBag

15 , singleton

16 , insert

17 , traverse

18+ , traverse_

18 , remove

19 , remove

19 -- * Internal functions

20 -- * Internal functions

20 -- These will not always be available.

21 -- These will not always be available.

@@ -99,18 +100,22 @@ singleton a wbRef finalizer = {-# SCC "singleton" #-} do

99 ticket <- insert a bag wbRef finalizer

100 ticket <- insert a bag wbRef finalizer

100 return (bag, ticket)

101 return (bag, ticket)

101

102

102−{-# INLINE traverse #-}

103+{-# INLINE traverse_ #-}

103-- | Visit every node in the given list. If new nodes are appended during the

104-- | Visit every node in the given list. If new nodes are appended during the

104-- traversal, they will not be visited. Every live node that was in the list

105-- traversal, they will not be visited. Every live node that was in the list

105-- when the traversal began will be visited exactly once; however, no guarantee

106-- when the traversal began will be visited exactly once; however, no guarantee

106-- is made about the order of the traversal.

107-- is made about the order of the traversal.

107−traverse :: MonadIO m => WeakBag a -> (a -> m ()) -> m ()

108+traverse_ :: MonadIO m => WeakBag a -> (a -> m ()) -> m ()

108−traverse (WeakBag _ children) f = {-# SCC "traverse" #-} do

109+traverse_ (WeakBag _ children) f = {-# SCC "traverse" #-} do

109 cs <- liftIO $ readIORef children

110 cs <- liftIO $ readIORef children

110 forM_ cs $ \c -> do

111 forM_ cs $ \c -> do

111 ma <- liftIO $ deRefWeak c

112 ma <- liftIO $ deRefWeak c

112 mapM_ f ma

113 mapM_ f ma

113

114

115+{-# DEPRECATED traverse "Use 'traverse_' instead" #-}

116+traverse :: MonadIO m => WeakBag a -> (a -> m ()) -> m ()

117+traverse = traverse_

118+

114-- | Remove an item from the 'WeakBag'; does nothing if invoked multiple times

119-- | Remove an item from the 'WeakBag'; does nothing if invoked multiple times

115-- on the same 'WeakBagTicket'.

120-- on the same 'WeakBagTicket'.

116{-# INLINE remove #-}

121{-# INLINE remove #-}

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+39−9

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

@@ -173,12 +173,15 @@ module Reflex.Class

173 , slowHeadE

174 ) where

175

176−#if defined(MIN_VERSION_semialign)

176+#ifdef MIN_VERSION_semialign

177import Prelude hiding (zip, zipWith)

178

179#if MIN_VERSION_these(0,8,0)

180import Data.These.Combinators (justThese)

181#endif

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

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

184+#endif

182#endif

185#endif

183

186

184import Control.Applicative

187import Control.Applicative

@@ -193,11 +196,12 @@ import Data.Align

193import Data.Bifunctor

196import Data.Bifunctor

194import Data.Coerce

197import Data.Coerce

195import Data.Default

198import Data.Default

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

199+import Data.Dependent.Map (DMap)

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

197import qualified Data.Dependent.Map as DMap

201import qualified Data.Dependent.Map as DMap

198import Data.Functor.Compose

202import Data.Functor.Compose

199import Data.Functor.Product

203import Data.Functor.Product

200−import Data.GADT.Compare (GEq (..), GCompare (..), (:~:) (..))

204+import Data.GADT.Compare (GEq (..), GCompare (..))

201import Data.FastMutableIntMap (PatchIntMap)

205import Data.FastMutableIntMap (PatchIntMap)

202import Data.Foldable

206import Data.Foldable

203import Data.Functor.Bind

207import Data.Functor.Bind

@@ -207,17 +211,18 @@ import Data.IntMap.Strict (IntMap)

207import qualified Data.IntMap.Strict as IntMap

211import qualified Data.IntMap.Strict as IntMap

208import Data.List.NonEmpty (NonEmpty (..))

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

209import Data.Map (Map)

213import Data.Map (Map)

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

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

211import Data.Some (Some(Some))

215import Data.Some (Some(Some))

212import Data.String

216import Data.String

213import Data.These

217import Data.These

214import Data.Type.Coercion

218import Data.Type.Coercion

219+import Data.Type.Equality ((:~:) (..))

215import Data.Witherable (Filterable(..))

220import Data.Witherable (Filterable(..))

216import qualified Data.Witherable as W

221import qualified Data.Witherable as W

217import Reflex.FunctorMaybe (FunctorMaybe)

222import Reflex.FunctorMaybe (FunctorMaybe)

218import qualified Reflex.FunctorMaybe

223import qualified Reflex.FunctorMaybe

219−import Reflex.Patch

224+import Data.Patch

220−import qualified Reflex.Patch.MapWithMove as PatchMapWithMove

225+import qualified Data.Patch.MapWithMove as PatchMapWithMove

221

226

222import Debug.Trace (trace)

227import Debug.Trace (trace)

223

228

@@ -283,7 +288,8 @@ class ( MonadHold t (PushM t)

283 -- | Create an 'Event' that will occur whenever the currently-selected input

288 -- | Create an 'Event' that will occur whenever the currently-selected input

284 -- 'Event' occurs

289 -- 'Event' occurs

285 switch :: Behavior t (Event t a) -> Event t a

290 switch :: Behavior t (Event t a) -> Event t a

286− -- | Create an 'Event' that will occur whenever the input event is occurring -- and its occurrence value, another 'Event', is also occurring

291+ -- | Create an 'Event' that will occur whenever the input event is occurring -- and its occurrence value, another 'Event', is also occurring.

292+ -- You maybe looking for '@switchHold@ @never@' instead.

287 coincidence :: Event t (Event t a) -> Event t a

293 coincidence :: Event t (Event t a) -> Event t a

288 -- | Extract the 'Behavior' of a 'Dynamic'.

294 -- | Extract the 'Behavior' of a 'Dynamic'.

289 current :: Dynamic t a -> Behavior t a

295 current :: Dynamic t a -> Behavior t a

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

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

416 -- the supplied 'Event'.

422 -- the supplied 'Event'.

417 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

418

431

419-- | 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',

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

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

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

560 holdIncremental a0 = lift . holdIncremental a0

573 holdIncremental a0 = lift . holdIncremental a0

561 buildDynamic a0 = lift . buildDynamic a0

574 buildDynamic a0 = lift . buildDynamic a0

562 headE = lift . headE

575 headE = lift . headE

576+ now = lift now

563

577

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

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

565 sample = lift . sample

579 sample = lift . sample

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

570 holdIncremental a0 = lift . holdIncremental a0

584 holdIncremental a0 = lift . holdIncremental a0

571 buildDynamic a0 = lift . buildDynamic a0

585 buildDynamic a0 = lift . buildDynamic a0

572 headE = lift . headE

586 headE = lift . headE

587+ now = lift now

573

588

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

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

575 sample = lift . sample

590 sample = lift . sample

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

580 holdIncremental a0 = lift . holdIncremental a0

595 holdIncremental a0 = lift . holdIncremental a0

581 buildDynamic a0 = lift . buildDynamic a0

596 buildDynamic a0 = lift . buildDynamic a0

582 headE = lift . headE

597 headE = lift . headE

598+ now = lift now

583

599

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

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

585 sample = lift . sample

601 sample = lift . sample

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

590 holdIncremental a0 = lift . holdIncremental a0

606 holdIncremental a0 = lift . holdIncremental a0

591 buildDynamic a0 = lift . buildDynamic a0

607 buildDynamic a0 = lift . buildDynamic a0

592 headE = lift . headE

608 headE = lift . headE

609+ now = lift now

593

610

594instance (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

595 sample = lift . sample

612 sample = lift . sample

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

600 holdIncremental a0 = lift . holdIncremental a0

617 holdIncremental a0 = lift . holdIncremental a0

601 buildDynamic a0 = lift . buildDynamic a0

618 buildDynamic a0 = lift . buildDynamic a0

602 headE = lift . headE

619 headE = lift . headE

620+ now = lift now

603

621

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

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

605 sample = lift . sample

623 sample = lift . sample

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

610 holdIncremental a0 = lift . holdIncremental a0

628 holdIncremental a0 = lift . holdIncremental a0

611 buildDynamic a0 = lift . buildDynamic a0

629 buildDynamic a0 = lift . buildDynamic a0

612 headE = lift . headE

630 headE = lift . headE

631+ now = lift now

613

632

614--------------------------------------------------------------------------------

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

615-- Convenience functions

634-- Convenience functions

@@ -659,7 +678,9 @@ instance Reflex t => Monad (Behavior t) where

659 a >>= f = pull $ sample a >>= sample . f

678 a >>= f = pull $ sample a >>= sample . f

660 -- Note: it is tempting to write (_ >> b = b); however, this would result in (fail x >> return y) succeeding (returning y), which violates the law that (a >> b = a >>= \_ -> b), since the implementation of (>>=) above actually will fail. Since we can't examine 'Behavior's other than by using sample, I don't think it's possible to write (>>) to be more efficient than the (>>=) above.

679 -- Note: it is tempting to write (_ >> b = b); however, this would result in (fail x >> return y) succeeding (returning y), which violates the law that (a >> b = a >>= \_ -> b), since the implementation of (>>=) above actually will fail. Since we can't examine 'Behavior's other than by using sample, I don't think it's possible to write (>>) to be more efficient than the (>>=) above.

661 return = constant

680 return = constant

681+#if !MIN_VERSION_base(4,13,0)

662 fail = error "Monad (Behavior t) does not support fail"

682 fail = error "Monad (Behavior t) does not support fail"

683+#endif

663

684

664instance (Reflex t, Monoid a) => Monoid (Behavior t a) where

685instance (Reflex t, Monoid a) => Monoid (Behavior t a) where

665 mempty = constant mempty

686 mempty = constant mempty

@@ -1077,10 +1098,19 @@ instance Reflex t => Semialign (Event t) where

1077#endif

1098#endif

1078 align = alignEventWithMaybe Just

1099 align = alignEventWithMaybe Just

1079

1100

1080−#if defined(MIN_VERSION_semialign)

1101+#ifdef MIN_VERSION_semialign

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

1103+instance Reflex t => Zip (Event t) where

1104+#endif

1081 zip x y = mapMaybe justThese $ align x y

1105 zip x y = mapMaybe justThese $ align x y

1082#endif

1106#endif

1083

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

1084

1114

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

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

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

src/Reflex/Collection.hs+5−2

@@ -27,8 +27,11 @@ module Reflex.Collection

27 , simpleList

28 ) where

30−#if defined(MIN_VERSION_semialign)

30+#ifdef MIN_VERSION_semialign

31import Prelude hiding (zip, zipWith)

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

33+import Data.Zip (Zip (..))

34+#endif

32#endif

35#endif

34import Control.Monad.Identity

37import Control.Monad.Identity

@@ -127,7 +130,7 @@ listWithKeyShallowDiff initialVals valsChanged mkChild = do

127 Nothing -> Just Nothing

130 Nothing -> Just Nothing

128

131

129 -- We don't want to let spurious re-creations of items through

132 -- We don't want to let spurious re-creations of items through

130− Just _ -> Nothing

133+ Just _ -> Nothing

131 listHoldWithKey

134 listHoldWithKey

132 initialVals

135 initialVals

133 (attachWith (flip (Map.differenceWith relevantPatch))

136 (attachWith (flip (Map.differenceWith relevantPatch))

src/Reflex/Dynamic.hs+17−2

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

@@ -87,11 +89,14 @@ import Data.Align

87import Data.Dependent.Map (DMap)

89import 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 (..))

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

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

93+import Data.IntMap (IntMap)

94+import qualified Data.IntMap as IntMap

91import Data.Map (Map)

95import Data.Map (Map)

92import Data.Maybe

96import Data.Maybe

93import Data.Monoid ((<>))

97import Data.Monoid ((<>))

94import Data.These

98import Data.These

99+import Data.Type.Equality ((:~:) (..))

100

96import Debug.Trace

101import Debug.Trace

102

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

201distributeMapOverDynPure :: (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)

202distributeMapOverDynPure = fmap dmapToMap . distributeDMapOverDynPure . mapWithFunctorToDMap

207distributeMapOverDynPure = fmap dmapToMap . distributeDMapOverDynPure . mapWithFunctorToDMap

203

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+

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

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

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

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

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

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

213joinDynThroughMap :: 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)

214joinDynThroughMap = (distributeMapOverDynPure =<<)

224joinDynThroughMap = (distributeMapOverDynPure =<<)

215

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+

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

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

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

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

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

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

333--

348--

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

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

335--

350--

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

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

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

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

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

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

339 , 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/DynamicWriter/Class.hs−1

@@ -26,4 +26,3 @@ class (Monad m, Monoid w) => DynamicWriter t w m | m -> t w where

27instance DynamicWriter t w m => DynamicWriter t w (ReaderT r m) where

28 tellDyn = lift . tellDyn

29−

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/Network.hs+1−1

@@ -20,7 +20,7 @@ import Reflex.NotReady.Class

20import Reflex.PostBuild.Class

22-- | A 'Dynamic' "network": Takes a 'Dynamic' of network-creating actions and replaces the network whenever the 'Dynamic' updates.

23−-- The returned Event of network results fires when the 'Dynamic' updates.

23+-- The returned Event of network results fires at post-build time and when the 'Dynamic' updates.

24-- Note: Often, the type 'a' is an Event, in which case the return value is an Event-of-Events, where the outer 'Event' fires

25-- when switching networks. Such an 'Event' would typically be flattened (via 'switchPromptly').

26networkView :: (NotReady t m, Adjustable t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)

src/Reflex/Patch.hsdeleted−46

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

1−{-# LANGUAGE TypeFamilies #-}

2−-- |

3−-- Module:

4−-- Reflex.Patch

5−-- Description:

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

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

8−module Reflex.Patch

9− ( module Reflex.Patch

10− , module X

11− ) where

12−

13−import Reflex.Patch.Class as X

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

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

16− patchDMapWithMoveToPatchMapWithMoveWith,

17− traversePatchDMapWithMoveWithKey, unPatchDMapWithMove,

18− unsafePatchDMapWithMove, weakenPatchDMapWithMoveWith)

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

20−import Reflex.Patch.Map as X

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

22− patchMapWithMoveNewElementsMap, unPatchMapWithMove,

23− unsafePatchMapWithMove)

24−import Data.Map.Monoidal (MonoidalMap)

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

26−

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

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

29− negateG :: q -> q

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

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

32−

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

34−class Semigroup q => Additive q where

35−

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

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

38−

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

40− type PatchTarget (AdditivePatch p) = p

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

42−

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

44− negateG = fmap negateG

45−

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

src/Reflex/Patch/Class.hsdeleted−34

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

1−{-# LANGUAGE TypeFamilies #-}

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

3−module Reflex.Patch.Class where

4−

5−import Control.Monad.Identity

6−import Data.Maybe

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

8−

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

10−--

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

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

13−class Patch p where

14− type PatchTarget p :: *

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

16− -- 'Nothing'.

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

18−

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

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

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

22−

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

24−instance Patch (Identity a) where

25− type PatchTarget (Identity a) = a

26− apply (Identity a) _ = Just a

27−

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

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

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

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

32−composePatchFunctions g f a =

33− let fp = f a

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

src/Reflex/Patch/DMap.hsdeleted−82

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

1−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2−{-# LANGUAGE LambdaCase #-}

3−{-# LANGUAGE PolyKinds #-}

4−{-# LANGUAGE Rank2Types #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE StandaloneDeriving #-}

7−{-# LANGUAGE TypeFamilies #-}

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

9−module Reflex.Patch.DMap where

10−

11−import Reflex.Patch.Class

12−import Reflex.Patch.IntMap

13−import Reflex.Patch.Map

14−

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

16−import qualified Data.Dependent.Map as DMap

17−import Data.Functor.Constant

18−import Data.Functor.Misc

19−import qualified Data.IntMap as IntMap

20−import qualified Data.Map as Map

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

22−import Data.Some (Some)

23−

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

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

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

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

28−

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

30−

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

32−

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

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

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

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

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

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

39− nothingToJust = \case

40− Nothing -> Just $ Constant ()

41− Just _ -> Nothing

42−

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

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

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

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

47−

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

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

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

51−traversePatchDMap f = traversePatchDMapWithKey $ const f

52−

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

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

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

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

57−

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

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

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

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

62−

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

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

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

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

67−

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

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

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

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

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

73−

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

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

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

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

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

79−

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

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

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

src/Reflex/Patch/DMapWithMove.hsdeleted−363

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

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE FlexibleInstances #-}

4−{-# LANGUAGE GADTs #-}

5−{-# LANGUAGE LambdaCase #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

7−{-# LANGUAGE PatternGuards #-}

8−{-# LANGUAGE PolyKinds #-}

9−{-# LANGUAGE Rank2Types #-}

10−{-# LANGUAGE ScopedTypeVariables #-}

11−{-# LANGUAGE TypeFamilies #-}

12−{-# LANGUAGE UndecidableInstances #-}

13−

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

15−-- move values between keys.

16−module Reflex.Patch.DMapWithMove where

17−

18−import Reflex.Patch.Class

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

20−import qualified Reflex.Patch.MapWithMove as MapWithMove

21−

22−import Data.Constraint.Extras

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

24−import qualified Data.Dependent.Map as DMap

25−import Data.Functor.Constant

26−import Data.Functor.Misc

27−import Data.Functor.Product

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

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

30−import qualified Data.Map as Map

31−import Data.Maybe

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

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

34−import Data.These

35−

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

37−-- destinations.

38−--

39−-- Invariants:

40−--

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

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

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

44−

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

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

47−data NodeInfo k v a = NodeInfo

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

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

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

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

52− }

53− deriving (Show)

54−

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

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

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

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

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

60− -- |Delete the existing key

61− From_Delete :: From k v a

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

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

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

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

66−

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

68−-- operation.

69−type To = ComposeMaybe

70−

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

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

73−validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove

74−

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

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

77−validationErrorsForPatchDMapWithMove m =

78− noSelfMoves <> movesBalanced

79− where

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

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

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

83− selfMove _ = Nothing

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

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

86− case DMap.lookup src m of

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

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

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

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

91− else Nothing

92− _ ->

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

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

95− case DMap.lookup dst m of

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

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

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

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

100− else Nothing

101−

102− _ ->

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

104− unbalancedMove _ = Nothing

105−

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

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

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

109−

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

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

112−

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

114−data Fixup k v a

115− = Fixup_Delete

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

117−

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

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

120− PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m

121− where

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

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

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

125− (Just toAfter, From_Move fromBefore)

126− | isJust $ fromBefore `geq` toAfter

127− -> [toAfter :=> Fixup_Delete]

128− | otherwise

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

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

131− ]

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

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

134− (Nothing, _) -> []

135− mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete

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

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

138− = Fixup_Update $ These x y

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

140− = Fixup_Update $ These x y

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

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

143− combineNodeInfos _ nia nib = NodeInfo

144− { _nodeInfo_from = _nodeInfo_from nia

145− , _nodeInfo_to = _nodeInfo_to nib

146− }

147− applyFixup _ ni = \case

148− Fixup_Delete -> Nothing

149− Fixup_Update u -> Just $ NodeInfo

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

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

152− }

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

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

155− getHere = \case

156− This a -> Just a

157− These a _ -> Just a

158− That _ -> Nothing

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

160− getThere = \case

161− This _ -> Nothing

162− These _ b -> Just b

163− That b -> Just b

164−

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

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

167− mempty = PatchDMapWithMove mempty

168− mappend = (<>)

169−

170−{-

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

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

173− where

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

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

176− removeRedundantDst _ a = Just a

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

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

179− From_Move fromKey -> getDstAction fromKey dstBefore

180− nonMove -> nonMove

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

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

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

184− removeRedundantSrc _ a = Just a

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

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

187− ComposeMaybe Nothing -> ComposeMaybe Nothing

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

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

190−-}

191−

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

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

194−insertDMapKey k v =

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

196−

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

198−--

199−-- @

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

201−-- @

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

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

204− Nothing -> PatchDMapWithMove $ DMap.fromList

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

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

207− ]

208− Just _ -> mempty

209−

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

211−--

212−-- @

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

214−-- bMay = DMap.lookup b dmap

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

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

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

218−-- @

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

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

221− Nothing -> PatchDMapWithMove $ DMap.fromList

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

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

224− ]

225− Just _ -> mempty

226−

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

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

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

230−

231−{-

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

233−k1 = Const2 1

234−k2 = Const2 2

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

236−p1 = moveDMapKey k1 k2

237−p2 = moveDMapKey k2 k1

238−p12 = p1 <> p2

239−p21 = p2 <> p1

240−p12Slow = p1 `mappendPatchDMapWithMoveSlow` p2

241−p21Slow = p2 `mappendPatchDMapWithMoveSlow` p1

242−

243−testPatchDMapWithMove = do

244− print p1

245− print p2

246− print $ p12 == deleteDMapKey k1

247− print $ p21 == deleteDMapKey k2

248− print $ p12Slow == deleteDMapKey k1

249− print $ p21Slow == deleteDMapKey k2

250−

251−dst (PatchDMapWithMove x _) = x

252−src (PatchDMapWithMove _ x) = x

253−-}

254−

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

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

257−unPatchDMapWithMove (PatchDMapWithMove p) = p

258−

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

260−--

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

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

263−unsafePatchDMapWithMove = PatchDMapWithMove

264−

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

266−-- otherwise @Left errors@.

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

268−patchDMapWithMove dm =

269− case validationErrorsForPatchDMapWithMove dm of

270− [] -> Right $ unsafePatchDMapWithMove dm

271− errs -> Left errs

272−

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

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

275−mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $

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

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

278− g = \case

279− From_Insert v -> From_Insert $ f v

280− From_Delete -> From_Delete

281− From_Move k -> From_Move k

282−

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

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

285−traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f

286−

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

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

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

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

291− g k = \case

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

293− From_Delete -> pure From_Delete

294− From_Move fromKey -> pure $ From_Move fromKey

295−

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

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

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

299−

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

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

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

303−

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

305−-- values.

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

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

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

309− g ni = MapWithMove.NodeInfo

310− { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of

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

312− From_Delete -> MapWithMove.From_Delete

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

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

315− }

316−

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

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

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

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

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

322− g ni = MapWithMove.NodeInfo

323− { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of

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

325− From_Delete -> MapWithMove.From_Delete

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

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

328− }

329−

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

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

332−-- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'

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

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

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

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

337− { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of

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

339− MapWithMove.From_Delete -> From_Delete

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

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

342− }

343−

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

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

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

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

348− where insertions = DMap.mapMaybeWithKey insertFunc p

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

350− insertFunc _ ni = case _nodeInfo_from ni of

351− From_Insert v -> Just v

352− From_Move k -> DMap.lookup k old

353− From_Delete -> Nothing

354− deletions = DMap.mapMaybeWithKey deleteFunc p

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

356− deleteFunc _ ni = case _nodeInfo_from ni of

357− From_Delete -> Just $ Constant ()

358− _ -> Nothing

359−

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

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

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

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

src/Reflex/Patch/IntMap.hsdeleted−59

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

1−{-# LANGUAGE DeriveFoldable #-}

2−{-# LANGUAGE DeriveFunctor #-}

3−{-# LANGUAGE DeriveTraversable #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5−{-# LANGUAGE TypeFamilies #-}

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

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

8−module Reflex.Patch.IntMap where

9−

10−import Data.IntMap.Strict (IntMap)

11−import qualified Data.IntMap.Strict as IntMap

12−import Data.Maybe

13−import Data.Semigroup

14−import Reflex.Patch.Class

15−

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

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

18−-- and @Nothing@ means delete.

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

20−

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

22−instance Patch (PatchIntMap a) where

23− type PatchTarget (PatchIntMap a) = IntMap a

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

25− let removes = IntMap.filter isNothing p

26− adds = IntMap.mapMaybe id p

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

28−

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

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

31−-- precedence.

32−instance Semigroup (PatchIntMap v) where

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

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

35− stimes = stimesIdempotentMonoid

36−

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

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

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

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

41−

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

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

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

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

46−

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

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

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

50−

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

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

53−patchIntMapNewElementsMap :: PatchIntMap a -> IntMap a

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

55−

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

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

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

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

src/Reflex/Patch/Map.hsdeleted−55

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

1−{-# LANGUAGE LambdaCase #-}

2−{-# LANGUAGE TypeFamilies #-}

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

4−-- and deletions

5−module Reflex.Patch.Map where

6−

7−import Reflex.Patch.Class

8−

9−import Data.Map (Map)

10−import qualified Data.Map as Map

11−import Data.Maybe

12−import Data.Semigroup

13−

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

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

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

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

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

19−

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

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

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

23− {-# INLINABLE apply #-}

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

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

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

27− nothingToJust = \case

28− Nothing -> Just ()

29− Just _ -> Nothing

30−

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

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

33−-- precedence.

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

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

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

37− stimes = stimesIdempotentMonoid

38−

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

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

41− mempty = PatchMap mempty

42− mappend = (<>)

43−

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

45−-- Deletions are unaffected.

46−instance Functor (PatchMap k) where

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

48−

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

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

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

52−

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

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

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

src/Reflex/Patch/MapWithMove.hsdeleted−270

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

1−{-# LANGUAGE DeriveFoldable #-}

2−{-# LANGUAGE DeriveFunctor #-}

3−{-# LANGUAGE DeriveTraversable #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE LambdaCase #-}

6−{-# LANGUAGE PatternGuards #-}

7−{-# LANGUAGE ScopedTypeVariables #-}

8−{-# LANGUAGE TypeFamilies #-}

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

10−-- another

11−module Reflex.Patch.MapWithMove where

12−

13−import Reflex.Patch.Class

14−

15−import Control.Arrow

16−import Control.Monad.State

17−import Data.Foldable

18−import Data.Function

19−import Data.List

20−import Data.Map (Map)

21−import qualified Data.Map as Map

22−import Data.Maybe

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

24−import qualified Data.Set as Set

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

26−import Data.Tuple

27−

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

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

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

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

32−

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

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

35−data NodeInfo k v = NodeInfo

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

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

38− , _nodeInfo_to :: !(To k)

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

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

41− }

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

43−

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

45−data From k v

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

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

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

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

50−

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

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

53−-- that means it will be deleted.

54−type To = Maybe

55−

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

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

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

59− where valid = forwardLinks == backwardLinks

60− forwardLinks = Map.mapMaybe _nodeInfo_to m

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

62− case _nodeInfo_from v of

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

64− _ -> Nothing

65−

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

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

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

69− { _nodeInfo_from = From_Insert v

70− , _nodeInfo_to = Nothing

71− }

72−

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

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

75−unPatchMapWithMove (PatchMapWithMove p) = p

76−

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

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

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

80−

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

82−--

83−-- @

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

85−-- @

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

87−moveMapKey src dst

88− | src == dst = mempty

89− | otherwise =

90− PatchMapWithMove $ Map.fromList

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

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

93− ]

94−

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

96−--

97−-- @

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

99−-- bMay = Map.lookup b map

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

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

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

103−-- @

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

105−swapMapKey src dst

106− | src == dst = mempty

107− | otherwise =

108− PatchMapWithMove $ Map.fromList

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

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

111− ]

112−

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

114−deleteMapKey :: k -> PatchMapWithMove k v

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

116−

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

118−--

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

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

121−unsafePatchMapWithMove = PatchMapWithMove

122−

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

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

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

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

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

128− From_Insert v -> Just v

129− From_Move k -> Map.lookup k old

130− From_Delete -> Nothing

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

132− From_Delete -> Just ()

133− _ -> Nothing

134−

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

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

137−patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap

138−

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

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

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

142− where f ni = case _nodeInfo_from ni of

143− From_Insert v -> Just v

144− From_Move _ -> Nothing

145− From_Delete -> Nothing

146−

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

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

149−-- not changed.

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

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

152− where unsorted = Map.toList m

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

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

155− Just (from, to)

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

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

158− let Just movingTo = Map.lookup from reverseMapping

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

160−

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

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

163−-- values sorted with the given ordering function.

164−patchThatChangesAndSortsMapWith :: forall k v. (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v

165−patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex

166− where newList = Map.toList newByIndexUnsorted

167− newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList

168−

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

170−-- will produce the second 'Map'.

171−patchThatChangesMap :: (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v

172−patchThatChangesMap oldByIndex newByIndex = patch

173− where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex

174− (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do

175− let f k v = do

176− remainingValues <- get

177− let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys

178− then Map.delete v remainingValues

179− else Map.insert v remainingKeys remainingValues

180− case Map.lookup v remainingValues of

181− Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take

182− Just fromKs ->

183− if k `Set.member` fromKs

184− then do

185− putRemainingKeys $ Set.delete k fromKs

186− return $ NodeInfo (From_Move k) $ Just undefined -- There's an existing value, and it's here, so no patch necessary

187− else do

188− (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here

189− putRemainingKeys remainingKeys

190− return $ NodeInfo (From_Move fromK) $ Just undefined

191− Map.traverseWithKey f newByIndex

192− unusedOldKeys = fold unusedValuesByValue

193− pointlessMove k = \case

194− From_Move k' | k == k' -> True

195− _ -> False

196− keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)

197− then Just undefined

198− else Nothing

199− patch = unsafePatchMapWithMove $ Map.filterWithKey (\k -> not . pointlessMove k . _nodeInfo_from) $ Map.mergeWithKey (\k a _ -> Just $ nodeInfoSetTo (keyWasMoved k) a) (Map.mapWithKey $ \k -> nodeInfoSetTo $ keyWasMoved k) (Map.mapWithKey $ \k _ -> NodeInfo From_Delete $ keyWasMoved k) insertsAndMoves oldByIndex

200−

201−-- | Change the 'From' value of a 'NodeInfo'

202−nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v

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

204−

205−-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or

206−-- 'Applicative', 'Monad', etc.) action to get the new value

207−nodeInfoMapMFrom :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)

208−nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni

209−

210−-- | Set the 'To' field of a 'NodeInfo'

211−nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v

212−nodeInfoSetTo to ni = ni { _nodeInfo_to = to }

213−

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

215−data Fixup k v

216− = Fixup_Delete

217− | Fixup_Update (These (From k v) (To k))

218−

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

220−instance Ord k => Semigroup (PatchMapWithMove k v) where

221− PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m

222− where

223− connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb

224− h :: (k, (Maybe k, From k v)) -> [(k, Fixup k v)]

225− h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of

226− (Just toAfter, From_Move fromBefore)

227− | fromBefore == toAfter

228− -> [(toAfter, Fixup_Delete)]

229− | otherwise

230− -> [ (toAfter, Fixup_Update (This editBefore))

231− , (fromBefore, Fixup_Update (That mToAfter))

232− ]

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

234− (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]

235− (Nothing, _) -> []

236− mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete

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

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

239− = Fixup_Update $ These x y

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

241− = Fixup_Update $ These x y

242− mergeFixups _ _ _ = error "PatchMapWithMove: incompatible fixups"

243− fixups = Map.fromListWithKey mergeFixups $ concatMap h connections

244− combineNodeInfos _ nia nib = NodeInfo

245− { _nodeInfo_from = _nodeInfo_from nia

246− , _nodeInfo_to = _nodeInfo_to nib

247− }

248− applyFixup _ ni = \case

249− Fixup_Delete -> Nothing

250− Fixup_Update u -> Just $ NodeInfo

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

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

253− }

254− m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups

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

256− getHere = \case

257− This a -> Just a

258− These a _ -> Just a

259− That _ -> Nothing

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

261− getThere = \case

262− This _ -> Nothing

263− These _ b -> Just b

264− That b -> Just b

265−

266−--TODO: Figure out how to implement this in terms of PatchDMapWithMove rather than duplicating it here

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

268−instance Ord k => Monoid (PatchMapWithMove k v) where

269− mempty = PatchMapWithMove mempty

270− mappend = (<>)

src/Reflex/PerformEvent/Base.hs+3−1

@@ -141,7 +141,7 @@ hostPerformEventT a = do

141 case mToPerform of

142 Nothing -> return [result']

143 Just toPerform -> do

144− responses <- runHostFrame $ traverseRequesterData (Identity <$>) toPerform

144+ responses <- runHostFrame $ traverseRequesterData (fmap Identity) toPerform

145 mrt <- readRef responseTrigger

146 let followupEventTriggers = case mrt of

147 Just rt -> [rt :=> Identity responses]

@@ -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+15−4

@@ -16,21 +16,25 @@ module Reflex.Query.Base

16 , mapQueryResult

17 , dynWithQueryT

18 , withQueryT

19+ , mapQueryT

19 ) where

20 ) where

21import Control.Applicative (liftA2)

22import Control.Applicative (liftA2)

22import Control.Monad.Exception

23import Control.Monad.Exception

23import Control.Monad.Fix

24import Control.Monad.Fix

25+import Control.Monad.Morph

24import Control.Monad.Primitive

26import Control.Monad.Primitive

25import Control.Monad.Reader

27import Control.Monad.Reader

26import Control.Monad.Ref

28import Control.Monad.Ref

27import Control.Monad.State.Strict

29import Control.Monad.State.Strict

28import Data.Align

30import Data.Align

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

31+import Data.Dependent.Map (DMap)

30import qualified Data.Dependent.Map as DMap

32import qualified Data.Dependent.Map as DMap

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

31import Data.Foldable

34import Data.Foldable

32import Data.Functor.Compose

35import Data.Functor.Compose

33import Data.Functor.Misc

36import Data.Functor.Misc

37+import Data.GADT.Compare (GCompare)

34import Data.IntMap (IntMap)

38import Data.IntMap (IntMap)

35import qualified Data.IntMap as IntMap

39import qualified Data.IntMap as IntMap

36import Data.Map (Map)

40import Data.Map (Map)

@@ -46,7 +50,7 @@ import Reflex.DynamicWriter.Class

46import Reflex.EventWriter.Base

50import Reflex.EventWriter.Base

47import Reflex.EventWriter.Class

51import Reflex.EventWriter.Class

48import Reflex.Host.Class

52import Reflex.Host.Class

49−import qualified Reflex.Patch.MapWithMove as MapWithMove

53+import qualified Data.Patch.MapWithMove as MapWithMove

50import Reflex.PerformEvent.Class

54import Reflex.PerformEvent.Class

51import Reflex.PostBuild.Class

55import Reflex.PostBuild.Class

52import Reflex.Query.Class

56import Reflex.Query.Class

@@ -134,7 +138,7 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t

134 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch

138 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch

135 return (liftedResult0, liftedResult')

139 return (liftedResult0, liftedResult')

136

140

137− traverseDMapWithKeyWithAdjust :: forall (k :: * -> *) v v'. (DMap.GCompare k) => (forall a. k a -> v a -> QueryT t q m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> QueryT t q m (DMap k v', Event t (PatchDMap k v'))

141+ traverseDMapWithKeyWithAdjust :: forall (k :: * -> *) v v'. (GCompare k) => (forall a. k a -> v a -> QueryT t q m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> QueryT t q m (DMap k v', Event t (PatchDMap k v'))

138 traverseDMapWithKeyWithAdjust f dm0 dm' = do

142 traverseDMapWithKeyWithAdjust f dm0 dm' = do

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

140 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

@@ -179,7 +183,7 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t

179 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch

183 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch

180 return (liftedResult0, liftedResult')

184 return (liftedResult0, liftedResult')

181

185

182− traverseDMapWithKeyWithAdjustWithMove :: forall (k :: * -> *) v v'. (DMap.GCompare k) => (forall a. k a -> v a -> QueryT t q m (v' a)) -> DMap k v -> Event t (PatchDMapWithMove k v) -> QueryT t q m (DMap k v', Event t (PatchDMapWithMove k v'))

186+ traverseDMapWithKeyWithAdjustWithMove :: forall (k :: * -> *) v v'. (GCompare k) => (forall a. k a -> v a -> QueryT t q m (v' a)) -> DMap k v -> Event t (PatchDMapWithMove k v) -> QueryT t q m (DMap k v', Event t (PatchDMapWithMove k v'))

183 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do

187 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do

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

185 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

@@ -236,6 +240,9 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t

236instance MonadTrans (QueryT t q) where

240instance MonadTrans (QueryT t q) where

237 lift = QueryT . lift . lift . lift

241 lift = QueryT . lift . lift . lift

238

242

243+instance MFunctor (QueryT t q) where

244+ hoist = mapQueryT

245+

239instance PrimMonad m => PrimMonad (QueryT t q m) where

246instance PrimMonad m => PrimMonad (QueryT t q m) where

240 type PrimState (QueryT t q m) = PrimState m

247 type PrimState (QueryT t q m) = PrimState m

241 primitive = lift . primitive

248 primitive = lift . primitive

@@ -287,6 +294,10 @@ withQueryT f a = do

287 (fmapCheap (AdditivePatch . mapQuery f . unAdditivePatch) $ updatedIncremental q)

294 (fmapCheap (AdditivePatch . mapQuery f . unAdditivePatch) $ updatedIncremental q)

288 return result

295 return result

289

296

297+-- | Maps a function over a 'QueryT' that can change the underlying monad

298+mapQueryT :: (forall b. m b -> n b) -> QueryT t q m a -> QueryT t q n a

299+mapQueryT f (QueryT a) = QueryT $ mapStateT (mapEventWriterT (mapReaderT f)) a

300+

290-- | dynWithQueryT's (Dynamic t QueryMorphism) argument needs to be a group homomorphism at all times in order to behave correctly

301-- | dynWithQueryT's (Dynamic t QueryMorphism) argument needs to be a group homomorphism at all times in order to behave correctly

291dynWithQueryT :: (MonadFix m, PostBuild t m, Group q, Additive q, Group q', Additive q', Query q')

302dynWithQueryT :: (MonadFix m, PostBuild t m, Group q, Additive q, Group q', Additive q', Query q')

292 => Dynamic t (QueryMorphism q q')

303 => Dynamic t (QueryMorphism q q')

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+340−169

@@ -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,15 +38,17 @@ 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

45import Control.Monad.Ref

44import Control.Monad.Ref

45+import Control.Monad.Fail (MonadFail)

46+import qualified Control.Monad.Fail as MonadFail

46import Data.Align

47import Data.Align

47import Data.Coerce

48import Data.Coerce

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

49+import Data.Dependent.Map (DMap)

49import qualified Data.Dependent.Map as DMap

50import qualified Data.Dependent.Map as DMap

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

50import Data.FastMutableIntMap (FastMutableIntMap, PatchIntMap (..))

52import Data.FastMutableIntMap (FastMutableIntMap, PatchIntMap (..))

51import qualified Data.FastMutableIntMap as FastMutableIntMap

53import qualified Data.FastMutableIntMap as FastMutableIntMap

52import Data.Foldable hiding (concat, elem, sequence_)

54import Data.Foldable hiding (concat, elem, sequence_)

@@ -59,10 +61,11 @@ import qualified Data.IntMap.Strict as IntMap

59import Data.IORef

61import Data.IORef

60import Data.Kind (Type)

62import Data.Kind (Type)

61import Data.Maybe hiding (mapMaybe)

63import Data.Maybe hiding (mapMaybe)

62−import Data.Monoid ((<>))

64+import Data.Monoid (mempty, (<>))

63import Data.Proxy

65import Data.Proxy

64import Data.These

66import Data.These

65import Data.Traversable

67import Data.Traversable

68+import Data.Type.Equality ((:~:)(Refl))

66import Data.Witherable (Filterable, mapMaybe)

69import Data.Witherable (Filterable, mapMaybe)

67import GHC.Exts hiding (toList)

70import GHC.Exts hiding (toList)

68import GHC.IORef (IORef (..))

71import GHC.IORef (IORef (..))

@@ -72,19 +75,23 @@ import System.IO.Unsafe

72import System.Mem.Weak

75import System.Mem.Weak

73import Unsafe.Coerce

76import Unsafe.Coerce

75−#if defined(MIN_VERSION_semialign)

78+#ifdef MIN_VERSION_semialign

76#if MIN_VERSION_these(0,8,0)

79#if MIN_VERSION_these(0,8,0)

77import Data.These.Combinators (justThese)

80import Data.These.Combinators (justThese)

78#endif

81#endif

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

83+import Data.Zip (Zip (..))

84+#endif

79#endif

85#endif

81#ifdef DEBUG_CYCLES

87#ifdef DEBUG_CYCLES

82import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)

88import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)

89+#endif

90+

83import Data.List.NonEmpty (NonEmpty (..), nonEmpty)

91import Data.List.NonEmpty (NonEmpty (..), nonEmpty)

84import qualified Data.List.NonEmpty as NonEmpty

92import qualified Data.List.NonEmpty as NonEmpty

85−import Data.Monoid (mempty)

86import Data.Tree (Forest, Tree (..), drawForest)

93import Data.Tree (Forest, Tree (..), drawForest)

87−#endif

94+import Data.List (isPrefixOf)

89import Data.FastWeakBag (FastWeakBag, FastWeakBagTicket)

96import Data.FastWeakBag (FastWeakBag, FastWeakBagTicket)

90import qualified Data.FastWeakBag as FastWeakBag

97import qualified Data.FastWeakBag as FastWeakBag

@@ -99,28 +106,65 @@ import qualified Reflex.Class

99import qualified Reflex.Class as R

106import qualified Reflex.Class as R

100import qualified Reflex.Host.Class

107import qualified Reflex.Host.Class

101import Reflex.NotReady.Class

108import Reflex.NotReady.Class

102−import Reflex.Patch

109+import Data.Patch

103−import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove

110+import qualified Data.Patch.DMapWithMove as PatchDMapWithMove

111+import Reflex.PerformEvent.Base (PerformEventT)

104

112

105#ifdef DEBUG_TRACE_EVENTS

113#ifdef DEBUG_TRACE_EVENTS

106import qualified Data.ByteString.Char8 as BS8

114import qualified Data.ByteString.Char8 as BS8

107import System.IO (stderr)

115import System.IO (stderr)

108import Data.List (isPrefixOf)

116import Data.List (isPrefixOf)

117+#endif

118+

119+-- TODO stdout might not be the best channel for debug output

120+debugStrLn :: String -> IO ()

121+debugStrLn = putStrLn

109

122

123+#ifdef DEBUG_TRACE_EVENTS

110withStackOneLine :: (BS8.ByteString -> a) -> a

124withStackOneLine :: (BS8.ByteString -> a) -> a

111withStackOneLine expr = unsafePerformIO $ do

125withStackOneLine expr = unsafePerformIO $ do

112 stack <- currentCallStack

126 stack <- currentCallStack

113 return (expr . BS8.pack . unwords . dropInternal . reverse $ stack)

127 return (expr . BS8.pack . unwords . dropInternal . reverse $ stack)

114− where dropInternal = filter (not . isPrefixOf "Reflex.Spider.Internal")

128+ where dropInternal = filterStack "Reflex.Spider.Internal"

115

129

116#endif

130#endif

117

131

132+debugPropagate :: Bool

133+

134+debugInvalidateHeight :: Bool

135+

136+debugInvalidate :: Bool

137+

118#ifdef DEBUG

138#ifdef DEBUG

119#define DEBUG_NODEIDS

139#define DEBUG_NODEIDS

120

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+

121class HasNodeId a where

159class HasNodeId a where

122 getNodeId :: a -> Int

160 getNodeId :: a -> Int

123

161

162+instance HasNodeId (CacheSubscribed x a) where

163+ getNodeId = _cacheSubscribed_nodeId

164+

165+instance HasNodeId (FanInt x a) where

166+ getNodeId = _fanInt_nodeId

167+

124instance HasNodeId (Hold x p) where

168instance HasNodeId (Hold x p) where

125 getNodeId = holdNodeId

169 getNodeId = holdNodeId

126

170

@@ -141,16 +185,27 @@ instance HasNodeId (Pull x a) where

141

185

142{-# INLINE showNodeId #-}

186{-# INLINE showNodeId #-}

143showNodeId :: HasNodeId a => a -> String

187showNodeId :: HasNodeId a => a -> String

144−showNodeId = ("#"<>) . show . getNodeId

188+showNodeId = showNodeId' . getNodeId

189+

190+showNodeId' :: Int -> String

191+showNodeId' = ("#"<>) . show

145

192

146

193

147#else

194#else

148

195

196+debugPropagate = False

197+debugInvalidateHeight = False

198+debugInvalidate = False

199+

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

150{-# INLINE showNodeId #-}

201{-# INLINE showNodeId #-}

151showNodeId :: a -> String

202showNodeId :: a -> String

152showNodeId _ = ""

203showNodeId _ = ""

153

204

205+{-# INLINE showNodeId' #-}

206+showNodeId' :: Int -> String

207+showNodeId' _ = ""

208+

154#endif

209#endif

155

210

156#ifdef DEBUG_NODEIDS

211#ifdef DEBUG_NODEIDS

@@ -196,9 +251,9 @@ subscribeAndRead = unEvent

196-- caching; if the computation function is very cheap, this is (much) more

251-- caching; if the computation function is very cheap, this is (much) more

197-- efficient than 'push'

252-- efficient than 'push'

198{-# INLINE [1] pushCheap #-}

253{-# INLINE [1] pushCheap #-}

199−pushCheap :: (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b

254+pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b

200pushCheap !f e = Event $ \sub -> do

255pushCheap !f e = Event $ \sub -> do

201− (subscription, occ) <- subscribeAndRead e $ sub

256+ (subscription, occ) <- subscribeAndRead e $ debugSubscriber' "push" $ sub

202 { subscriberPropagate = \a -> do

257 { subscriberPropagate = \a -> do

203 mb <- f a

258 mb <- f a

204 mapM_ (subscriberPropagate sub) mb

259 mapM_ (subscriberPropagate sub) mb

@@ -217,10 +272,10 @@ terminalSubscriber p = Subscriber

217

272

218-- | Subscribe to an Event only for the duration of one occurrence

273-- | Subscribe to an Event only for the duration of one occurrence

219{-# INLINE subscribeAndReadHead #-}

274{-# INLINE subscribeAndReadHead #-}

220−subscribeAndReadHead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)

275+subscribeAndReadHead :: HasSpiderTimeline x => Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)

221subscribeAndReadHead e sub = do

276subscribeAndReadHead e sub = do

222 subscriptionRef <- liftIO $ newIORef $ error "subscribeAndReadHead: not initialized"

277 subscriptionRef <- liftIO $ newIORef $ error "subscribeAndReadHead: not initialized"

223− (subscription, occ) <- subscribeAndRead e $ sub

278+ (subscription, occ) <- subscribeAndRead e $ debugSubscriber' "head" $ sub

224 { subscriberPropagate = \a -> do

279 { subscriberPropagate = \a -> do

225 liftIO $ unsubscribe =<< readIORef subscriptionRef

280 liftIO $ unsubscribe =<< readIORef subscriptionRef

226 subscriberPropagate sub a

281 subscriberPropagate sub a

@@ -231,24 +286,42 @@ subscribeAndReadHead e sub = do

231 return (subscription, occ)

286 return (subscription, occ)

232

287

233--TODO: Make this lazy in its input event

288--TODO: Make this lazy in its input event

234−headE :: (MonadIO m, Defer (SomeMergeInit x) m) => Event x a -> m (Event x a)

289+headE :: (MonadIO m, Defer (SomeMergeInit x) m, HasSpiderTimeline x) => Event x a -> m (Event x a)

235headE originalE = do

290headE originalE = do

236 parent <- liftIO $ newIORef $ Just originalE

291 parent <- liftIO $ newIORef $ Just originalE

237 defer $ SomeMergeInit $ do --TODO: Rename SomeMergeInit appropriately

292 defer $ SomeMergeInit $ do --TODO: Rename SomeMergeInit appropriately

238 let clearParent = liftIO $ writeIORef parent Nothing

293 let clearParent = liftIO $ writeIORef parent Nothing

239− (_, occ) <- subscribeAndReadHead originalE $ terminalSubscriber $ \_ -> clearParent

294+ (_, occ) <- subscribeAndReadHead originalE $ terminalSubscriber $ const clearParent

240 when (isJust occ) clearParent

295 when (isJust occ) clearParent

241− return $ Event $ \sub -> do

296+ return $ Event $ \sub ->

242 liftIO (readIORef parent) >>= \case

297 liftIO (readIORef parent) >>= \case

243− Nothing -> subscribeAndReadNever

298+ Nothing -> subscribeAndReadNever

244 Just e -> subscribeAndReadHead e sub

299 Just e -> subscribeAndReadHead e sub

245

300

246data CacheSubscribed x a

301data CacheSubscribed x a

247 = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(FastWeakBag (Subscriber x a))

302 = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(FastWeakBag (Subscriber x a))

248 , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)

303 , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)

249 , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))

304 , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))

305+#ifdef DEBUG_NODEIDS

306+ , _cacheSubscribed_nodeId :: {-# UNPACK #-} !Int

307+#endif

250 }

308 }

251

309

310+nowSpiderEventM :: (HasSpiderTimeline x) => EventM x (R.Event (SpiderTimeline x) ())

311+nowSpiderEventM =

312+ SpiderEvent <$> now

313+

314+now :: (MonadIO m, Defer (Some Clear) m, HasSpiderTimeline x

315+ ) => m (Event x ())

316+now = do

317+ nowOrNot <- liftIO $ newIORef $ Just ()

318+ scheduleClear nowOrNot

319+ return . Event $ \_ -> do

320+ occ <- liftIO . readIORef $ nowOrNot

321+ return ( EventSubscription (return ()) eventSubscribedNow

322+ , occ

323+ )

324+

252-- | Construct an 'Event' whose value is guaranteed not to be recomputed

325-- | Construct an 'Event' whose value is guaranteed not to be recomputed

253-- repeatedly

326-- repeatedly

254--

327--

@@ -273,16 +346,23 @@ cacheEvent e =

273 subscribedTicket <- liftIO (readIORef mSubscribedRef >>= getFastWeakTicket) >>= \case

346 subscribedTicket <- liftIO (readIORef mSubscribedRef >>= getFastWeakTicket) >>= \case

274 Just subscribedTicket -> return subscribedTicket

347 Just subscribedTicket -> return subscribedTicket

275 Nothing -> do

348 Nothing -> do

349+#ifdef DEBUG_NODEIDS

350+ nodeId <- liftIO newNodeId

351+#endif

276 subscribers <- liftIO FastWeakBag.empty

352 subscribers <- liftIO FastWeakBag.empty

277 occRef <- liftIO $ newIORef Nothing -- This should never be read prior to being set below

353 occRef <- liftIO $ newIORef Nothing -- This should never be read prior to being set below

354+#ifdef DEBUG_NODEIDS

355+ (parentSub, occ) <- subscribeAndRead e $ debugSubscriber' ("cacheEvent" <> showNodeId' nodeId) $ Subscriber

356+#else

278 (parentSub, occ) <- subscribeAndRead e $ Subscriber

357 (parentSub, occ) <- subscribeAndRead e $ Subscriber

358+#endif

279− { subscriberPropagate = \a -> do

359+ { subscriberPropagate = \a -> do

280− liftIO $ writeIORef occRef (Just a)

360+ liftIO $ writeIORef occRef (Just a)

281− scheduleClear occRef

361+ scheduleClear occRef

282− propagateFast a subscribers

362+ propagateFast a subscribers

283− , subscriberInvalidateHeight = FastWeakBag.traverse subscribers . invalidateSubscriberHeight

363+ , subscriberInvalidateHeight = FastWeakBag.traverse_ subscribers . invalidateSubscriberHeight

284− , subscriberRecalculateHeight = FastWeakBag.traverse subscribers . recalculateSubscriberHeight

364+ , subscriberRecalculateHeight = FastWeakBag.traverse_ subscribers . recalculateSubscriberHeight

285− }

365+ }

286 when (isJust occ) $ do

366 when (isJust occ) $ do

287 liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing

367 liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing

288 scheduleClear occRef

368 scheduleClear occRef

@@ -290,19 +370,22 @@ cacheEvent e =

290 { _cacheSubscribed_subscribers = subscribers

370 { _cacheSubscribed_subscribers = subscribers

291 , _cacheSubscribed_parent = parentSub

371 , _cacheSubscribed_parent = parentSub

292 , _cacheSubscribed_occurrence = occRef

372 , _cacheSubscribed_occurrence = occRef

373+#ifdef DEBUG_NODEIDS

374+ , _cacheSubscribed_nodeId = nodeId

375+#endif

293 }

376 }

294 subscribedTicket <- liftIO $ mkFastWeakTicket subscribed

377 subscribedTicket <- liftIO $ mkFastWeakTicket subscribed

295 liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket

378 liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket

296 return subscribedTicket

379 return subscribedTicket

297 liftIO $ cacheSubscription sub mSubscribedRef subscribedTicket

380 liftIO $ cacheSubscription sub mSubscribedRef subscribedTicket

298

381

299−cacheSubscription :: Subscriber x a -> IORef (FastWeak (CacheSubscribed x a))

382+cacheSubscription :: Subscriber x a -> IORef (FastWeak (CacheSubscribed x a))

300 -> FastWeakTicket (CacheSubscribed x a) -> IO (EventSubscription x, Maybe a)

383 -> FastWeakTicket (CacheSubscribed x a) -> IO (EventSubscription x, Maybe a)

301−cacheSubscription sub mSubscribedRef subscribedTicket = do

384+cacheSubscription sub mSubscribedRef subscribedTicket = do

302 subscribed <- getFastWeakTicketValue subscribedTicket

385 subscribed <- getFastWeakTicketValue subscribedTicket

303 ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed

386 ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed

304 occ <- readIORef $ _cacheSubscribed_occurrence subscribed

387 occ <- readIORef $ _cacheSubscribed_occurrence subscribed

305−

388+

306 let parentSub = _cacheSubscribed_parent subscribed

389 let parentSub = _cacheSubscribed_parent subscribed

307 es = EventSubscription

390 es = EventSubscription

308 { _eventSubscription_unsubscribe = do

391 { _eventSubscription_unsubscribe = do

@@ -321,9 +404,9 @@ cacheSubscription sub mSubscribedRef subscribedTicket = do

321 , eventSubscribedGetParents = return [_eventSubscription_subscribed parentSub]

404 , eventSubscribedGetParents = return [_eventSubscription_subscribed parentSub]

322 , eventSubscribedHasOwnHeightRef = False

405 , eventSubscribedHasOwnHeightRef = False

323 , eventSubscribedWhoCreated = whoCreatedIORef mSubscribedRef

406 , eventSubscribedWhoCreated = whoCreatedIORef mSubscribedRef

407+#endif

324 }

408 }

325−#endif

326− }

409+ }

327 return (es, occ)

410 return (es, occ)

328

411

329

412

@@ -381,16 +464,6 @@ data Subscriber x a = Subscriber

381 , subscriberRecalculateHeight :: !(Height -> IO ())

464 , subscriberRecalculateHeight :: !(Height -> IO ())

382 }

465 }

383

466

384−--TODO: Move this comment to WeakBag

385−-- These function are constructor functions that are marked NOINLINE so they are

386−-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away

387−-- so any weak references that are attached to the constructors will have their

388−-- finalizer run. Using the opaque constructor, does not see the

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

390−--

391−-- The result is also evaluated to WHNF, since forcing a thunk invalidates

392−-- the weak pointer to it in some cases.

393−

394newSubscriberHold :: (HasSpiderTimeline x, Patch p) => Hold x p -> IO (Subscriber x p)

467newSubscriberHold :: (HasSpiderTimeline x, Patch p) => Hold x p -> IO (Subscriber x p)

395newSubscriberHold h = return $ Subscriber

468newSubscriberHold h = return $ Subscriber

396 { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h

469 { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h

@@ -412,14 +485,12 @@ newSubscriberFan subscribed = debugSubscriber ("SubscriberFan " <> showNodeId su

412 return ()

485 return ()

413 , subscriberInvalidateHeight = \old -> do

486 , subscriberInvalidateHeight = \old -> do

414 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

487 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

415− forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old

488+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old

416−

417 , subscriberRecalculateHeight = \new -> do

489 , subscriberRecalculateHeight = \new -> do

418 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

490 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

419− forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new

491+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new

420 }

492 }

421

493

422−

423newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)

494newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)

424newSubscriberSwitch subscribed = debugSubscriber ("SubscriberCoincidenceOuter" <> showNodeId subscribed) $ Subscriber

495newSubscriberSwitch subscribed = debugSubscriber ("SubscriberCoincidenceOuter" <> showNodeId subscribed) $ Subscriber

425 { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do

496 { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do

@@ -430,7 +501,7 @@ newSubscriberSwitch subscribed = debugSubscriber ("SubscriberCoincidenceOuter" <

430 oldHeight <- readIORef $ switchSubscribedHeight subscribed

501 oldHeight <- readIORef $ switchSubscribedHeight subscribed

431 when (oldHeight /= invalidHeight) $ do

502 when (oldHeight /= invalidHeight) $ do

432 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight

503 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight

433− WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

504+ WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

434 , subscriberRecalculateHeight = (`updateSwitchHeight` subscribed)

505 , subscriberRecalculateHeight = (`updateSwitchHeight` subscribed)

435 }

506 }

436

507

@@ -446,17 +517,17 @@ newSubscriberCoincidenceOuter subscribed = debugSubscriber ("SubscriberCoinciden

446 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd

517 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd

447 scheduleClear $ coincidenceSubscribedInnerParent subscribed

518 scheduleClear $ coincidenceSubscribedInnerParent subscribed

448 case occ of

519 case occ of

449− Nothing -> do

520+ Nothing ->

450 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height

521 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height

451 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight

522 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight

452− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight

523+ WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight

453− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight

524+ WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight

454 Just o -> do -- Since it's already firing, no need to adjust height

525 Just o -> do -- Since it's already firing, no need to adjust height

455 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ

526 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ

456 scheduleClear $ coincidenceSubscribedOccurrence subscribed

527 scheduleClear $ coincidenceSubscribedOccurrence subscribed

457 propagate o $ coincidenceSubscribedSubscribers subscribed

528 propagate o $ coincidenceSubscribedSubscribers subscribed

458 , subscriberInvalidateHeight = \_ -> invalidateCoincidenceHeight subscribed

529 , subscriberInvalidateHeight = \_ -> invalidateCoincidenceHeight subscribed

459− , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed

530+ , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed

460 }

531 }

461

532

462newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)

533newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)

@@ -480,18 +551,18 @@ recalculateSubscriberHeight :: Height -> Subscriber x a -> IO ()

480recalculateSubscriberHeight = flip subscriberRecalculateHeight

551recalculateSubscriberHeight = flip subscriberRecalculateHeight

481

552

482-- | Propagate everything at the current height

553-- | Propagate everything at the current height

483−propagate :: a -> WeakBag (Subscriber x a) -> EventM x ()

554+propagate :: forall x a. HasSpiderTimeline x => a -> WeakBag (Subscriber x a) -> EventM x ()

484−propagate a subscribers = withIncreasedDepth (Proxy::Proxy x) $ do

555+propagate a subscribers = withIncreasedDepth (Proxy::Proxy x) $

485 -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them

556 -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them

486 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work

557 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work

487− WeakBag.traverse subscribers $ \s -> subscriberPropagate s a

558+ WeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a

488

559

489-- | Propagate everything at the current height

560-- | Propagate everything at the current height

490−propagateFast :: a -> FastWeakBag (Subscriber x a) -> EventM x ()

561+propagateFast :: forall x a. HasSpiderTimeline x => a -> FastWeakBag (Subscriber x a) -> EventM x ()

491−propagateFast a subscribers = withIncreasedDepth (Proxy::Proxy x) $ do

562+propagateFast a subscribers = withIncreasedDepth (Proxy::Proxy x) $

492 -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them

563 -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them

493 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work

564 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work

494− FastWeakBag.traverse subscribers $ \s -> subscriberPropagate s a

565+ FastWeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a

495

566

496--------------------------------------------------------------------------------

567--------------------------------------------------------------------------------

497-- EventSubscribed

568-- EventSubscribed

@@ -536,6 +607,16 @@ eventSubscribedNever = EventSubscribed

536 , eventSubscribedWhoCreated = return ["never"]

607 , eventSubscribedWhoCreated = return ["never"]

537#endif

608#endif

538 }

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

539

620

540eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x

621eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x

541eventSubscribedFan !subscribed = EventSubscribed

622eventSubscribedFan !subscribed = EventSubscribed

@@ -913,8 +994,10 @@ instance Monad (BehaviorM x) where

913 BehaviorM x >> BehaviorM y = BehaviorM $ x >> y

994 BehaviorM x >> BehaviorM y = BehaviorM $ x >> y

914 {-# INLINE return #-}

995 {-# INLINE return #-}

915 return x = BehaviorM $ return x

996 return x = BehaviorM $ return x

997+#if !MIN_VERSION_base(4,13,0)

916 {-# INLINE fail #-}

998 {-# INLINE fail #-}

917 fail s = BehaviorM $ fail s

999 fail s = BehaviorM $ fail s

1000+#endif

918

1001

919data BehaviorSubscribed x a

1002data BehaviorSubscribed x a

920 = forall p. BehaviorSubscribedHold (Hold x p)

1003 = forall p. BehaviorSubscribedHold (Hold x p)

@@ -974,7 +1057,7 @@ data SomeMergeUpdate x = SomeMergeUpdate

974newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }

1057newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }

975

1058

976-- EventM can do everything BehaviorM can, plus create holds

1059-- EventM can do everything BehaviorM can, plus create holds

977−newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException)

1060+newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException)

978

1061

979newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }

1062newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }

980

1063

@@ -999,7 +1082,8 @@ heightBagFromList :: [Height] -> HeightBag

999heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights

1082heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights

1000

1083

1001heightBagAdd :: Height -> HeightBag -> HeightBag

1084heightBagAdd :: Height -> HeightBag -> HeightBag

1002−heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $ IntMap.insertWithKey (\_ _ old -> succ old) h 0 c

1085+heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $

1086+ IntMap.insertWithKey (\_ _ old -> succ old) h 0 c

1003

1087

1004heightBagRemove :: Height -> HeightBag -> HeightBag

1088heightBagRemove :: Height -> HeightBag -> HeightBag

1005heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of

1089heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of

@@ -1008,6 +1092,13 @@ heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.loo

1008 0 -> IntMap.delete h c

1092 0 -> IntMap.delete h c

1009 _ -> IntMap.insert h (pred old) c

1093 _ -> IntMap.insert h (pred old) c

1010

1094

1095+heightBagRemoveMaybe :: Height -> HeightBag -> Maybe HeightBag

1096+heightBagRemoveMaybe (Height h) b@(HeightBag s c) = heightBagVerify . removed <$> IntMap.lookup h c where

1097+ removed old = HeightBag (pred s) $ case old of

1098+ 0 -> IntMap.delete h c

1099+ _ -> IntMap.insert h (pred old) c

1100+

1101+

1011heightBagMax :: HeightBag -> Height

1102heightBagMax :: HeightBag -> Height

1012heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of

1103heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of

1013 Just ((h, _), _) -> Height h

1104 Just ((h, _), _) -> Height h

@@ -1108,7 +1199,10 @@ instance HasSpiderTimeline x => Semialign (Event x) where

1108 align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $

1199 align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $

1109 DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]

1200 DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]

1110

1201

1111−#if defined(MIN_VERSION_semialign)

1202+#ifdef MIN_VERSION_semialign

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

1204+instance HasSpiderTimeline x => Zip (Event x) where

1205+#endif

1112 zip x y = mapMaybe justThese $ align x y

1206 zip x y = mapMaybe justThese $ align x y

1113#endif

1207#endif

1114

1208

@@ -1252,7 +1346,7 @@ mkWeakPtrWithDebug x debugNote = do

1252 x' <- evaluate x

1346 x' <- evaluate x

1253 mkWeakPtr x' $

1347 mkWeakPtr x' $

1254 if debugFinalize

1348 if debugFinalize

1255− then Just $ putStrLn $ "finalizing: " ++ debugNote

1349+ then Just $ debugStrLn $ "finalizing: " ++ debugNote

1256 else Nothing

1350 else Nothing

1257

1351

1258type WeakList a = [Weak a]

1352type WeakList a = [Weak a]

@@ -1265,19 +1359,22 @@ type CanTrace x m = (HasSpiderTimeline x, MonadIO m)

1265#ifdef DEBUG

1359#ifdef DEBUG

1266

1360

1267debugSubscriber :: forall x a. HasSpiderTimeline x => String -> Subscriber x a -> IO (Subscriber x a)

1361debugSubscriber :: forall x a. HasSpiderTimeline x => String -> Subscriber x a -> IO (Subscriber x a)

1268−debugSubscriber description subscribed = return $ Subscriber

1362+debugSubscriber description = return . debugSubscriber' description

1363+

1364+debugSubscriber' :: forall x a. HasSpiderTimeline x => String -> Subscriber x a -> Subscriber x a

1365+debugSubscriber' description subscribed = Subscriber

1269 {

1366 {

1270 subscriberPropagate = \m -> do

1367 subscriberPropagate = \m -> do

1271 tracePropagate (Proxy :: Proxy x) ("subscriberPropagate: " <> description)

1368 tracePropagate (Proxy :: Proxy x) ("subscriberPropagate: " <> description)

1272 subscriberPropagate subscribed m

1369 subscriberPropagate subscribed m

1273 , subscriberInvalidateHeight = \old -> do

1370 , subscriberInvalidateHeight = \old -> do

1274− putStrLn $ "invalidateSubscriberHeight: " <> description

1371+ traceInvalidateHeight $ "invalidateSubscriberHeight: " <> description <> ", old = " <> show (unHeight old)

1275 subscriberInvalidateHeight subscribed old

1372 subscriberInvalidateHeight subscribed old

1276− putStrLn $ "invalidateSubscriberHeight: " <> description <> ", done"

1373+ traceInvalidateHeight $ "invalidateSubscriberHeight: " <> description <> ", done"

1277 , subscriberRecalculateHeight = \new -> do

1374 , subscriberRecalculateHeight = \new -> do

1278− putStrLn $ "subscriberRecalculateHeight: " <> description

1375+ traceInvalidateHeight $ "subscriberRecalculateHeight: " <> description <> ", new = " <> show (unHeight new)

1279 subscriberRecalculateHeight subscribed new

1376 subscriberRecalculateHeight subscribed new

1280− putStrLn $ "subscriberRecalculateHeight: " <> description <> ", done"

1377+ traceInvalidateHeight $ "subscriberRecalculateHeight: " <> description <> ", done"

1281 }

1378 }

1282

1379

1283

1380

@@ -1291,11 +1388,15 @@ withIncreasedDepth _ a = do

1291

1388

1292{-# INLINE tracePropagate #-}

1389{-# INLINE tracePropagate #-}

1293tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()

1390tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()

1294−tracePropagate p = trace p

1391+tracePropagate p = when debugPropagate . trace p

1295

1392

1296{-# INLINE traceInvalidate #-}

1393{-# INLINE traceInvalidate #-}

1297traceInvalidate :: String -> IO ()

1394traceInvalidate :: String -> IO ()

1298−traceInvalidate = liftIO . putStrLn

1395+traceInvalidate = when debugInvalidate . liftIO . debugStrLn

1396+

1397+{-# INLINE traceInvalidateHeight #-}

1398+traceInvalidateHeight :: String -> IO ()

1399+traceInvalidateHeight = when debugInvalidateHeight . liftIO . debugStrLn

1299

1400

1300{-# INLINE trace #-}

1401{-# INLINE trace #-}

1301trace :: (CanTrace x m) => proxy x -> String -> m ()

1402trace :: (CanTrace x m) => proxy x -> String -> m ()

@@ -1306,7 +1407,7 @@ traceM :: forall x proxy m. (CanTrace x m) => proxy x -> m String -> m ()

1306traceM _ getMessage = do

1407traceM _ getMessage = do

1307 message <- getMessage

1408 message <- getMessage

1308 d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)

1409 d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)

1309− liftIO $ putStrLn $ replicate d ' ' <> message

1410+ liftIO $ debugStrLn $ replicate d ' ' <> message

1310

1411

1311#else

1412#else

1312

1413

@@ -1322,10 +1423,20 @@ tracePropagate _ _ = return ()

1322traceInvalidate :: String -> IO ()

1423traceInvalidate :: String -> IO ()

1323traceInvalidate _ = return ()

1424traceInvalidate _ = return ()

1324

1425

1426+{-# INLINE traceInvalidateHeight #-}

1427+traceInvalidateHeight :: String -> IO ()

1428+traceInvalidateHeight _ = return ()

1429+

1325{-# INLINE debugSubscriber #-}

1430{-# INLINE debugSubscriber #-}

1326debugSubscriber :: String -> Subscriber x a -> IO (Subscriber x a)

1431debugSubscriber :: String -> Subscriber x a -> IO (Subscriber x a)

1327debugSubscriber _ = return

1432debugSubscriber _ = return

1328

1433

1434+{-# INLINE debugSubscriber' #-}

1435+debugSubscriber' :: String -> Subscriber x a -> Subscriber x a

1436+debugSubscriber' _ = id

1437+

1438+

1439+

1329{-# INLINE trace #-}

1440{-# INLINE trace #-}

1330trace :: (CanTrace x m) => proxy x -> String -> m ()

1441trace :: (CanTrace x m) => proxy x -> String -> m ()

1331trace _ _ = return ()

1442trace _ _ = return ()

@@ -1336,18 +1447,9 @@ traceM _ _ = return ()

1336

1447

1337#endif

1448#endif

1338

1449

1339−

1340whoCreatedIORef :: IORef a -> IO [String]

1450whoCreatedIORef :: IORef a -> IO [String]

1341whoCreatedIORef (IORef a) = whoCreated $! a

1451whoCreatedIORef (IORef a) = whoCreated $! a

1342

1452

1343−#ifdef DEBUG_CYCLES

1344−

1345−data EventLoopException = EventLoopException (Forest String)

1346−instance Exception EventLoopException

1347−

1348−instance Show EventLoopException where

1349− show (EventLoopException stacks) = "Causality loop detected:\n" <> drawForest stacks

1350−

1351groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]

1453groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]

1352groupByHead = \case

1454groupByHead = \case

1353 [] -> []

1455 [] -> []

@@ -1358,7 +1460,28 @@ groupByHead = \case

1358 | otherwise -> (x, xs :| []) : l

1460 | otherwise -> (x, xs :| []) : l

1359

1461

1360listsToForest :: Eq a => [[a]] -> Forest a

1462listsToForest :: Eq a => [[a]] -> Forest a

1361−listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l

1463+listsToForest lists = buildForest <$> groupByHead (mapMaybe nonEmpty lists)

1464+ where buildForest (a, lists') = Node a $ listsToForest $ toList lists'

1465+

1466+showStacks :: [[String]] -> String

1467+showStacks = drawForest . listsToForest . fmap (filterStack "Reflex.Spider.Internal")

1468+

1469+filterStack :: String -> [String] -> [String]

1470+#ifdef DEBUG_HIDE_INTERNALS

1471+filterStack prefix = filter (not . (prefix `isPrefixOf`))

1472+#else

1473+filterStack prefix = id

1474+#endif

1475+

1476+#ifdef DEBUG_CYCLES

1477+

1478+data EventLoopException = EventLoopException [[String]]

1479+instance Exception EventLoopException

1480+

1481+instance Show EventLoopException where

1482+ show (EventLoopException stacks) = "causality loop detected:\n" <> if null stacks

1483+ then "no location information, compile with profiling enabled for stack tree"

1484+ else showStacks stacks

1362

1485

1363#else

1486#else

1364

1487

@@ -1366,8 +1489,8 @@ data EventLoopException = EventLoopException

1366instance Exception EventLoopException

1489instance Exception EventLoopException

1367

1490

1368instance Show EventLoopException where

1491instance Show EventLoopException where

1369− show EventLoopException = "Causality loop detected: \n" <>

1492+ show EventLoopException = "causality loop detected: \n" <>

1370− "no location information, compile with --enable-profiling and reflex with flag 'debug-cycles'"

1493+ "compile reflex with flag 'debug-cycles' and compile with profiling enabled for stack tree"

1371

1494

1372#endif

1495#endif

1373

1496

@@ -1375,7 +1498,7 @@ instance Show EventLoopException where

1375{-# INLINE propagateSubscriberHold #-}

1498{-# INLINE propagateSubscriberHold #-}

1376propagateSubscriberHold :: 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 ()

1377propagateSubscriberHold h a = do

1500propagateSubscriberHold h a = do

1378− traceM (Proxy :: Proxy x) $ liftIO $ do

1501+ {-# SCC "trace" #-} when debugPropagate $ traceM (Proxy :: Proxy x) $ liftIO $ do

1379 invalidators <- liftIO $ readIORef $ holdInvalidators h

1502 invalidators <- liftIO $ readIORef $ holdInvalidators h

1380 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)

1503 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)

1381

1504

@@ -1383,7 +1506,7 @@ propagateSubscriberHold h a = do

1383 case {-# SCC "apply" #-} apply a v of

1506 case {-# SCC "apply" #-} apply a v of

1384 Nothing -> return ()

1507 Nothing -> return ()

1385 Just v' -> do

1508 Just v' -> do

1386− withIncreasedDepth (Proxy :: Proxy x) $

1509+ {-# SCC "trace2" #-} withIncreasedDepth (Proxy :: Proxy x) $

1387 tracePropagate (Proxy :: Proxy x) ("propagateSubscriberHold: assigning Hold" <> showNodeId h)

1510 tracePropagate (Proxy :: Proxy x) ("propagateSubscriberHold: assigning Hold" <> showNodeId h)

1388 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h

1511 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h

1389 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h

1512 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h

@@ -1504,6 +1627,9 @@ data FanInt x a = FanInt

1504 { _fanInt_subscribers :: {-# UNPACK #-} !(FastMutableIntMap (FastWeakBag (Subscriber x a))) --TODO: Clean up the keys in here when their child weak bags get empty --TODO: Remove our own subscription when the subscribers list is completely empty

1627 { _fanInt_subscribers :: {-# UNPACK #-} !(FastMutableIntMap (FastWeakBag (Subscriber x a))) --TODO: Clean up the keys in here when their child weak bags get empty --TODO: Remove our own subscription when the subscribers list is completely empty

1505 , _fanInt_subscriptionRef :: {-# UNPACK #-} !(IORef (EventSubscription x)) -- This should have a valid subscription iff subscribers is non-empty

1628 , _fanInt_subscriptionRef :: {-# UNPACK #-} !(IORef (EventSubscription x)) -- This should have a valid subscription iff subscribers is non-empty

1506 , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a))

1629 , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a))

1630+#ifdef DEBUG_NODEIDS

1631+ , _fanInt_nodeId :: {-# UNPACK #-} !Int

1632+#endif

1507 }

1633 }

1508

1634

1509newFanInt :: IO (FanInt x a)

1635newFanInt :: IO (FanInt x a)

@@ -1511,10 +1637,16 @@ newFanInt = do

1511 subscribers <- FastMutableIntMap.newEmpty --TODO: Clean up the keys in here when their child weak bags get empty --TODO: Remove our own subscription when the subscribers list is completely empty

1637 subscribers <- FastMutableIntMap.newEmpty --TODO: Clean up the keys in here when their child weak bags get empty --TODO: Remove our own subscription when the subscribers list is completely empty

1512 subscriptionRef <- newIORef $ error "fanInt: no subscription"

1638 subscriptionRef <- newIORef $ error "fanInt: no subscription"

1513 occRef <- newIORef $ error "fanInt: no occurrence"

1639 occRef <- newIORef $ error "fanInt: no occurrence"

1640+#ifdef DEBUG_NODEIDS

1641+ nodeId <- newNodeId

1642+#endif

1514 return $ FanInt

1643 return $ FanInt

1515 { _fanInt_subscribers = subscribers

1644 { _fanInt_subscribers = subscribers

1516 , _fanInt_subscriptionRef = subscriptionRef

1645 , _fanInt_subscriptionRef = subscriptionRef

1517 , _fanInt_occRef = occRef

1646 , _fanInt_occRef = occRef

1647+#ifdef DEBUG_NODEIDS

1648+ , _fanInt_nodeId = nodeId

1649+#endif

1518 }

1650 }

1519

1651

1520fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a

1652fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a

@@ -1523,20 +1655,21 @@ fanInt p = unsafePerformIO $ do

1523 pure $ EventSelectorInt $ \k -> Event $ \sub -> do

1655 pure $ EventSelectorInt $ \k -> Event $ \sub -> do

1524 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)

1656 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)

1525 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input

1657 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input

1658+ let desc = "fanInt" <> showNodeId self <> ", k = " <> show k

1526− (subscription, parentOcc) <- subscribeAndRead p $ Subscriber

1659+ (subscription, parentOcc) <- subscribeAndRead p $ debugSubscriber' desc $ Subscriber

1527 { subscriberPropagate = \m -> do

1660 { subscriberPropagate = \m -> do

1528 liftIO $ writeIORef (_fanInt_occRef self) m

1661 liftIO $ writeIORef (_fanInt_occRef self) m

1529 scheduleIntClear $ _fanInt_occRef self

1662 scheduleIntClear $ _fanInt_occRef self

1530 FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> --TODO: Do we need to know that no subscribers are being added as we traverse?

1663 FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> --TODO: Do we need to know that no subscribers are being added as we traverse?

1531− FastWeakBag.traverse b $ \s ->

1664+ FastWeakBag.traverse_ b $ \s ->

1532 subscriberPropagate s v

1665 subscriberPropagate s v

1533− , subscriberInvalidateHeight = \old ->

1666+ , subscriberInvalidateHeight = \old ->

1534− FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->

1667+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->

1535− FastWeakBag.traverse b $ \s ->

1668+ FastWeakBag.traverse_ b $ \s ->

1536 subscriberInvalidateHeight s old

1669 subscriberInvalidateHeight s old

1537 , subscriberRecalculateHeight = \new ->

1670 , subscriberRecalculateHeight = \new ->

1538− FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->

1671+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->

1539− FastWeakBag.traverse b $ \s ->

1672+ FastWeakBag.traverse_ b $ \s ->

1540 subscriberRecalculateHeight s new

1673 subscriberRecalculateHeight s new

1541 }

1674 }

1542 liftIO $ do

1675 liftIO $ do

@@ -1552,14 +1685,14 @@ fanInt p = unsafePerformIO $ do

1552 Just b -> return b

1685 Just b -> return b

1553 ticket <- liftIO $ FastWeakBag.insert sub b

1686 ticket <- liftIO $ FastWeakBag.insert sub b

1554 currentOcc <- readIORef (_fanInt_occRef self)

1687 currentOcc <- readIORef (_fanInt_occRef self)

1555−

1688+

1556 subscribed <- fanIntSubscribed ticket self

1689 subscribed <- fanIntSubscribed ticket self

1557 return (EventSubscription (FastWeakBag.remove ticket) subscribed, IntMap.lookup k currentOcc)

1690 return (EventSubscription (FastWeakBag.remove ticket) subscribed, IntMap.lookup k currentOcc)

1558

1691

1559fanIntSubscribed :: FastWeakBagTicket k -> FanInt x a -> IO (EventSubscribed x)

1692fanIntSubscribed :: FastWeakBagTicket k -> FanInt x a -> IO (EventSubscribed x)

1560−fanIntSubscribed ticket self = do

1693+fanIntSubscribed ticket self = do

1561 subscribedParent <- _eventSubscription_subscribed <$> readIORef (_fanInt_subscriptionRef self)

1694 subscribedParent <- _eventSubscription_subscribed <$> readIORef (_fanInt_subscriptionRef self)

1562− return $ EventSubscribed

1695+ return $ EventSubscribed

1563 { eventSubscribedHeightRef = eventSubscribedHeightRef subscribedParent

1696 { eventSubscribedHeightRef = eventSubscribedHeightRef subscribedParent

1564 , eventSubscribedRetained = toAny (_fanInt_subscriptionRef self, ticket)

1697 , eventSubscribedRetained = toAny (_fanInt_subscriptionRef self, ticket)

1565#ifdef DEBUG_CYCLES

1698#ifdef DEBUG_CYCLES

@@ -1568,7 +1701,7 @@ fanIntSubscribed ticket self = do

1568 , eventSubscribedWhoCreated = whoCreatedIORef $ _fanInt_subscriptionRef self

1701 , eventSubscribedWhoCreated = whoCreatedIORef $ _fanInt_subscriptionRef self

1569#endif

1702#endif

1570 }

1703 }

1571−

1704+

1572

1705

1573{-# INLINABLE getFanSubscribed #-}

1706{-# INLINABLE getFanSubscribed #-}

1574getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k v -> Subscriber x (v a) -> EventM x (WeakBagTicket, FanSubscribed x k v, Maybe (v a))

1707getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k v -> Subscriber x (v a) -> EventM x (WeakBagTicket, FanSubscribed x k v, Maybe (v a))

@@ -1781,7 +1914,7 @@ mergeCheap nt = mergeGCheap' unMergeSubscribedParent getInitialSubscribers updat

1781 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight

1914 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight

1782 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps

1915 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps

1783 forM_ mOldSubd $ \oldSubd -> do

1916 forM_ mOldSubd $ \oldSubd -> do

1784− oldHeight <- liftIO $ getEventSubscribedHeight $

1917+ oldHeight <- liftIO $ getEventSubscribedHeight $

1785 _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd

1918 _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd

1786

1919

1787 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

1920 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

@@ -1827,7 +1960,7 @@ mergeCheapWithMove nt = mergeGCheap' _mergeSubscribedParentWithMove_subscription

1827 let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a

1960 let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a

1828 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of

1961 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of

1829 Nothing -> do

1962 Nothing -> do

1830− oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $

1963+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $

1831 _mergeSubscribedParentWithMove_subscription parent

1964 _mergeSubscribedParentWithMove_subscription parent

1832

1965

1833 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

1966 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

@@ -1835,7 +1968,7 @@ mergeCheapWithMove nt = mergeGCheap' _mergeSubscribedParentWithMove_subscription

1835 Just toKey -> do

1968 Just toKey -> do

1836 liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey

1969 liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey

1837 return Nothing

1970 return Nothing

1838− toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $

1971+ toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $

1839 DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents

1972 DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents

1840

1973

1841 return (toDelete, applyAlways p' oldParents)

1974 return (toDelete, applyAlways p' oldParents)

@@ -1888,16 +2021,16 @@ invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()

1888invalidateMergeHeight' heightRef sub = do

2021invalidateMergeHeight' heightRef sub = do

1889 oldHeight <- readIORef heightRef

2022 oldHeight <- readIORef heightRef

1890 -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents

2023 -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents

1891− when (oldHeight /= invalidHeight) $ do

2024+ when (oldHeight /= invalidHeight) $ do

1892 writeIORef heightRef $! invalidHeight

2025 writeIORef heightRef $! invalidHeight

1893 subscriberInvalidateHeight sub oldHeight

2026 subscriberInvalidateHeight sub oldHeight

1894

2027

1895revalidateMergeHeight :: Merge x k v s -> IO ()

2028revalidateMergeHeight :: Merge x k v s -> IO ()

1896revalidateMergeHeight m = do

2029revalidateMergeHeight m = do

1897 currentHeight <- readIORef $ _merge_heightRef m

2030 currentHeight <- readIORef $ _merge_heightRef m

1898−

2031+

1899 -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check

2032 -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check

1900− when (currentHeight == invalidHeight) $ do

2033+ when (currentHeight == invalidHeight) $ do

1901 heights <- readIORef $ _merge_heightBagRef m

2034 heights <- readIORef $ _merge_heightBagRef m

1902 parents <- readIORef $ _merge_parentsRef m

2035 parents <- readIORef $ _merge_parentsRef m

1903 -- When the number of heights in the bag reaches the number of parents, we should have a valid height

2036 -- When the number of heights in the bag reaches the number of parents, we should have a valid height

@@ -1905,7 +2038,7 @@ revalidateMergeHeight m = do

1905 LT -> return ()

2038 LT -> return ()

1906 EQ -> do

2039 EQ -> do

1907 let height = succHeight $ heightBagMax heights

2040 let height = succHeight $ heightBagMax heights

1908− traceInvalidate $ "recalculateSubscriberHeight: height: " <> show height

2041+ traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height

1909 writeIORef (_merge_heightRef m) $! height

2042 writeIORef (_merge_heightRef m) $! height

1910 subscriberRecalculateHeight (_merge_sub m) height

2043 subscriberRecalculateHeight (_merge_sub m) height

1911 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"

@@ -1913,32 +2046,35 @@ revalidateMergeHeight m = do

1913scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()

2046scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()

1914scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do

2047scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do

1915 vals <- liftIO $ readIORef $ _merge_accumRef m

2048 vals <- liftIO $ readIORef $ _merge_accumRef m

1916− -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us,

2049+ -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us,

1917 -- it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers

2050 -- it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers

1918− liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty

2051+ liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty

1919 --TODO: Assert that m is not empty

2052 --TODO: Assert that m is not empty

1920 subscriberPropagate (_merge_sub m) vals

2053 subscriberPropagate (_merge_sub m) vals

1921

2054

1922−checkCycle :: HasSpiderTimeline x => EventSubscribed x -> Height -> EventM x ()

2055+checkCycle :: HasSpiderTimeline x => EventSubscribed x -> EventM x ()

1923−checkCycle subscribed height = do

2056+checkCycle subscribed = liftIO $ do

2057+ height <- readIORef (eventSubscribedHeightRef subscribed)

2058+

1924− currentHeight <- getCurrentHeight

2059+ -- currentHeight <- getCurrentHeight

1925− when (height <= currentHeight) $ if height /= invalidHeight

2060+ -- when (height <= currentHeight) $ if height /= invalidHeight

1926− then do

2061+ -- then do

1927− myStack <- liftIO $ whoCreatedIORef undefined --TODO

2062+ -- myStack <- liftIO $ whoCreatedIORef undefined --TODO

1928− error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)

2063+ -- error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)

1929− else liftIO $

2064+ -- else liftIO $

2065+ when (height == invalidHeight) $

1930#ifdef DEBUG_CYCLES

2066#ifdef DEBUG_CYCLES

1931− do

2067+ do

1932− nodesInvolvedInCycle <- walkInvalidHeightParents subscribed

2068+ nodesInvolvedInCycle <- walkInvalidHeightParents subscribed

1933− stacks <- forM nodesInvolvedInCycle whoCreatedEventSubscribed

2069+ stacks <- forM nodesInvolvedInCycle whoCreatedEventSubscribed

1934− throwIO (EventLoopException (listsToForest stacks))

2070+ throwIO (EventLoopException stacks)

1935#else

2071#else

1936− throwIO EventLoopException

2072+ throwIO EventLoopException

1937#endif

2073#endif

1938−

1939

2074

2075+

1940−mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => Merge x k v s -> EventM x (k a) -> Subscriber x (v a)

2076+mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => EventSubscribed x -> Merge x k v s -> EventM x (k a) -> Subscriber x (v a)

1941−mergeSubscriber m getKey = Subscriber

2077+mergeSubscriber subscribed m getKey = Subscriber

1942 { subscriberPropagate = \a -> do

2078 { subscriberPropagate = \a -> do

1943 oldM <- liftIO $ readIORef $ _merge_accumRef m

2079 oldM <- liftIO $ readIORef $ _merge_accumRef m

1944 k <- getKey

2080 k <- getKey

@@ -1947,7 +2083,7 @@ mergeSubscriber m getKey = Subscriber

1947 liftIO $ writeIORef (_merge_accumRef m) $! newM

2083 liftIO $ writeIORef (_merge_accumRef m) $! newM

1948 when (DMap.null oldM) $ do -- Only schedule the firing once

2084 when (DMap.null oldM) $ do -- Only schedule the firing once

1949 height <- liftIO $ readIORef $ _merge_heightRef m

2085 height <- liftIO $ readIORef $ _merge_heightRef m

1950− -- checkCycle (_merge_sub m) height --TODO: assertions about height

2086+ checkCycle subscribed

1951

2087

1952 scheduleMergeSelf m height

2088 scheduleMergeSelf m height

1953 , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating

2089 , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating

@@ -1959,11 +2095,11 @@ mergeSubscriber m getKey = Subscriber

1959 }

2095 }

1960

2096

1961--TODO: Be able to run as much of this as possible promptly

2097--TODO: Be able to run as much of this as possible promptly

1962−updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x

2098+updateMerge :: (HasSpiderTimeline x, GCompare k) => EventSubscribed x -> Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x

1963−updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)

2099+updateMerge subscribed m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)

1964 where updateMe = do

2100 where updateMe = do

1965 oldParents <- liftIO $ readIORef $ _merge_parentsRef m

2101 oldParents <- liftIO $ readIORef $ _merge_parentsRef m

1966− (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber m) (_merge_heightBagRef m) oldParents p

2102+ (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber subscribed m) (_merge_heightBagRef m) oldParents p

1967 liftIO $ writeIORef (_merge_parentsRef m) $! newParents

2103 liftIO $ writeIORef (_merge_parentsRef m) $! newParents

1968 return subscriptionsToKill

2104 return subscriptionsToKill

1969

2105

@@ -1976,14 +2112,28 @@ mergeGCheap' getParent getInitialSubscribers updateFunc destroy d = Event $ \sub

1976 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"

2112 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"

1977 heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"

2113 heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"

1978 parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"

2114 parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"

2115+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"

2116+

2117+ let subscribed = EventSubscribed

2118+ { eventSubscribedHeightRef = heightRef

2119+ , eventSubscribedRetained = toAny (parentsRef, changeSubdRef)

2120+#ifdef DEBUG_CYCLES

2121+ , eventSubscribedGetParents = do

2122+ let getParent' (_ :=> v) = _eventSubscription_subscribed (getParent v)

2123+ fmap getParent' . DMap.toList <$> readIORef parentsRef

2124+ , eventSubscribedHasOwnHeightRef = False

2125+ , eventSubscribedWhoCreated = whoCreatedIORef heightRef

2126+#endif

2127+ }

2128+

1979− let m = Merge

2129+ m = Merge

1980 { _merge_parentsRef = parentsRef

2130 { _merge_parentsRef = parentsRef

1981 , _merge_heightBagRef = heightBagRef

2131 , _merge_heightBagRef = heightBagRef

1982 , _merge_heightRef = heightRef

2132 , _merge_heightRef = heightRef

1983 , _merge_sub = sub

2133 , _merge_sub = sub

1984 , _merge_accumRef = accumRef

2134 , _merge_accumRef = accumRef

1985 }

2135 }

1986− (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber m

2136+ (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber subscribed m

1987 let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights

2137 let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights

1988 myHeight = if invalidHeight `elem` heights

2138 myHeight = if invalidHeight `elem` heights

1989 then invalidHeight

2139 then invalidHeight

@@ -1992,40 +2142,29 @@ mergeGCheap' getParent getInitialSubscribers updateFunc destroy d = Event $ \sub

1992 let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now

2142 let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now

1993 then (if DMap.null dm then Nothing else Just dm, DMap.empty)

2143 then (if DMap.null dm then Nothing else Just dm, DMap.empty)

1994 else (Nothing, dm)

2144 else (Nothing, dm)

1995− unless (DMap.null accum) $ do

1996− scheduleMergeSelf m myHeight

2145+ unless (DMap.null accum) $ scheduleMergeSelf m myHeight

1997 liftIO $ writeIORef accumRef $! accum

2146 liftIO $ writeIORef accumRef $! accum

1998 liftIO $ writeIORef heightRef $! myHeight

2147 liftIO $ writeIORef heightRef $! myHeight

1999 liftIO $ writeIORef heightBagRef $! myHeightBag

2148 liftIO $ writeIORef heightBagRef $! myHeightBag

2000− changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"

2001 liftIO $ writeIORef parentsRef $! initialParentState

2149 liftIO $ writeIORef parentsRef $! initialParentState

2002 defer $ SomeMergeInit $ do

2150 defer $ SomeMergeInit $ do

2003− let s = Subscriber

2151+ let changeSubscriber = Subscriber

2004 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

2152 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

2005− tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change"

2153+ tracePropagate (Proxy :: Proxy x) "SubscriberMerge/Change"

2006− defer $ updateMerge m updateFunc a

2154+ defer $ updateMerge subscribed m updateFunc a

2007 , subscriberInvalidateHeight = \_ -> return ()

2155 , subscriberInvalidateHeight = \_ -> return ()

2008 , subscriberRecalculateHeight = \_ -> return ()

2156 , subscriberRecalculateHeight = \_ -> return ()

2009 }

2157 }

2010− (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s

2158+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) changeSubscriber

2011− forM_ change $ \c -> defer $ updateMerge m updateFunc c

2159+ forM_ change $ \c -> defer $ updateMerge subscribed m updateFunc c

2012 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.

2160 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.

2013 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain

2161 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain

2014 -- its subscription.

2162 -- its subscription.

2015− liftIO $ writeIORef changeSubdRef (s, changeSubscription)

2163+ liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)

2016 let unsubscribeAll = destroy =<< readIORef parentsRef

2164 let unsubscribeAll = destroy =<< readIORef parentsRef

2017− getParent' = \(_ :=> v) -> _eventSubscription_subscribed (getParent v)

2165+

2018− subscribed = EventSubscribed

2019− { eventSubscribedHeightRef = heightRef

2020− , eventSubscribedRetained = toAny (parentsRef, changeSubdRef)

2021−#ifdef DEBUG_CYCLES

2022− , eventSubscribedGetParents = fmap getParent' . DMap.toList <$> readIORef parentsRef

2023− , eventSubscribedHasOwnHeightRef = False

2024− , eventSubscribedWhoCreated = whoCreatedIORef heightRef

2025− }

2026−#endif

2027 return (EventSubscription unsubscribeAll subscribed, occ)

2166 return (EventSubscription unsubscribeAll subscribed, occ)

2028−

2167+

2029

2168

2030mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)

2169mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)

2031mergeInt = cacheEvent . mergeIntCheap

2170mergeInt = cacheEvent . mergeIntCheap

@@ -2038,13 +2177,22 @@ mergeIntCheap d = Event $ \sub -> do

2038 heightRef <- liftIO $ newIORef zeroHeight

2177 heightRef <- liftIO $ newIORef zeroHeight

2039 heightBagRef <- liftIO $ newIORef heightBagEmpty

2178 heightBagRef <- liftIO $ newIORef heightBagEmpty

2040 parents <- liftIO $ FastMutableIntMap.newEmpty

2179 parents <- liftIO $ FastMutableIntMap.newEmpty

2180+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"

2181+ let subscribed = EventSubscribed

2182+ { eventSubscribedHeightRef = heightRef

2183+ , eventSubscribedRetained = toAny (parents, changeSubdRef)

2184+#ifdef DEBUG_CYCLES

2185+ , eventSubscribedGetParents = fmap (_eventSubscription_subscribed . snd) <$> FastMutableIntMap.toList parents

2186+ , eventSubscribedHasOwnHeightRef = False

2187+ , eventSubscribedWhoCreated = whoCreatedIORef heightRef

2188+#endif

2189+ }

2041 let scheduleSelf = do

2190 let scheduleSelf = do

2042 height <- liftIO $ readIORef $ heightRef

2191 height <- liftIO $ readIORef $ heightRef

2043 scheduleMerge' height heightRef $ do

2192 scheduleMerge' height heightRef $ do

2044 vals <- liftIO $ FastMutableIntMap.getFrozenAndClear accum

2193 vals <- liftIO $ FastMutableIntMap.getFrozenAndClear accum

2045 subscriberPropagate sub vals

2194 subscriberPropagate sub vals

2046− invalidateMyHeight = do

2047− invalidateMergeHeight' heightRef sub

2195+ invalidateMyHeight = invalidateMergeHeight' heightRef sub

2048 recalculateMyHeight = do

2196 recalculateMyHeight = do

2049 currentHeight <- readIORef heightRef

2197 currentHeight <- readIORef heightRef

2050 when (currentHeight == invalidHeight) $ do --TODO: This will almost always be true; can we get rid of this check and just proceed to the next one always?

2198 when (currentHeight == invalidHeight) $ do --TODO: This will almost always be true; can we get rid of this check and just proceed to the next one always?

@@ -2054,14 +2202,14 @@ mergeIntCheap d = Event $ \sub -> do

2054 LT -> return ()

2202 LT -> return ()

2055 EQ -> do

2203 EQ -> do

2056 let height = succHeight $ heightBagMax heights

2204 let height = succHeight $ heightBagMax heights

2057− traceInvalidate $ "recalculateSubscriberHeight: height: " <> show height

2205+ traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height

2058 writeIORef heightRef $! height

2206 writeIORef heightRef $! height

2059 subscriberRecalculateHeight sub height

2207 subscriberRecalculateHeight sub height

2060 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"

2061 mySubscriber k = Subscriber

2209 mySubscriber k = Subscriber

2062 { subscriberPropagate = \a -> do

2210 { subscriberPropagate = \a -> do

2063− -- liftIO (readIORef heightRef) >>= checkCycle

2211+ checkCycle subscribed

2064−

2212+

2065 wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum

2213 wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum

2066 liftIO $ FastMutableIntMap.insert accum k a

2214 liftIO $ FastMutableIntMap.insert accum k a

2067 when wasEmpty scheduleSelf

2215 when wasEmpty scheduleSelf

@@ -2095,7 +2243,6 @@ mergeIntCheap d = Event $ \sub -> do

2095 else liftIO $ Just <$> FastMutableIntMap.getFrozenAndClear accum

2243 else liftIO $ Just <$> FastMutableIntMap.getFrozenAndClear accum

2096 else do when (not isEmpty) scheduleSelf -- We have things accumulated, but we shouldn't have fired them yet

2244 else do when (not isEmpty) scheduleSelf -- We have things accumulated, but we shouldn't have fired them yet

2097 return Nothing

2245 return Nothing

2098− changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"

2099 defer $ SomeMergeInit $ do

2246 defer $ SomeMergeInit $ do

2100 let updateMe a = SomeMergeUpdate u invalidateMyHeight recalculateMyHeight

2247 let updateMe a = SomeMergeUpdate u invalidateMyHeight recalculateMyHeight

2101 where

2248 where

@@ -2109,31 +2256,25 @@ mergeIntCheap d = Event $ \sub -> do

2109 oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions

2256 oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions

2110 liftIO $ for_ oldParents $ \oldParent -> do

2257 liftIO $ for_ oldParents $ \oldParent -> do

2111 oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent

2258 oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent

2259+

2260+ print ("updateMe", oldParentHeight)

2112 modifyIORef' heightBagRef $ heightBagRemove oldParentHeight

2261 modifyIORef' heightBagRef $ heightBagRemove oldParentHeight

2113 return $ IntMap.elems oldParents

2262 return $ IntMap.elems oldParents

2114− let s = Subscriber

2263+ let changeSubscriber = Subscriber

2115 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

2264 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

2116 tracePropagate (Proxy :: Proxy x) $ "SubscriberMergeInt/Change"

2265 tracePropagate (Proxy :: Proxy x) $ "SubscriberMergeInt/Change"

2117 defer $ updateMe a

2266 defer $ updateMe a

2118 , subscriberInvalidateHeight = \_ -> return ()

2267 , subscriberInvalidateHeight = \_ -> return ()

2119 , subscriberRecalculateHeight = \_ -> return ()

2268 , subscriberRecalculateHeight = \_ -> return ()

2120 }

2269 }

2121− (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s

2270+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) changeSubscriber

2122 forM_ change $ \c -> defer $ updateMe c

2271 forM_ change $ \c -> defer $ updateMe c

2123 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.

2272 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.

2124 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain

2273 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain

2125 -- its subscription.

2274 -- its subscription.

2126− liftIO $ writeIORef changeSubdRef (s, changeSubscription)

2275+ liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)

2127 let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents

2276 let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents

2128− subscribed = EventSubscribed

2277+

2129− { eventSubscribedHeightRef = heightRef

2130− , eventSubscribedRetained = toAny (parents, changeSubdRef)

2131−#ifdef DEBUG_CYCLES

2132− , eventSubscribedGetParents = fmap (_eventSubscription_subscribed . snd) <$> FastMutableIntMap.toList parents

2133− , eventSubscribedHasOwnHeightRef = False

2134− , eventSubscribedWhoCreated = whoCreatedIORef heightRef

2135− }

2136−#endif

2137

2278

2138 return (EventSubscription unsubscribeAll subscribed, occ)

2279 return (EventSubscription unsubscribeAll subscribed, occ)

2139

2280

@@ -2244,7 +2385,7 @@ runFrame a = SpiderHost $ do

2244 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

2245 {-

2386 {-

2246 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)

2387 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)

2247− liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of

2388+ liftIO $ debugStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of

2248 EventRoot _ -> "EventRoot"

2389 EventRoot _ -> "EventRoot"

2249 EventNever -> "EventNever"

2390 EventNever -> "EventNever"

2250 _ -> "something else"

2391 _ -> "something else"

@@ -2259,7 +2400,7 @@ runFrame a = SpiderHost $ do

2259 myHeight <- readIORef $ switchSubscribedHeight subscribed

2400 myHeight <- readIORef $ switchSubscribedHeight subscribed

2260 when (parentHeight /= myHeight) $ do

2401 when (parentHeight /= myHeight) $ do

2261 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight

2402 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight

2262− WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight

2403+ WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight

2263 mapM_ _someMergeUpdate_invalidateHeight mergeUpdates --TODO: In addition to when the patch is completely empty, we should also not run this if it has some Nothing values, but none of them have actually had any effect; potentially, we could even check for Just values with no effect (e.g. by comparing their IORefs and ignoring them if they are unchanged); actually, we could just check if the new height is different

2404 mapM_ _someMergeUpdate_invalidateHeight mergeUpdates --TODO: In addition to when the patch is completely empty, we should also not run this if it has some Nothing values, but none of them have actually had any effect; potentially, we could even check for Just values with no effect (e.g. by comparing their IORefs and ignoring them if they are unchanged); actually, we could just check if the new height is different

2264 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do

2405 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do

2265 unsubscribe subscription

2406 unsubscribe subscription

@@ -2300,7 +2441,7 @@ invalidateCoincidenceHeight subscribed = do

2300 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed

2441 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed

2301 when (oldHeight /= invalidHeight) $ do

2442 when (oldHeight /= invalidHeight) $ do

2302 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight

2443 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight

2303− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

2444+ WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

2304

2445

2305updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()

2446updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()

2306updateSwitchHeight new subscribed = do

2447updateSwitchHeight new subscribed = do

@@ -2308,7 +2449,7 @@ updateSwitchHeight new subscribed = do

2308 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion

2449 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion

2309 when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion

2450 when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion

2310 writeIORef (switchSubscribedHeight subscribed) $! new

2451 writeIORef (switchSubscribedHeight subscribed) $! new

2311− WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new

2452+ WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new

2312

2453

2313recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()

2454recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()

2314recalculateCoincidenceHeight subscribed = do

2455recalculateCoincidenceHeight subscribed = do

@@ -2317,7 +2458,7 @@ recalculateCoincidenceHeight subscribed = do

2317 height <- calculateCoincidenceHeight subscribed

2458 height <- calculateCoincidenceHeight subscribed

2318 when (height /= invalidHeight) $ do

2459 when (height /= invalidHeight) $ do

2319 writeIORef (coincidenceSubscribedHeight subscribed) $! height

2460 writeIORef (coincidenceSubscribedHeight subscribed) $! height

2320− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height

2461+ WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height

2321

2462

2322calculateSwitchHeight :: SwitchSubscribed x a -> IO Height

2463calculateSwitchHeight :: SwitchSubscribed x a -> IO Height

2323calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)

2464calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)

@@ -2379,6 +2520,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Event

2379 {-# INLINABLE headE #-}

2520 {-# INLINABLE headE #-}

2380 headE = R.slowHeadE

2521 headE = R.slowHeadE

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

2382

2525

2383instance Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where

2526instance Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where

2384 {-# INLINABLE sample #-}

2527 {-# INLINABLE sample #-}

@@ -2400,6 +2543,9 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide

2400 {-# INLINABLE headE #-}

2543 {-# INLINABLE headE #-}

2401 headE = R.slowHeadE

2544 headE = R.slowHeadE

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

2403

2549

2404instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where

2550instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where

2405 {-# INLINE return #-}

2551 {-# INLINE return #-}

@@ -2408,8 +2554,10 @@ instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x))

2408 x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x

2554 x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x

2409 {-# INLINE (>>) #-}

2555 {-# INLINE (>>) #-}

2410 (>>) = (*>)

2556 (>>) = (*>)

2557+#if !MIN_VERSION_base(4,13,0)

2411 {-# INLINE fail #-}

2558 {-# INLINE fail #-}

2412 fail _ = error "Dynamic does not support 'fail'"

2559 fail _ = error "Dynamic does not support 'fail'"

2560+#endif

2413

2561

2414{-# INLINABLE newJoinDyn #-}

2562{-# INLINABLE newJoinDyn #-}

2415newJoinDyn :: HasSpiderTimeline x => DynamicS x (Identity (DynamicS x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)

2563newJoinDyn :: HasSpiderTimeline x => DynamicS x (Identity (DynamicS x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)

@@ -2461,6 +2609,9 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide

2461 buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e

2609 buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e

2462 {-# INLINABLE headE #-}

2610 {-# INLINABLE headE #-}

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

2464

2615

2465instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where

2616instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where

2466 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

@@ -2477,6 +2628,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide

2477 {-# INLINABLE headE #-}

2628 {-# INLINABLE headE #-}

2478 headE = R.slowHeadE

2629 headE = R.slowHeadE

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

2480

2633

2481instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where

2634instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where

2482 {-# INLINABLE sample #-}

2635 {-# INLINABLE sample #-}

@@ -2497,6 +2650,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Refle

2497 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

2498 {-# INLINABLE headE #-}

2651 {-# INLINABLE headE #-}

2499 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

2500

2655

2501--------------------------------------------------------------------------------

2656--------------------------------------------------------------------------------

2502-- Deprecated items

2657-- Deprecated items

@@ -2620,7 +2775,7 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2620 fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))

2775 fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))

2621 {-# INLINABLE mergeG #-}

2776 {-# INLINABLE mergeG #-}

2622 mergeG

2777 mergeG

2623− :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k

2778+ :: forall k2 (k :: k2 -> *) q (v :: k2 -> *). GCompare k

2624 => (forall a. q a -> R.Event (SpiderTimeline x) (v a))

2779 => (forall a. q a -> R.Event (SpiderTimeline x) (v a))

2625 -> DMap k q

2780 -> DMap k q

2626 -> R.Event (SpiderTimeline x) (DMap k v)

2781 -> R.Event (SpiderTimeline x) (DMap k v)

@@ -2688,8 +2843,14 @@ instance Monad (SpiderHost x) where

2688 SpiderHost x >> SpiderHost y = SpiderHost $ x >> y

2843 SpiderHost x >> SpiderHost y = SpiderHost $ x >> y

2689 {-# INLINABLE return #-}

2844 {-# INLINABLE return #-}

2690 return x = SpiderHost $ return x

2845 return x = SpiderHost $ return x

2846+#if !MIN_VERSION_base(4,13,0)

2847+ {-# INLINABLE fail #-}

2848+ fail = MonadFail.fail

2849+#endif

2850+

2851+instance MonadFail (SpiderHost x) where

2691 {-# INLINABLE fail #-}

2852 {-# INLINABLE fail #-}

2692− fail s = SpiderHost $ fail s

2853+ fail s = SpiderHost $ MonadFail.fail s

2693

2854

2694-- | Run an action affecting the global Spider timeline; this will be guarded by

2855-- | Run an action affecting the global Spider timeline; this will be guarded by

2695-- a mutex for that timeline

2856-- a mutex for that timeline

@@ -2711,8 +2872,10 @@ instance Monad (SpiderHostFrame x) where

2711 SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y

2872 SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y

2712 {-# INLINABLE return #-}

2873 {-# INLINABLE return #-}

2713 return x = SpiderHostFrame $ return x

2874 return x = SpiderHostFrame $ return x

2875+#if !MIN_VERSION_base(4,13,0)

2714 {-# INLINABLE fail #-}

2876 {-# INLINABLE fail #-}

2715 fail s = SpiderHostFrame $ fail s

2877 fail s = SpiderHostFrame $ fail s

2878+#endif

2716

2879

2717instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where

2880instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where

2718 notReadyUntil _ = pure ()

2881 notReadyUntil _ = pure ()

@@ -2757,3 +2920,11 @@ instance MonadAtomicRef (SpiderHostFrame x) where

2757instance PrimMonad (SpiderHostFrame x) where

2920instance PrimMonad (SpiderHostFrame x) where

2758 type PrimState (SpiderHostFrame x) = PrimState IO

2921 type PrimState (SpiderHostFrame x) = PrimState IO

2759 primitive = SpiderHostFrame . EventM . primitive

2922 primitive = SpiderHostFrame . EventM . primitive

2923+

2924+instance NotReady (SpiderTimeline x) (SpiderHost x) where

2925+ notReadyUntil _ = return ()

2926+ notReady = return ()

2927+

2928+instance HasSpiderTimeline x => NotReady (SpiderTimeline x) (PerformEventT (SpiderTimeline x) (SpiderHost x)) where

2929+ notReadyUntil _ = return ()

2930+ notReady = return ()

src/Reflex/TriggerEvent/Base.hs+2

@@ -122,6 +122,8 @@ instance MonadHold t m => MonadHold t (TriggerEventT t m) where

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

src/Reflex/Workflow.hs+1−1

@@ -34,7 +34,7 @@ workflow w0 = do

34 rec eResult <- networkHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult

35 return $ fmap fst eResult

37−-- | Similar to 'workflow', but outputs an 'Event' that fires whenever the current 'Workflow' is replaced by the next 'Workflow'.

37+-- | Similar to 'workflow', but outputs an 'Event' that fires at post-build time and whenever the current 'Workflow' is replaced by the next 'Workflow'.

38workflowView :: forall t m a. (Reflex t, NotReady t m, Adjustable t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a)

39workflowView w0 = do

40 rec eResult <- networkView . fmap unWorkflow =<< holdDyn w0 eReplace

test/Adjustable.hsnew file+62

@@ -0,0 +1,62 @@

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE LambdaCase #-}

3+{-# LANGUAGE RankNTypes #-}

4+{-# LANGUAGE RecursiveDo #-}

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/DebugCycles.hs+91−64

@@ -15,38 +15,33 @@ import Control.Applicative

15import Control.Monad

16import Control.Monad.Fix

17import Control.Exception

18−

19import System.Timeout

18import System.Timeout

20−

21import Data.Maybe (isJust)

19import Data.Maybe (isJust)

22import Data.Functor.Misc

20import Data.Functor.Misc

23import qualified Data.Map as Map

21import qualified Data.Map as Map

24import Data.Map (Map)

22import Data.Map (Map)

25−

23+import qualified Data.IntMap as IntMap

24+import Data.IntMap (IntMap)

26import Data.These

25import Data.These

27import Data.Align

26import Data.Align

28−

29import Reflex

27import Reflex

30import Reflex.EventWriter.Base

28import Reflex.EventWriter.Base

31import Test.Run

29import Test.Run

32−

30+import Test.Hspec

33import Reflex.Spider.Internal (EventLoopException)

31import Reflex.Spider.Internal (EventLoopException)

34−

35−

36import Data.Witherable (Filterable)

32import Data.Witherable (Filterable)

38#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))

34#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))

39import Data.These.Lens

35import Data.These.Lens

40#endif

36#endif

42−type Widget t m = (MonadHold t m, Reflex t, MonadFix m)

38+type Widget t m = (MonadHold t m, Reflex t, MonadFix m)

44−connectDyn ::Widget t m => Event t () -> (Dynamic t a, Dynamic t a) -> m (Dynamic t a)

40+connectDyn :: Widget t m => Event t () -> (Dynamic t a, Dynamic t a) -> m (Dynamic t a)

45−connectDyn e (d, d') = do

41+connectDyn e (d, d') = do

46 dd <- holdDyn d (d' <$ e)

42 dd <- holdDyn d (d' <$ e)

47 return $ join dd

43 return $ join dd

49−

50dynLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

45dynLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

51dynLoop (e1, e2) = do

46dynLoop (e1, e2) = do

52 -- "heightBagRemove: Height 2 not present in bag HeightBag {_heightBag_size = 2, _heightBag_contents = fromList [(0,1)]}"

47 -- "heightBagRemove: Height 2 not present in bag HeightBag {_heightBag_size = 2, _heightBag_contents = fromList [(0,1)]}"

@@ -55,6 +50,31 @@ dynLoop (e1, e2) = do

55 d' <- connectDyn e2 (d, liftA2 (+) d d')

50 d' <- connectDyn e2 (d, liftA2 (+) d d')

56 return $ updated d'

51 return $ updated d'

53+connectOnCoincidence :: Widget t m => Event t () -> Event t a -> m (Event t a)

54+connectOnCoincidence click e = do

55+ d <- holdDyn never (e <$ click)

56+ return $ coincidence (updated d)

57+

58+coincidenceLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

59+coincidenceLoop (e1, e2) = do

60+-- "heightBagRemove: Height 1 not present in bag HeightBag {_heightBag_size = 1, _heightBag_contents = fromList [(0,0)]}"

61+-- (simpler version of dynLoop)

62+ rec

63+ e' <- connectOnCoincidence e2 (updated d)

64+ d <- count (align e' e1)

65+ return $ updated d

66+

67+addHeight :: Reflex t => Event t a -> Event t a

68+addHeight e = leftmost [e4, e4] where

69+ e1 = leftmost [e, e]

70+ e2 = leftmost [e1, e1]

71+ e3 = leftmost [e2, e2]

72+ e4 = leftmost [e3, e3]

73+

74+-- Take an existing test and build it inside a

75+buildLoop :: Widget t m => (forall t m. Widget t m => (Event t Int, Event t ()) -> m (Event t Int)) -> (Event t Int, Event t ()) -> m (Event t Int)

76+buildLoop test (e1, e2) = switchHold never buildLoop

77+ where buildLoop = pushAlways (const $ test (e1, e2)) e2

59connectButtonPromptly :: Widget t m => Event t () -> Event t a -> m (Event t a)

79connectButtonPromptly :: Widget t m => Event t () -> Event t a -> m (Event t a)

60connectButtonPromptly click e = do

80connectButtonPromptly click e = do

@@ -66,79 +86,86 @@ connectButton click e = do

66 d <- hold never (e <$ click)

86 d <- hold never (e <$ click)

67 return (switch d)

87 return (switch d)

69−

70−switchLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

89+switchLoop01 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

71−switchLoop (e1, e2) = do

90+switchLoop01 (e1, e2) = do

72 rec

91 rec

73 e' <- connectButton e2 (updated d)

92 e' <- connectButton e2 (updated d)

74 d <- count (align e' e1)

93 d <- count (align e' e1)

75 return $ updated d

94 return $ updated d

96+mergeLoop :: forall t m. (Adjustable t m, Widget t m) => (Event t Int, Event t ()) -> m (Event t Int)

97+mergeLoop (e1, e2) = do

98+ rec

99+ (_, e) <- runEventWriterT $

100+ runWithReplace w (leftmost [w <$ e1])

101+ return (sum <$> e)

102+ where

103+ w = do

104+ c <- count e1

105+ tellEvent (updated ((pure <$> c) :: Dynamic t [Int]))

106+

77−switchLoop' :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

107+switchLoop02 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

78−switchLoop' (e1, e2) = do

108+switchLoop02 (e1, e2) = do

79 rec

109 rec

80 e' <- connectButton e2 (updated d)

110 e' <- connectButton e2 (updated d)

81 d <- count (leftmost [e', e1])

111 d <- count (leftmost [e', e1])

82− return $ updated d

112+ return $ updated d

113+

114+switchLoop03 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

115+switchLoop03 (e1, e2) = do

116+ rec

117+ e' <- connectButton e2 (addHeight $ updated d)

118+ d <- count (align e' e1)

119+ return $ updated d

120

84−staticLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

121+staticLoop01 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

85−staticLoop (e1, e2) = do

122+staticLoop01 (e1, e2) = do

86 rec

123 rec

87 d <- foldDyn (+) (0 :: Int) (1 <$ align e1 (updated d))

124 d <- foldDyn (+) (0 :: Int) (1 <$ align e1 (updated d))

88 return $ updated d

125 return $ updated d

126

90−staticLoop' :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

127+staticLoop02 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

91−staticLoop' (e1, e2) = do

128+staticLoop02 (e1, e2) = do

92 rec

129 rec

93 d <- foldDyn (+) (0 :: Int) (leftmost [e1, updated d])

130 d <- foldDyn (+) (0 :: Int) (leftmost [e1, updated d])

94− return $ updated d

131+ return $ updated d

95−

132

97buildStaticLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

133buildStaticLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

98buildStaticLoop (e1, e2) = switchHold never buildLoop

134buildStaticLoop (e1, e2) = switchHold never buildLoop

99− where buildLoop = pushAlways (const $ staticLoop (e1, e2)) e2

135+ where buildLoop = pushAlways (const $ staticLoop01 (e1, e2)) e2

100

136

101splitThese :: Filterable f => f (These a b) -> (f a, f b)

137splitThese :: Filterable f => f (These a b) -> (f a, f b)

102splitThese f = (mapMaybe (preview here) f, mapMaybe (preview there) f)

138splitThese f = (mapMaybe (preview here) f, mapMaybe (preview there) f)

103

139

104−pattern RunTestCaseFlag = "--run-test"

105−

106−runTest :: (String, TestCase) -> IO ()

107−runTest (name, TestCase test) = do

108− mError <- timeout (milliseconds 5) $

109− run `catch` \(e :: EventLoopException) -> pure (show e)

110−

111− unless (isJust mError) $

112− error $ name <> ": timed out (loop not detected)"

113−

114− where

115−

116− run = runApp' (test . splitThese) (Just <$> occs)

117− >> error (name <> ": unexpected success")

118−

119− occs = [ This 1, This 2, That (), This 3 ]

120−

121− milliseconds = (*1000)

122−

123−

124−newtype TestCase = TestCase { unTest :: forall t m. Widget t m => (Event t Int, Event t ()) -> m (Event t Int) }

125−

126−tests :: [(String, TestCase)]

127−tests =

128− [

129− -- ("switchLoop'", TestCase switchLoop')

130− -- , ("switchLoop", TestCase switchLoop)

131− -- ("staticLoop'", TestCase staticLoop')

132− -- ("staticLoop", TestCase staticLoop)

133− ("buildStaticLoop", TestCase buildStaticLoop)

134− -- , ("dynLoop", TestCase dynLoop)

135− ]

136−

137main :: IO ()

140main :: IO ()

138−main = traverse_ runTest tests

141+main = hspec $ do

139−

142+ describe "DebugCycles" $ do

140−

143+ it "throws EventLoopException on switchLoop01" $ do

141−

144+ check switchLoop01

142−

145+ it "throws EventLoopException on switchLoop02" $ do

143−

146+ check switchLoop02

144−

147+ it "throws EventLoopException on switchLoop03" $ do

148+ check switchLoop03

149+ it "throws EventLoopException on buildSwitchLoop" $ do

150+ check $ buildLoop switchLoop01

151+ xit "throws EventLoopException on mergeLoop" $ do

152+ check mergeLoop

153+ xit "throws EventLoopException on staticLoop01" $ do

154+ check staticLoop01

155+ xit "throws EventLoopException on staticLoop02" $ do

156+ check staticLoop02

157+ xit "throws EventLoopException on buildStaticLoop" $ do

158+ check buildStaticLoop

159+ xit "throws EventLoopException on coincidenceLoop" $ do

160+ check coincidenceLoop

161+ xit "throws EventLoopException on dynLoop" $ do

162+ check dynLoop

163+ xit "throws EventLoopException on buildCoincidenceLoop" $ do

164+ check $ buildLoop coincidenceLoop

165+ where

166+ milliseconds = (*1000)

167+ occs = [ This 1, This 2, That (), This 3, That (), This 1 ]

168+ check test = do

169+ let action = timeout (milliseconds 50) $ do

170+ runApp' (test . splitThese) (Just <$> occs)

171+ action `shouldThrow` (const True :: Selector EventLoopException)

test/GC.hs+2−2

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

@@ -83,7 +84,6 @@ hostPerf ref = S.runSpiderHost $ do

83 Nothing -> []

84 Nothing -> []

84 Host.fireEventsAndRead followupEventTriggers $ return ()

85 Host.fireEventsAndRead followupEventTriggers $ return ()

85 return ()

86 return ()

86− return ()

88data Tell a where

89 Action :: Tell ()

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/Bench/Focused.hs+1−1

@@ -134,7 +134,7 @@ holdDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynami

134holdDynChain = iterM (\d -> sample (current d) >>= flip holdDyn (updated d))

135

136buildDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

137−buildDynChain = iterM (\d -> do

137+buildDynChain = iterM (\d -> do

138 let b = fmap (+1) (current d)

139 e = fmap (*2) (updated d)

140 buildDynamic (sample b) e)

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−8

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

@@ -30,16 +31,9 @@ main = do

30 ]

31 ]

31 matchFile = and <$> sequence

32 matchFile = and <$> sequence

32 [ extension ==? ".hs"

33 [ extension ==? ".hs"

33− , let notElem' = liftOp notElem

34− in filePath `notElem'` filePathExceptions pwd

35 ]

34 ]

36 files <- find recurseInto matchFile (pwd </> "src") --TODO: Someday fix all hints in tests, etc.

35 files <- find recurseInto matchFile (pwd </> "src") --TODO: Someday fix all hints in tests, etc.

37 ideas <- fmap concat $ forM files $ \f -> do

36 ideas <- fmap concat $ forM files $ \f -> do

38 putStr $ "linting file " ++ drop (length pwd + 1) f ++ "... "

37 putStr $ "linting file " ++ drop (length pwd + 1) f ++ "... "

39 runHlint f

38 runHlint f

40 if null ideas then exitSuccess else exitFailure

39 if null ideas then exitSuccess else exitFailure

41−

42−filePathExceptions :: FilePath -> [FilePath]

43−filePathExceptions pwd = map (pwd </>) $

44− [ "src/Data/AppendMap.hs" -- parse error when hlint runs

45− ]