9a63788...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−178

@@ -1,178 +0,0 @@

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

2−#

3−# haskell-ci '--config=cabal.haskell-ci' 'cabal.project'

4−#

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

6−#

7−# version: 0.3.20190804.2

8−#

9−language: c

10−dist: bionic

11−sudo: required

12−git:

13− # whether to recursively clone submodules

14− submodules: false

15−cache:

16− directories:

17− - $HOME/.cabal/packages

18− - $HOME/.cabal/store

19−before_cache:

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

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

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

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

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

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

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

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

28−matrix:

29− include:

30− - compiler: ghcjs-8.4

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

32− - compiler: ghc-8.6.5

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

34− - compiler: ghc-8.4.4

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

36− - compiler: ghc-8.2.2

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

38− - compiler: ghc-8.0.2

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

40−before_install:

41− - |

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

43− sudo add-apt-repository -y ppa:hvr/ghc;

44− sudo add-apt-repository -y ppa:hvr/ghcjs;

45− sudo apt-get update;

46− sudo apt-get install $CC cabal-install-3.0;

47− fi

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

49− - WITHCOMPILER="-w $HC"

50− - |

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

52− GHCJS=true

53− HC=${HC}js

54− WITHCOMPILER="--ghcjs ${WITHCOMPILER}js"

55− else

56− GHCJS=false;

57− fi

58− - if $GHCJS ; then sudo apt-get install -y ghc-8.6.5 ; fi

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

60− - HCPKG="$HC-pkg"

61− - unset CC

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

63− - CABALHOME=$HOME/.cabal

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

65− - TOP=$(pwd)

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

67− - echo $HCNUMVER

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

69− - set -o pipefail

70− - |

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

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

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

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

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

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

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

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

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

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

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

82− - cat .colorful.awk

83− - |

84− color_cabal_output () {

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

86− }

87− - echo text | color_cabal_output

88−install:

89− - ${CABAL} --version

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

91− - node --version

92− - echo $GHCJS

93− - TEST=--enable-tests

94− - BENCH=--enable-benchmarks

95− - HEADHACKAGE=false

96− - rm -f $CABALHOME/config

97− - |

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

113− - cat $CABALHOME/config

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

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

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

117− # Generate cabal.project

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

119− - touch cabal.project

120− - |

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

122− - |

123− echo "source-repository-package" >> cabal.project

124− echo " type: git" >> cabal.project

125− echo " location: https://github.com/phadej/monoidal-containers.git" >> cabal.project

126− echo " tag: f8860ba08385f77128efb45fb9193e6d287e893f" >> cabal.project

127− - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(reflex)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"

128− - cat cabal.project || true

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

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

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

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

133− - rm cabal.project.freeze

134−script:

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

136− # Packaging...

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

138− # Unpacking...

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

140− - cd ${DISTDIR} || false

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

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

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

144− # Generate cabal.project

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

146− - touch cabal.project

147− - |

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

149− - |

150− echo "source-repository-package" >> cabal.project

151− echo " type: git" >> cabal.project

152− echo " location: https://github.com/phadej/monoidal-containers.git" >> cabal.project

153− echo " tag: f8860ba08385f77128efb45fb9193e6d287e893f" >> cabal.project

154− - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(reflex)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done"

155− - cat cabal.project || true

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

157− # Building...

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

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

160− # Building with tests and benchmarks...

161− # build & run tests, build benchmarks

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

163− # Testing...

164− - if ! $GHCJS && [ $HCNUMVER -ge 80000 ] && [ $HCNUMVER -lt 80606 ] ; then ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi

165− # cabal check...

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

167− # haddock...

168− - if ! $GHCJS && [ $HCNUMVER -ge 80000 ] && [ $HCNUMVER -lt 80606 ] ; then ${CABAL} v2-haddock $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi

169− # Building without installed constraints for packages in global-db...

170− - rm -f cabal.project.local

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

172− # Constraint sets

173− - rm -rf cabal.project.local

174− # Constraint set no-th

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

176−

177−# REGENDATA ["--config=cabal.haskell-ci","cabal.project"]

178−# EOF

CONTRIBUTING.md+4

@@ -45,6 +45,10 @@ Your pull request should add no new warnings to the project. It should also gene

46Make sure the project builds and that the tests pass! This will generally also be checked by CI before merge, but trying it yourself first means you'll catch problems earlier and your contribution can be merged that much sooner!

48+#### Dependencies

49+

50+Include version bounds whenever adding a dependency to the library stanza of the cabal file. Note that libraries added to reflex.cabal also need to be added to default.nix.

51+

48### Documentation

52### Documentation

50#### In the code

54#### In the code

ChangeLog.md+121−6

@@ -1,36 +1,151 @@

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+

93+## 0.6.2.2

94+

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

96+

97+* Update version bounds to fix some CI failures

98+

99+* Add travis CI configuration

100+

3## 0.6.2.1

101## 0.6.2.1

102

5* Generalize `fan` to `fanG` to take a `DMap` with non-`Identity`

103* Generalize `fan` to `fanG` to take a `DMap` with non-`Identity`

6− values.

104+ functor:

105+ * `fan` to `fanG`

106+ * `EventSelectorG` for `fanG` result selector.

107+

108+* Reduce the amount of unsafeCoerce in coercing newtypes under Event/Dynamic/Behavior.

109+ * Add fused ReaderIO for the purpose of coercion (ReaderT's third argument has nominal role preventing automated coerce)

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

111

8* Generalize merging functions:

112* Generalize merging functions:

9− `merge` to `mergeG`,

113+ `merge` to `mergeG`,

10− `mergeIncremental` to `mergeIncrementalG`,

114+ `mergeIncremental` to `mergeIncrementalG`,

11− `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`,

12− `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`.

115+ `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`.

116

117+* Generalize distribute function:

118+ `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`,

119

15## 0.6.2.0

120## 0.6.2.0

121

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

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

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

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

124+

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

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

126+

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

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

128

22## 0.6.1.0

129## 0.6.1.0

130

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

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

132+

25* Fix `QueryT` and `RequesterT` tests

133* Fix `QueryT` and `RequesterT` tests

134

27## 0.6.0.0 -- 2019-03-20

135## 0.6.0.0 -- 2019-03-20

136

29* 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+

30* 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+

31* Remove many deprecated functions.

141* Remove many deprecated functions.

142+

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

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

144+

33* 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+

34* 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+

35* 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+

36* 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+17−1

@@ -1,7 +1,23 @@

1−distribution: bionic

1+distribution: xenial

2+benchmarks: False

3+unconstrained: False

4+installed: -all

3-- https://github.com/haskell/cabal/issues/6106

6-- https://github.com/haskell/cabal/issues/6106

4install-dependencies: False

7install-dependencies: False

6constraint-set no-th

9constraint-set no-th

7 constraints: reflex -use-template-haskell

10 constraints: reflex -use-template-haskell

11+

12+constraint-set old-these

13+ ghc: <8.8

14+ constraints: these <1

15+

16+constraint-set old-witherable

17+ constraints: witherable <0.3.2

18+

19+constraint-set debug-propagation

20+ constraints: reflex +debug-propagation

21+

22+constraint-set debug-cycles

23+ constraints: reflex +debug-cycles

default.nixdeleted−42

@@ -1,42 +0,0 @@

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

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

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

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

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

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

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

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

9−, monoidal-containers, witherable

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− ] ++ (if ghc.isGhcjs or false then [

27− ghcjs-base

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

29− haskell-src-exts haskell-src-meta

30− ]) ++ (if splitThese then [

31− semialign

32− ] else []);

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

34− hlint filepath directory filemanip

35− ];

36− configureFlags =

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

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

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

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

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

42−}

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

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

1+# DO NOT HAND-EDIT THIS FILE

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

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

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

5+ private = json.private or false;

6+ }

7+))

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

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

1+{

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

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

4+ "branch": "develop",

5+ "rev": "f628398d076243a0851b27e625b37f65dff9b89b",

6+ "sha256": "0sl0hf1glgyb1vmf2mhw4r9ipmcqk1y19d3wsic7dix2jwywzrh9"

7+}

hydra.jsondeleted−29

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

1−{

2− "enabled": 1,

3− "hidden": true,

4− "description": "Jobsets",

5− "nixexprinput": "src",

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

7− "checkinterval": 300,

8− "schedulingshares": 100,

9− "enableemail": false,

10− "emailoverride": "",

11− "keepnr": 10,

12− "inputs": {

13− "src": {

14− "type": "git",

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

16− "emailresponsible": false

17− },

18− "nixpkgs": {

19− "type": "git",

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

21− "emailresponsible": false

22− },

23− "prs": {

24− "type": "githubpulls",

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

26− "emailresponsible": false

27− }

28− }

29−}

jobsets.nixdeleted−70

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

1−{ prs }:

2−

3−let

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

5− mkFetchGithub = value: {

6− inherit value;

7− type = "git";

8− emailresponsible = false;

9− };

10−in

11−with pkgs.lib;

12−let

13− defaults = jobs: {

14− inherit (jobs) description;

15− enabled = 1;

16− hidden = false;

17− keepnr = 10;

18− schedulingshares = 100;

19− checkinterval = 120;

20− enableemail = false;

21− emailoverride = "";

22− nixexprinput = "reflex";

23− nixexprpath = "release.nix";

24− inputs = jobs.inputs // {

25− nixpkgs = {

26− type = "git";

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

28− emailresponsible = false;

29− };

30− config = {

31− type = "nix";

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

33− emailresponsible = false;

34− };

35− };

36− };

37− branchJobset = branch: defaults {

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

39− inputs = {

40− reflex = {

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

42− type = "git";

43− emailresponsible = false;

44− };

45− };

46− };

47− makePr = num: info: {

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

49− value = defaults {

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

51− inputs = {

52− reflex = {

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

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

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

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

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

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

59− type = "git";

60− emailresponsible = false;

61− };

62− };

63− };

64− };

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

66− jobsetsAttrs = processedPrs //

67− genAttrs ["develop"] branchJobset;

68−in {

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

70−}

reflex-platform.nixdeleted−8

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

1−let

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

3− owner = "reflex-frp";

4− repo = "reflex-platform";

5− rev = "384cd850f3adf1d404bced2424b5f6efb0f415f2";

6− sha256 = "1ws77prqx8khmp8j6br1ij4k2v4dlgv170r9fmg0p1jivfbn8y9d";

7− };

8−in import reflex-platform-src

reflex.cabal+159−56

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

@@ -41,52 +51,67 @@ flag fast-weak

41 default: False

51 default: False

42 manual: True

52 manual: True

54+flag debug-propagation

55+ description: Enable debugging of spider internals

56+ default: False

57+ manual: True

58+

59+flag debug-cycles

60+ description: Enable debugging of event cycles

61+ default: False

62+ manual: True

63+

44flag split-these

64flag split-these

45 description: Use split these/semialign packages

65 description: Use split these/semialign packages

46 manual: False

66 manual: False

47 default: True

67 default: True

49library

69library

70+ default-language: Haskell2010

50 hs-source-dirs: src

71 hs-source-dirs: src

51 build-depends:

72 build-depends:

52 MemoTrie == 0.6.*,

73 MemoTrie == 0.6.*,

53− base >= 4.9 && < 4.13,

74+ base >= 4.11 && < 4.15,

54 bifunctors >= 5.2 && < 5.6,

75 bifunctors >= 5.2 && < 5.6,

55− comonad,

76+ comonad >= 5.0.4 && < 5.1,

77+ constraints >= 0.10 && <0.14,

56− constraints-extras >= 0.2,

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

57− containers >= 0.5 && < 0.7,

79+ containers >= 0.6 && < 0.7,

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

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

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

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

60 exception-transformers == 0.4.*,

82 exception-transformers == 0.4.*,

61− profunctors,

62 lens >= 4.7 && < 5,

83 lens >= 4.7 && < 5,

84+ mmorph >= 1.0 && < 1.2,

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

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

64− monoidal-containers >= 0.4 && < 0.6,

65 mtl >= 2.1 && < 2.3,

86 mtl >= 2.1 && < 2.3,

87+ patch >= 0.0.1 && < 0.1,

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

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

67 primitive >= 0.5 && < 0.8,

89 primitive >= 0.5 && < 0.8,

90+ profunctors >= 5.3 && < 5.7,

68 random == 1.1.*,

91 random == 1.1.*,

69 ref-tf == 0.4.*,

92 ref-tf == 0.4.*,

70 reflection == 2.1.*,

93 reflection == 2.1.*,

71 semigroupoids >= 4.0 && < 6,

94 semigroupoids >= 4.0 && < 6,

72 stm >= 2.4 && < 2.6,

95 stm >= 2.4 && < 2.6,

73 syb >= 0.5 && < 0.8,

96 syb >= 0.5 && < 0.8,

74− time >= 1.4 && < 1.9,

97+ time >= 1.4 && < 1.10,

75− transformers >= 0.5.2.0,

98+ transformers >= 0.5.6.0 && < 0.6,

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

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

77− witherable >= 0.2 && < 0.4

100+ witherable >= 0.3 && < 0.5

101

79 if flag(split-these)

102 if flag(split-these)

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

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

81− semialign >=1 && <1.1

104+ semialign >=1 && <1.2,

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

82 else

106 else

83− build-depends: these >= 0.4 && <0.9

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

108+ monoidal-containers == 0.4.0.0

109

85 exposed-modules:

110 exposed-modules:

111+ Control.Monad.ReaderIO

86 Data.AppendMap,

112 Data.AppendMap,

87 Data.FastMutableIntMap,

113 Data.FastMutableIntMap,

88 Data.FastWeakBag,

114 Data.FastWeakBag,

89− Data.Functor.Misc,

90 Data.Map.Misc,

115 Data.Map.Misc,

91 Data.WeakBag,

116 Data.WeakBag,

92 Reflex,

117 Reflex,

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

106 Reflex.FastWeak,

131 Reflex.FastWeak,

107 Reflex.FunctorMaybe,

132 Reflex.FunctorMaybe,

108 Reflex.Host.Class,

133 Reflex.Host.Class,

134+ Reflex.Host.Headless,

109 Reflex.Network,

135 Reflex.Network,

110 Reflex.NotReady.Class,

136 Reflex.NotReady.Class,

111− Reflex.Patch,

112− Reflex.Patch.Class,

113− Reflex.Patch.DMap,

114− Reflex.Patch.DMapWithMove,

115− Reflex.Patch.IntMap,

116− Reflex.Patch.Map,

117− Reflex.Patch.MapWithMove,

118 Reflex.PerformEvent.Base,

137 Reflex.PerformEvent.Base,

119 Reflex.PerformEvent.Class,

138 Reflex.PerformEvent.Class,

120 Reflex.PostBuild.Base,

139 Reflex.PostBuild.Base,

@@ -133,38 +152,57 @@ library

133 Reflex.Widget.Basic,

152 Reflex.Widget.Basic,

134 Reflex.Workflow

153 Reflex.Workflow

135

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+

136 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

137

166

138 if flag(debug-trace-events)

167 if flag(debug-trace-events)

139 cpp-options: -DDEBUG_TRACE_EVENTS

168 cpp-options: -DDEBUG_TRACE_EVENTS

140− build-depends: bytestring

169+ build-depends:

170+ bytestring >= 0.10.8 && < 0.11

141

171

142 if flag(use-reflex-optimizer)

172 if flag(use-reflex-optimizer)

143 cpp-options: -DUSE_REFLEX_OPTIMIZER

173 cpp-options: -DUSE_REFLEX_OPTIMIZER

144 build-depends: ghc

174 build-depends: ghc

145 exposed-modules: Reflex.Optimizer

175 exposed-modules: Reflex.Optimizer

146

176

177+ if flag(debug-propagation)

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

179+

180+ if flag(debug-cycles)

181+ cpp-options: -DDEBUG_CYCLES

182+

147 if flag(use-template-haskell)

183 if flag(use-template-haskell)

148 cpp-options: -DUSE_TEMPLATE_HASKELL

184 cpp-options: -DUSE_TEMPLATE_HASKELL

149 build-depends:

185 build-depends:

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

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

151− haskell-src-exts >= 1.16 && < 1.22,

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

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

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

153− template-haskell >= 2.9 && < 2.15

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

154 exposed-modules:

190 exposed-modules:

155 Reflex.Dynamic.TH

191 Reflex.Dynamic.TH

156 other-extensions: TemplateHaskell

192 other-extensions: TemplateHaskell

157 else

193 else

158 build-depends:

194 build-depends:

159− dependent-sum == 0.6.*

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

160

196

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

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

162 cpp-options: -DGHCJS_FAST_WEAK

198 cpp-options: -DGHCJS_FAST_WEAK

163

199

164 if impl(ghcjs)

200 if impl(ghcjs)

165− build-depends: ghcjs-base

201+ build-depends:

202+ ghcjs-base == 0.2.*

166

203

167test-suite semantics

204test-suite semantics

205+ default-language: Haskell2010

168 type: exitcode-stdio-1.0

206 type: exitcode-stdio-1.0

169 main-is: semantics.hs

207 main-is: semantics.hs

170 hs-source-dirs: test

208 hs-source-dirs: test

@@ -173,14 +211,14 @@ test-suite semantics

173 base,

211 base,

174 bifunctors,

212 bifunctors,

175 containers,

213 containers,

176− deepseq >= 1.3 && < 1.5,

214+ deepseq,

177 dependent-map,

215 dependent-map,

178 dependent-sum,

216 dependent-sum,

179 mtl,

217 mtl,

180 ref-tf,

218 ref-tf,

181 reflex,

219 reflex,

182 split,

220 split,

183− transformers >= 0.3

221+ transformers

184 other-modules:

222 other-modules:

185 Reflex.Bench.Focused

223 Reflex.Bench.Focused

186 Reflex.Plan.Pure

224 Reflex.Plan.Pure

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

190 Reflex.TestPlan

228 Reflex.TestPlan

191

229

192test-suite CrossImpl

230test-suite CrossImpl

231+ default-language: Haskell2010

193 type: exitcode-stdio-1.0

232 type: exitcode-stdio-1.0

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

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

195 hs-source-dirs: test

234 hs-source-dirs: test

@@ -199,7 +238,7 @@ test-suite CrossImpl

199 containers,

238 containers,

200 dependent-map,

239 dependent-map,

201 dependent-sum,

240 dependent-sum,

202− deepseq >= 1.3 && < 1.5,

241+ deepseq,

203 mtl,

242 mtl,

204 transformers,

243 transformers,

205 ref-tf,

244 ref-tf,

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

211 Reflex.Plan.Pure

250 Reflex.Plan.Pure

212

251

213test-suite hlint

252test-suite hlint

253+ default-language: Haskell2010

214 type: exitcode-stdio-1.0

254 type: exitcode-stdio-1.0

215 main-is: hlint.hs

255 main-is: hlint.hs

216 hs-source-dirs: test

256 hs-source-dirs: test

@@ -218,17 +258,21 @@ test-suite hlint

218 , directory

258 , directory

219 , filepath

259 , filepath

220 , filemanip

260 , filemanip

221− , hlint >= 2.2.2 && < 2.3

261+ if impl(ghc >= 8.8)

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

263+ else

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

222 if impl(ghcjs)

265 if impl(ghcjs)

223 buildable: False

266 buildable: False

224

267

225test-suite EventWriterT

268test-suite EventWriterT

269+ default-language: Haskell2010

226 type: exitcode-stdio-1.0

270 type: exitcode-stdio-1.0

227 main-is: EventWriterT.hs

271 main-is: EventWriterT.hs

228 hs-source-dirs: test

272 hs-source-dirs: test

229 build-depends: base

273 build-depends: base

230 , containers

274 , containers

231− , deepseq >= 1.3 && < 1.5

275+ , deepseq

232 , dependent-map

276 , dependent-map

233 , dependent-sum

277 , dependent-sum

234 , lens

278 , lens

@@ -242,28 +286,57 @@ test-suite EventWriterT

242 build-depends: these-lens

286 build-depends: these-lens

243

287

244 other-modules:

288 other-modules:

245− Reflex.Test

246− Reflex.TestPlan

247− Reflex.Plan.Reflex

248− Reflex.Plan.Pure

249 Test.Run

289 Test.Run

250

290

251

291

252−test-suite RequesterT

292+test-suite DebugCycles

293+ default-language: Haskell2010

253 type: exitcode-stdio-1.0

294 type: exitcode-stdio-1.0

254− main-is: RequesterT.hs

295+ main-is: DebugCycles.hs

255 hs-source-dirs: test

296 hs-source-dirs: test

297+ ghc-options: -threaded

256 build-depends: base

298 build-depends: base

257 , containers

299 , containers

258− , deepseq >= 1.3 && < 1.5

300+ , deepseq

259− , dependent-sum

260 , dependent-map

301 , dependent-map

302+ , dependent-sum

303+ , hspec

261 , lens

304 , lens

262 , mtl

305 , mtl

263 , these

306 , these

264 , transformers

307 , transformers

265 , reflex

308 , reflex

266 , ref-tf

309 , ref-tf

310+ , witherable

311+ , proctest

312+

313+

314+ if flag(split-these)

315+ build-depends: these-lens, semialign

316+

317+ other-modules:

318+ Test.Run

319+

320+

321+test-suite RequesterT

322+ default-language: Haskell2010

323+ type: exitcode-stdio-1.0

324+ main-is: RequesterT.hs

325+ hs-source-dirs: test

326+ build-depends: base

327+ , constraints

328+ , constraints-extras

329+ , containers

330+ , deepseq

331+ , dependent-map

332+ , dependent-sum

333+ , lens

334+ , mtl

335+ , ref-tf

336+ , reflex

337+ , text

338+ , these

339+ , transformers

267

340

268 if flag(split-these)

341 if flag(split-these)

269 build-depends: these-lens

342 build-depends: these-lens

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

273 Reflex.Plan.Pure

346 Reflex.Plan.Pure

274 Test.Run

347 Test.Run

275

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+

276test-suite QueryT

372test-suite QueryT

373+ default-language: Haskell2010

277 type: exitcode-stdio-1.0

374 type: exitcode-stdio-1.0

278 main-is: QueryT.hs

375 main-is: QueryT.hs

279 hs-source-dirs: test

376 hs-source-dirs: test

@@ -281,10 +378,11 @@ test-suite QueryT

281 , containers

378 , containers

282 , dependent-map

379 , dependent-map

283 , dependent-sum

380 , dependent-sum

284− , deepseq >= 1.3 && < 1.5

381+ , deepseq

285 , lens

382 , lens

286 , monoidal-containers

383 , monoidal-containers

287 , mtl

384 , mtl

385+ , patch

288 , ref-tf

386 , ref-tf

289 , reflex

387 , reflex

290 , these

388 , these

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

300 Reflex.Plan.Pure

398 Reflex.Plan.Pure

301

399

302test-suite GC-Semantics

400test-suite GC-Semantics

401+ default-language: Haskell2010

303 type: exitcode-stdio-1.0

402 type: exitcode-stdio-1.0

304 main-is: GC.hs

403 main-is: GC.hs

305 hs-source-dirs: test

404 hs-source-dirs: test

@@ -307,8 +406,9 @@ test-suite GC-Semantics

307 , containers

406 , containers

308 , dependent-sum

407 , dependent-sum

309 , dependent-map

408 , dependent-map

310− , deepseq >= 1.3 && < 1.5

409+ , deepseq

311 , mtl

410 , mtl

411+ , patch

312 , these

412 , these

313 , transformers

413 , transformers

314 , reflex

414 , reflex

@@ -324,12 +424,13 @@ test-suite GC-Semantics

324 Test.Run

424 Test.Run

325

425

326test-suite rootCleanup

426test-suite rootCleanup

427+ default-language: Haskell2010

327 type: exitcode-stdio-1.0

428 type: exitcode-stdio-1.0

328 main-is: rootCleanup.hs

429 main-is: rootCleanup.hs

329 hs-source-dirs: test

430 hs-source-dirs: test

330 build-depends: base

431 build-depends: base

331 , containers

432 , containers

332− , deepseq >= 1.3 && < 1.5

433+ , deepseq

333 , dependent-sum

434 , dependent-sum

334 , mtl

435 , mtl

335 , reflex

436 , reflex

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

341 Test.Run

442 Test.Run

342

443

343benchmark spider-bench

444benchmark spider-bench

445+ default-language: Haskell2010

344 type: exitcode-stdio-1.0

446 type: exitcode-stdio-1.0

345 hs-source-dirs: bench test

447 hs-source-dirs: bench test

346 main-is: Main.hs

448 main-is: Main.hs

@@ -348,8 +450,8 @@ benchmark spider-bench

348 build-depends:

450 build-depends:

349 base,

451 base,

350 containers,

452 containers,

351− criterion >= 1.1 && < 1.6,

453+ criterion,

352− deepseq >= 1.3 && < 1.5,

454+ deepseq,

353 dependent-map,

455 dependent-map,

354 dependent-sum,

456 dependent-sum,

355 ref-tf,

457 ref-tf,

@@ -358,13 +460,14 @@ benchmark spider-bench

358 reflex,

460 reflex,

359 split,

461 split,

360 stm,

462 stm,

361− transformers >= 0.3

463+ transformers

362 other-modules:

464 other-modules:

363 Reflex.TestPlan

465 Reflex.TestPlan

364 Reflex.Plan.Reflex

466 Reflex.Plan.Reflex

365 Reflex.Bench.Focused

467 Reflex.Bench.Focused

366

468

367benchmark saulzar-bench

469benchmark saulzar-bench

470+ default-language: Haskell2010

368 type: exitcode-stdio-1.0

471 type: exitcode-stdio-1.0

369 hs-source-dirs: bench test

472 hs-source-dirs: bench test

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

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

@@ -372,9 +475,9 @@ benchmark saulzar-bench

372 ghc-options: -Wall -O2 -rtsopts -threaded

475 ghc-options: -Wall -O2 -rtsopts -threaded

373 build-depends:

476 build-depends:

374 base,

477 base,

375− containers >= 0.5 && < 0.7,

478+ containers,

376− criterion >= 1.1 && < 1.6,

479+ criterion,

377− deepseq >= 1.3 && < 1.5,

480+ deepseq,

378 dependent-map,

481 dependent-map,

379 dependent-sum,

482 dependent-sum,

380 loch-th,

483 loch-th,

@@ -386,7 +489,7 @@ benchmark saulzar-bench

386 split,

489 split,

387 stm,

490 stm,

388 time,

491 time,

389− transformers >= 0.3

492+ transformers

390 other-modules:

493 other-modules:

391 Reflex.TestPlan

494 Reflex.TestPlan

392 Reflex.Plan.Reflex

495 Reflex.Plan.Reflex

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.hsnew file+60

@@ -0,0 +1,60 @@

1+{-# language RoleAnnotations #-}

2+{-# language MultiParamTypeClasses #-}

3+{-# language FlexibleInstances #-}

4+{-# language CPP #-}

5+module Control.Monad.ReaderIO

6+ (

7+ ReaderIO (..)

8+ )

9+ where

10+

11+import Control.Monad.Fix

12+#if MIN_VERSION_base(4,10,0)

13+import Control.Applicative

14+#endif

15+import Control.Monad

16+import Control.Monad.Reader.Class

17+import Control.Monad.IO.Class

18+

19+-- | An approximate clone of @RIO@ from the @rio@ package, but not based on

20+-- @ReaderT@. The trouble with @ReaderT@ is that its third type argument has a

21+-- @nominal@ role, so we can't coerce through it when it's wrapped in some

22+-- other @data@ type. Ugh.

23+newtype ReaderIO e a = ReaderIO { runReaderIO :: e -> IO a }

24+type role ReaderIO representational representational

25+

26+instance Functor (ReaderIO e) where

27+ fmap = liftM

28+ {-# INLINE fmap #-}

29+ a <$ m = m >> pure a

30+ {-# INLINE (<$) #-}

31+

32+instance Applicative (ReaderIO e) where

33+ pure a = ReaderIO $ \_ -> pure a

34+ {-# INLINE pure #-}

35+ (<*>) = ap

36+ {-# INLINE (<*>) #-}

37+#if MIN_VERSION_base(4,10,0)

38+ liftA2 = liftM2

39+ {-# INLINE liftA2 #-}

40+#endif

41+ (*>) = (>>)

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

43+

44+instance Monad (ReaderIO e) where

45+ ReaderIO q >>= f = ReaderIO $ \e -> q e >>= \a -> runReaderIO (f a) e

46+ {-# INLINE (>>=) #-}

47+

48+instance MonadFix (ReaderIO e) where

49+ mfix f = ReaderIO $ \e -> mfix $ \r -> runReaderIO (f r) e

50+ {-# INLINE mfix #-}

51+

52+instance MonadIO (ReaderIO e) where

53+ liftIO m = ReaderIO $ \_ -> m

54+ {-# INLINE liftIO #-}

55+

56+instance MonadReader e (ReaderIO e) where

57+ ask = ReaderIO pure

58+ {-# INLINE ask #-}

59+ local f (ReaderIO m) = ReaderIO (m . f)

60+ {-# INLINE local #-}

src/Data/AppendMap.hs+7−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'

@@ -46,8 +48,10 @@ _unAppendMap = getMonoidalMap

46pattern AppendMap :: Map k v -> MonoidalMap k v

48pattern AppendMap :: Map k v -> MonoidalMap k v

47pattern AppendMap m = MonoidalMap m

49pattern AppendMap m = MonoidalMap m

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

49instance W.Filterable (MonoidalMap k) where

52instance W.Filterable (MonoidalMap k) where

50− mapMaybe = mapMaybe

53+ mapMaybe = MonoidalMap.mapMaybe

54+#endif

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

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

53nonEmptyDelete :: Ord k => k -> MonoidalMap k a -> Maybe (MonoidalMap k a)

57nonEmptyDelete :: Ord k => k -> MonoidalMap k a -> Maybe (MonoidalMap k a)

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

67 then Nothing

71 then Nothing

68 else Just bs

72 else Just bs

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

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

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

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

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

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

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

src/Data/FastMutableIntMap.hs+7−3

@@ -21,6 +21,7 @@ module Data.FastMutableIntMap

21 , patchIntMapNewElements

22 , patchIntMapNewElementsMap

23 , getDeletions

24+ , toList

24 ) where

25 ) where

26--TODO: Pure JS version

27--TODO: Pure JS version

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

34import Data.IntMap.Strict (IntMap)

35import Data.IntMap.Strict (IntMap)

35import qualified Data.IntMap.Strict as IntMap

36import qualified Data.IntMap.Strict as IntMap

36import Data.IORef

37import Data.IORef

37−import Reflex.Patch.Class

38+import Data.Patch.Class

38−import Reflex.Patch.IntMap

39+import Data.Patch.IntMap

40-- | A 'FastMutableIntMap' holds a map of values of type @a@ and allows low-overhead modifications via IO.

41-- | A 'FastMutableIntMap' holds a map of values of type @a@ and allows low-overhead modifications via IO.

41-- Operations on 'FastMutableIntMap' run in IO.

42-- Operations on 'FastMutableIntMap' run in IO.

@@ -84,10 +85,13 @@ getFrozenAndClear (FastMutableIntMap r) = do

84 writeIORef r IntMap.empty

85 writeIORef r IntMap.empty

85 return result

86 return result

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

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

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

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

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

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

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

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

91 v <- readIORef r

92 v <- readIORef r

92 writeIORef r $! applyAlways p v

93 writeIORef r $! applyAlways p v

93 return $ IntMap.intersection v m

94 return $ IntMap.intersection v m

95+

96+toList :: FastMutableIntMap a -> IO [(Int, a)]

97+toList (FastMutableIntMap r) = IntMap.toList <$> readIORef r

src/Data/FastWeakBag.hs+9−4

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

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+56−12

@@ -29,13 +29,14 @@

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

36 , coerceBehavior

37 , coerceEvent

38 , coerceDynamic

39+ , coerceIncremental

39 , MonadSample (..)

40 , MonadSample (..)

40 , MonadHold (..)

41 , MonadHold (..)

41 -- ** 'fan' related types

42 -- ** 'fan' related types

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

172 , slowHeadE

173 , slowHeadE

173 ) where

174 ) where

174

175

175−#if defined(MIN_VERSION_semialign)

176+#ifdef MIN_VERSION_semialign

176import Prelude hiding (zip, zipWith)

177import Prelude hiding (zip, zipWith)

177

178

178#if MIN_VERSION_these(0,8,0)

179#if MIN_VERSION_these(0,8,0)

179import Data.These.Combinators (justThese)

180import Data.These.Combinators (justThese)

180#endif

181#endif

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

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

184+#endif

181#endif

185#endif

182

186

183import Control.Applicative

187import Control.Applicative

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

192import Data.Bifunctor

196import Data.Bifunctor

193import Data.Coerce

197import Data.Coerce

194import Data.Default

198import Data.Default

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

199+import Data.Dependent.Map (DMap)

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

196import qualified Data.Dependent.Map as DMap

201import qualified Data.Dependent.Map as DMap

197import Data.Functor.Compose

202import Data.Functor.Compose

198import Data.Functor.Product

203import Data.Functor.Product

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

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

200import Data.FastMutableIntMap (PatchIntMap)

205import Data.FastMutableIntMap (PatchIntMap)

201import Data.Foldable

206import Data.Foldable

202import Data.Functor.Bind

207import Data.Functor.Bind

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

206import qualified Data.IntMap.Strict as IntMap

211import qualified Data.IntMap.Strict as IntMap

207import Data.List.NonEmpty (NonEmpty (..))

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

208import Data.Map (Map)

213import Data.Map (Map)

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

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

210import Data.Some (Some(Some))

215import Data.Some (Some(Some))

211import Data.String

216import Data.String

212import Data.These

217import Data.These

213import Data.Type.Coercion

218import Data.Type.Coercion

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

214import Data.Witherable (Filterable(..))

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

215import qualified Data.Witherable as W

221import qualified Data.Witherable as W

216import Reflex.FunctorMaybe (FunctorMaybe)

222import Reflex.FunctorMaybe (FunctorMaybe)

217import qualified Reflex.FunctorMaybe

223import qualified Reflex.FunctorMaybe

218−import Reflex.Patch

224+import Data.Patch

219−import qualified Reflex.Patch.MapWithMove as PatchMapWithMove

225+import qualified Data.Patch.MapWithMove as PatchMapWithMove

220

226

221import Debug.Trace (trace)

227import Debug.Trace (trace)

222

228

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

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

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

283 -- 'Event' occurs

289 -- 'Event' occurs

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

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

285− -- | 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.

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

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

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

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

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

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

@@ -319,6 +326,10 @@ class ( MonadHold t (PushM t)

319 -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its

326 -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its

320 -- occurrence type

327 -- occurrence type

321 dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)

328 dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)

329+ -- | Construct a 'Coercion' for an 'Incremental' given 'Coercion's for its

330+ -- patch target and patch types.

331+ incrementalCoercion

332+ :: Coercion (PatchTarget a) (PatchTarget b) -> Coercion a b -> Coercion (Incremental t a) (Incremental t b)

322 mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)

333 mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)

323 fanInt :: Event t (IntMap a) -> EventSelectorInt t a

334 fanInt :: Event t (IntMap a) -> EventSelectorInt t a

324

335

@@ -352,6 +363,12 @@ coerceEvent = coerceWith $ eventCoercion Coercion

352coerceDynamic :: (Reflex t, Coercible a b) => Dynamic t a -> Dynamic t b

363coerceDynamic :: (Reflex t, Coercible a b) => Dynamic t a -> Dynamic t b

353coerceDynamic = coerceWith $ dynamicCoercion Coercion

364coerceDynamic = coerceWith $ dynamicCoercion Coercion

354

365

366+-- | Coerce an 'Incremental' between representationally-equivalent value types

367+coerceIncremental

368+ :: (Reflex t, Coercible a b, Coercible (PatchTarget a) (PatchTarget b))

369+ => Incremental t a -> Incremental t b

370+coerceIncremental = coerceWith $ incrementalCoercion Coercion Coercion

371+

355-- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'. The 'Behavior'

372-- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'. The 'Behavior'

356-- __must__ change when and only when the 'Event' fires, such that the

373-- __must__ change when and only when the 'Event' fires, such that the

357-- 'Behavior''s value is always equal to the most recent firing of the 'Event';

374-- 'Behavior''s value is always equal to the most recent firing of the 'Event';

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

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

405 -- the supplied 'Event'.

422 -- the supplied 'Event'.

406 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

407

431

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

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

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

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

549 holdIncremental a0 = lift . holdIncremental a0

573 holdIncremental a0 = lift . holdIncremental a0

550 buildDynamic a0 = lift . buildDynamic a0

574 buildDynamic a0 = lift . buildDynamic a0

551 headE = lift . headE

575 headE = lift . headE

576+ now = lift now

552

577

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

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

554 sample = lift . sample

579 sample = lift . sample

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

559 holdIncremental a0 = lift . holdIncremental a0

584 holdIncremental a0 = lift . holdIncremental a0

560 buildDynamic a0 = lift . buildDynamic a0

585 buildDynamic a0 = lift . buildDynamic a0

561 headE = lift . headE

586 headE = lift . headE

587+ now = lift now

562

588

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

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

564 sample = lift . sample

590 sample = lift . sample

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

569 holdIncremental a0 = lift . holdIncremental a0

595 holdIncremental a0 = lift . holdIncremental a0

570 buildDynamic a0 = lift . buildDynamic a0

596 buildDynamic a0 = lift . buildDynamic a0

571 headE = lift . headE

597 headE = lift . headE

598+ now = lift now

572

599

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

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

574 sample = lift . sample

601 sample = lift . sample

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

579 holdIncremental a0 = lift . holdIncremental a0

606 holdIncremental a0 = lift . holdIncremental a0

580 buildDynamic a0 = lift . buildDynamic a0

607 buildDynamic a0 = lift . buildDynamic a0

581 headE = lift . headE

608 headE = lift . headE

609+ now = lift now

582

610

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

584 sample = lift . sample

612 sample = lift . sample

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

589 holdIncremental a0 = lift . holdIncremental a0

617 holdIncremental a0 = lift . holdIncremental a0

590 buildDynamic a0 = lift . buildDynamic a0

618 buildDynamic a0 = lift . buildDynamic a0

591 headE = lift . headE

619 headE = lift . headE

620+ now = lift now

592

621

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

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

594 sample = lift . sample

623 sample = lift . sample

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

599 holdIncremental a0 = lift . holdIncremental a0

628 holdIncremental a0 = lift . holdIncremental a0

600 buildDynamic a0 = lift . buildDynamic a0

629 buildDynamic a0 = lift . buildDynamic a0

601 headE = lift . headE

630 headE = lift . headE

631+ now = lift now

602

632

603--------------------------------------------------------------------------------

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

604-- Convenience functions

634-- Convenience functions

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

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

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

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

650 return = constant

680 return = constant

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

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

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

683+#endif

652

684

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

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

654 mempty = constant mempty

686 mempty = constant mempty

@@ -703,9 +735,12 @@ filterRight = mapMaybe (either (const Nothing) Just)

703instance Reflex t => Alt (Event t) where

735instance Reflex t => Alt (Event t) where

704 ev1 <!> ev2 = leftmost [ev1, ev2]

736 ev1 <!> ev2 = leftmost [ev1, ev2]

705

737

706−-- | 'Event' intersection (convenient interface to 'coincidence').

738+-- | 'Event' intersection. Only occurs when both events are co-incident.

707instance Reflex t => Apply (Event t) where

739instance Reflex t => Apply (Event t) where

708− evf <.> evx = coincidence (fmap (<$> evx) evf)

740+ evf <.> evx = mapMaybe f (align evf evx) where

741+ f (These g a) = Just (g a)

742+ f _ = Nothing

743+

709

744

710-- | 'Event' intersection (convenient interface to 'coincidence').

745-- | 'Event' intersection (convenient interface to 'coincidence').

711instance Reflex t => Bind (Event t) where

746instance Reflex t => Bind (Event t) where

@@ -1062,11 +1097,20 @@ instance Reflex t => Align (Event t) where

1062instance Reflex t => Semialign (Event t) where

1097instance Reflex t => Semialign (Event t) where

1063#endif

1098#endif

1064 align = alignEventWithMaybe Just

1099 align = alignEventWithMaybe Just

1065−

1100+

1066−#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

1067 zip x y = mapMaybe justThese $ align x y

1105 zip x y = mapMaybe justThese $ align x y

1068#endif

1106#endif

1069

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

1070

1114

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

1072-- 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−2

@@ -3,7 +3,6 @@

3{-# LANGUAGE CPP #-}

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FunctionalDependencies #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE UndecidableInstances #-}

6{-# LANGUAGE UndecidableInstances #-}

8#ifdef USE_REFLEX_OPTIMIZER

7#ifdef USE_REFLEX_OPTIMIZER

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

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

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

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

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

29 tellDyn = lift . tellDyn

28 tellDyn = lift . tellDyn

30−

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 (\v -> Identity <$> v) 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+70−12

@@ -9,6 +9,7 @@

9{-# LANGUAGE TypeFamilies #-}

10{-# LANGUAGE UndecidableInstances #-}

11{-# LANGUAGE PolyKinds #-}

12+{-# LANGUAGE TypeApplications #-}

12{-# LANGUAGE RankNTypes #-}

13{-# LANGUAGE RankNTypes #-}

13-- |

14-- |

14-- Module:

15-- Module:

@@ -25,8 +26,10 @@ import Control.Monad.Primitive

25import Control.Monad.Reader

26import Control.Monad.Reader

26import Control.Monad.Ref

27import Control.Monad.Ref

27import Control.Monad.State.Strict (StateT, execStateT, modify)

28import Control.Monad.State.Strict (StateT, execStateT, modify)

29+import Data.Bifunctor

28import Data.Coerce

30import Data.Coerce

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

31+import Data.Dependent.Map (DMap)

32+import Data.GADT.Compare (GCompare)

30import Data.FastMutableIntMap

33import Data.FastMutableIntMap

31import Data.IORef

34import Data.IORef

32import Data.List

35import Data.List

@@ -41,12 +44,20 @@ import Foreign.Ptr

41import GHC.Foreign

44import GHC.Foreign

42import GHC.IO.Encoding

45import GHC.IO.Encoding

43import GHC.Stack

46import GHC.Stack

47+import Reflex.Adjustable.Class

48+import Reflex.BehaviorWriter.Class

44import Reflex.Class

49import Reflex.Class

50+import Reflex.DynamicWriter.Class

51+import Reflex.EventWriter.Class

45import Reflex.Host.Class

52import Reflex.Host.Class

53+import Reflex.NotReady.Class

46import 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

48import System.IO.Unsafe

60import System.IO.Unsafe

49−import Unsafe.Coerce

51data ProfiledTimeline t

62data ProfiledTimeline t

@@ -136,7 +147,7 @@ instance Reflex t => Reflex (ProfiledTimeline t) where

136 pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e

147 pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e

137 pull = Behavior_Profiled . pull . coerce

148 pull = Behavior_Profiled . pull . coerce

138 fanG (Event_Profiled e) = EventSelectorG $ coerce $ selectG (fanG $ profileEvent e)

149 fanG (Event_Profiled e) = EventSelectorG $ coerce $ selectG (fanG $ profileEvent e)

139− mergeG :: forall (k :: z -> *) q v. GCompare k

150+ mergeG :: forall z (k :: z -> *) q v. GCompare k

140 => (forall a. q a -> Event (ProfiledTimeline t) (v a))

151 => (forall a. q a -> Event (ProfiledTimeline t) (v a))

141 -> DMap k q -> Event (ProfiledTimeline t) (DMap k v)

152 -> DMap k q -> Event (ProfiledTimeline t) (DMap k v)

142 mergeG nt = Event_Profiled #. mergeG (coerce nt)

153 mergeG nt = Event_Profiled #. mergeG (coerce nt)

@@ -146,18 +157,21 @@ instance Reflex t => Reflex (ProfiledTimeline t) where

146 updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d

157 updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d

147 unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'

158 unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'

148 unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'

159 unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'

149− mergeIncrementalG nt = (Event_Profiled . coerce) #. mergeIncrementalG nt

160+ mergeIncrementalG nt res = Event_Profiled $ mergeIncrementalG (coerce nt) (coerce res)

150− mergeIncrementalWithMoveG nt = (Event_Profiled . coerce) #. mergeIncrementalWithMoveG nt

161+ mergeIncrementalWithMoveG nt res = Event_Profiled $ mergeIncrementalWithMoveG (coerce nt) (coerce res)

151 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i

162 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i

152 updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i

163 updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i

153 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i

164 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i

154− behaviorCoercion (c :: Coercion a b) = case behaviorCoercion c :: Coercion (Behavior t a) (Behavior t b) of

165+ behaviorCoercion c =

155− Coercion -> unsafeCoerce (Coercion :: Coercion (Behavior (ProfiledTimeline t) a) (Behavior (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce

166+ Coercion `trans` behaviorCoercion @t c `trans` Coercion

156− eventCoercion (c :: Coercion a b) = case eventCoercion c :: Coercion (Event t a) (Event t b) of

167+ eventCoercion c =

157− Coercion -> unsafeCoerce (Coercion :: Coercion (Event (ProfiledTimeline t) a) (Event (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce

168+ Coercion `trans` eventCoercion @t c `trans` Coercion

169+ dynamicCoercion c =

158− dynamicCoercion (c :: Coercion a b) = case dynamicCoercion c :: Coercion (Dynamic t a) (Dynamic t b) of

170+ Coercion `trans` dynamicCoercion @t c `trans` Coercion

159− Coercion -> unsafeCoerce (Coercion :: Coercion (Dynamic (ProfiledTimeline t) a) (Dynamic (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce

171+ incrementalCoercion c d =

172+ Coercion `trans` incrementalCoercion @t c d `trans` Coercion

160− mergeIntIncremental = Event_Profiled . mergeIntIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchIntMap (Event (ProfiledTimeline t) a)) -> Incremental t (PatchIntMap (Event t a)))

173+ mergeIntIncremental = Event_Profiled . mergeIntIncremental .

174+ coerceWith (Coercion `trans` incrementalCoercion Coercion Coercion `trans` Coercion)

161 fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e

175 fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e

162

176

163deriving instance Functor (Dynamic t) => Functor (Dynamic (ProfiledTimeline t))

177deriving instance Functor (Dynamic t) => Functor (Dynamic (ProfiledTimeline t))

@@ -170,10 +184,21 @@ instance MonadHold t m => MonadHold (ProfiledTimeline t) (ProfiledM m) where

170 holdIncremental v0 (Event_Profiled v') = ProfiledM $ Incremental_Profiled <$> holdIncremental v0 v'

184 holdIncremental v0 (Event_Profiled v') = ProfiledM $ Incremental_Profiled <$> holdIncremental v0 v'

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

172 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

173

188

174instance MonadSample t m => MonadSample (ProfiledTimeline t) (ProfiledM m) where

189instance MonadSample t m => MonadSample (ProfiledTimeline t) (ProfiledM m) where

175 sample (Behavior_Profiled b) = ProfiledM $ sample b

190 sample (Behavior_Profiled b) = ProfiledM $ sample b

176

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+

177instance MonadTrans ProfiledM where

202instance MonadTrans ProfiledM where

178 lift = ProfiledM

203 lift = ProfiledM

179

204

@@ -185,6 +210,39 @@ instance PerformEvent t m => PerformEvent (ProfiledTimeline t) (ProfiledM m) whe

185 performEvent_ = lift . performEvent_ . coerce

210 performEvent_ = lift . performEvent_ . coerce

186 performEvent = lift . fmap coerce . performEvent . coerce

211 performEvent = lift . fmap coerce . performEvent . coerce

187

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+

188instance MonadRef m => MonadRef (ProfiledM m) where

246instance MonadRef m => MonadRef (ProfiledM m) where

189 type Ref (ProfiledM m) = Ref m

247 type Ref (ProfiledM m) = Ref m

190 newRef = lift . newRef

248 newRef = lift . newRef

src/Reflex/Pure.hs+9−2

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

@@ -88,7 +89,8 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where

88 then Nothing

89 then Nothing

89 else Just currentOccurrences

90 else Just currentOccurrences

92+-- The instance signature doeesn't compile, leave commented for documentation

91− -- fanG :: GCompare k => Event (Pure t) (DMap k v) -> EventSelectorG (Pure t) k v

93+-- fanG :: GCompare k => Event (Pure t) (DMap k v) -> EventSelectorG (Pure t) k v

92 fanG e = EventSelectorG $ \k -> Event $ \t -> unEvent e t >>= DMap.lookup k

94 fanG e = EventSelectorG $ \k -> Event $ \t -> unEvent e t >>= DMap.lookup k

94 switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a

96 switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a

@@ -128,6 +130,7 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where

128 behaviorCoercion Coercion = Coercion

130 behaviorCoercion Coercion = Coercion

129 eventCoercion Coercion = Coercion

131 eventCoercion Coercion = Coercion

130 dynamicCoercion Coercion = Coercion

132 dynamicCoercion Coercion = Coercion

133+ incrementalCoercion Coercion Coercion = Coercion

131

134

132 fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k

135 fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k

133

136

@@ -208,3 +211,7 @@ instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where

208 Just x -> fromMaybe lastValue $ apply x lastValue

211 Just x -> fromMaybe lastValue $ apply x lastValue

209

212

210 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+562−313

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

@@ -17,7 +16,10 @@

17{-# LANGUAGE TypeOperators #-}

16{-# LANGUAGE TypeOperators #-}

18{-# LANGUAGE UndecidableInstances #-}

17{-# LANGUAGE UndecidableInstances #-}

19{-# LANGUAGE PolyKinds #-}

18{-# LANGUAGE PolyKinds #-}

19+{-# LANGUAGE DeriveFunctor #-}

20+{-# LANGUAGE StandaloneDeriving #-}

20{-# LANGUAGE InstanceSigs #-}

21{-# LANGUAGE InstanceSigs #-}

22+{-# LANGUAGE MultiWayIf #-}

22#ifdef USE_REFLEX_OPTIMIZER

24#ifdef USE_REFLEX_OPTIMIZER

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

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

@@ -36,12 +38,17 @@ import Control.Monad hiding (forM, forM_, mapM, mapM_)

36import Control.Monad.Exception

38import Control.Monad.Exception

37import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)

39import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)

38import Control.Monad.Primitive

40import Control.Monad.Primitive

39−import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_)

41+import Control.Monad.Reader.Class

42+import Control.Monad.IO.Class

43+import Control.Monad.ReaderIO

40import Control.Monad.Ref

44import Control.Monad.Ref

45+import Control.Monad.Fail (MonadFail)

46+import qualified Control.Monad.Fail as MonadFail

41import Data.Align

47import Data.Align

42import Data.Coerce

48import Data.Coerce

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

49+import Data.Dependent.Map (DMap)

44import qualified Data.Dependent.Map as DMap

50import qualified Data.Dependent.Map as DMap

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

45import Data.FastMutableIntMap (FastMutableIntMap, PatchIntMap (..))

52import Data.FastMutableIntMap (FastMutableIntMap, PatchIntMap (..))

46import qualified Data.FastMutableIntMap as FastMutableIntMap

53import qualified Data.FastMutableIntMap as FastMutableIntMap

47import Data.Foldable hiding (concat, elem, sequence_)

54import Data.Foldable hiding (concat, elem, sequence_)

@@ -54,12 +61,13 @@ import qualified Data.IntMap.Strict as IntMap

54import Data.IORef

61import Data.IORef

55import Data.Kind (Type)

62import Data.Kind (Type)

56import Data.Maybe hiding (mapMaybe)

63import Data.Maybe hiding (mapMaybe)

57−import Data.Monoid ((<>))

64+import Data.Monoid (mempty, (<>))

58import Data.Proxy

65import Data.Proxy

59import Data.These

66import Data.These

60import Data.Traversable

67import Data.Traversable

68+import Data.Type.Equality ((:~:)(Refl))

61import Data.Witherable (Filterable, mapMaybe)

69import Data.Witherable (Filterable, mapMaybe)

62−import GHC.Exts

70+import GHC.Exts hiding (toList)

63import GHC.IORef (IORef (..))

71import GHC.IORef (IORef (..))

64import GHC.Stack

72import GHC.Stack

65import Reflex.FastWeak

73import Reflex.FastWeak

@@ -67,22 +75,27 @@ import System.IO.Unsafe

67import System.Mem.Weak

75import System.Mem.Weak

68import Unsafe.Coerce

76import Unsafe.Coerce

70−#if defined(MIN_VERSION_semialign)

78+#ifdef MIN_VERSION_semialign

71#if MIN_VERSION_these(0,8,0)

79#if MIN_VERSION_these(0,8,0)

72import Data.These.Combinators (justThese)

80import Data.These.Combinators (justThese)

73#endif

81#endif

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

83+import Data.Zip (Zip (..))

84+#endif

74#endif

85#endif

76#ifdef DEBUG_CYCLES

87#ifdef DEBUG_CYCLES

77import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)

88import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)

89+#endif

90+

78import Data.List.NonEmpty (NonEmpty (..), nonEmpty)

91import Data.List.NonEmpty (NonEmpty (..), nonEmpty)

79import qualified Data.List.NonEmpty as NonEmpty

92import qualified Data.List.NonEmpty as NonEmpty

80−import Data.Monoid (mempty)

81import Data.Tree (Forest, Tree (..), drawForest)

93import Data.Tree (Forest, Tree (..), drawForest)

82−#endif

94+import Data.List (isPrefixOf)

84−import Data.FastWeakBag (FastWeakBag)

96+import Data.FastWeakBag (FastWeakBag, FastWeakBagTicket)

85import qualified Data.FastWeakBag as FastWeakBag

97import qualified Data.FastWeakBag as FastWeakBag

98+

86import Data.Reflection

99import Data.Reflection

87import Data.Some (Some(Some))

100import Data.Some (Some(Some))

88import Data.Type.Coercion

101import Data.Type.Coercion

@@ -93,20 +106,26 @@ import qualified Reflex.Class

93import qualified Reflex.Class as R

106import qualified Reflex.Class as R

94import qualified Reflex.Host.Class

107import qualified Reflex.Host.Class

95import Reflex.NotReady.Class

108import Reflex.NotReady.Class

96−import Reflex.Patch

109+import Data.Patch

97−import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove

110+import qualified Data.Patch.DMapWithMove as PatchDMapWithMove

111+import Reflex.PerformEvent.Base (PerformEventT)

112

99#ifdef DEBUG_TRACE_EVENTS

113#ifdef DEBUG_TRACE_EVENTS

100import qualified Data.ByteString.Char8 as BS8

114import qualified Data.ByteString.Char8 as BS8

101import System.IO (stderr)

115import System.IO (stderr)

116+import Data.List (isPrefixOf)

102#endif

117#endif

103

118

104−#ifdef DEBUG_TRACE_EVENTS

119+-- TODO stdout might not be the best channel for debug output

120+debugStrLn :: String -> IO ()

121+debugStrLn = putStrLn

105

122

123+#ifdef DEBUG_TRACE_EVENTS

106withStackOneLine :: (BS8.ByteString -> a) -> a

124withStackOneLine :: (BS8.ByteString -> a) -> a

107withStackOneLine expr = unsafePerformIO $ do

125withStackOneLine expr = unsafePerformIO $ do

108 stack <- currentCallStack

126 stack <- currentCallStack

109− return (expr (BS8.pack (unwords (reverse stack))))

127+ return (expr . BS8.pack . unwords . dropInternal . reverse $ stack)

128+ where dropInternal = filterStack "Reflex.Spider.Internal"

110

129

111#endif

130#endif

112

131

@@ -117,28 +136,42 @@ debugInvalidateHeight :: Bool

117debugInvalidate :: Bool

136debugInvalidate :: Bool

118

137

119#ifdef DEBUG

138#ifdef DEBUG

120−

121#define DEBUG_NODEIDS

139#define DEBUG_NODEIDS

122

140

141+#ifdef DEBUG_TRACE_PROPAGATION

123debugPropagate = True

142debugPropagate = True

143+#else

144+debugPropagate = False

145+#endif

124

146

147+#ifdef DEBUG_TRACE_HEIGHT

148+debugInvalidateHeight = True

149+#else

125debugInvalidateHeight = False

150debugInvalidateHeight = False

151+#endif

126

152

153+#ifdef DEBUG_TRACE_INVALIDATION

127debugInvalidate = True

154debugInvalidate = True

155+#else

156+debugInvalidate = False

157+#endif

128

158

129class HasNodeId a where

159class HasNodeId a where

130 getNodeId :: a -> Int

160 getNodeId :: a -> Int

131

161

132−instance HasNodeId (Hold x p a) where

162+instance HasNodeId (CacheSubscribed x a) where

163+ getNodeId = _cacheSubscribed_nodeId

164+

165+instance HasNodeId (FanInt x a) where

133− getNodeId = holdNodeId

166+ getNodeId = _fanInt_nodeId

134

167

135−instance HasNodeId (PushSubscribed x a b) where

168+instance HasNodeId (Hold x p) where

136− getNodeId = pushSubscribedNodeId

169+ getNodeId = holdNodeId

137

170

138instance HasNodeId (SwitchSubscribed x a) where

171instance HasNodeId (SwitchSubscribed x a) where

139 getNodeId = switchSubscribedNodeId

172 getNodeId = switchSubscribedNodeId

140

173

141−instance HasNodeId (FanSubscribed x a) where

174+instance HasNodeId (FanSubscribed x v a) where

142 getNodeId = fanSubscribedNodeId

175 getNodeId = fanSubscribedNodeId

143

176

144instance HasNodeId (CoincidenceSubscribed x a) where

177instance HasNodeId (CoincidenceSubscribed x a) where

@@ -152,41 +185,16 @@ instance HasNodeId (Pull x a) where

152

185

153{-# INLINE showNodeId #-}

186{-# INLINE showNodeId #-}

154showNodeId :: HasNodeId a => a -> String

187showNodeId :: HasNodeId a => a -> String

155−showNodeId = ("#"<>) . show . getNodeId

188+showNodeId = showNodeId' . getNodeId

156−

189+

157−showSubscriberType :: Subscriber x a -> String

190+showNodeId' :: Int -> String

158−showSubscriberType = \case

191+showNodeId' = ("#"<>) . show

159− SubscriberPush _ _ -> "SubscriberPush"

192+

160− SubscriberMerge _ _ -> "SubscriberMerge"

161− SubscriberFan _ -> "SubscriberFan"

162− SubscriberMergeChange _ -> "SubscriberMergeChange"

163− SubscriberHold _ -> "SubscriberHold"

164− SubscriberHoldIdentity _ -> "SubscriberHoldIdentity"

165− SubscriberSwitch _ -> "SubscriberSwitch"

166− SubscriberCoincidenceOuter _ -> "SubscriberCoincidenceOuter"

167− SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"

168− SubscriberHandle -> "SubscriberHandle"

169−

170−showEventType :: Event x a -> String

171−showEventType = \case

172− EventRoot _ _ -> "EventRoot"

173− EventNever -> "EventNever"

174− EventPush _ -> "EventPush"

175− EventMerge _ -> "EventMerge"

176− EventFan _ _ -> "EventFan"

177− EventSwitch _ -> "EventSwitch"

178− EventCoincidence _ -> "EventCoincidence"

179− EventHold _ -> "EventHold"

180− EventDyn _ -> "EventDyn"

181− EventHoldIdentity _ -> "EventHoldIdentity"

182− EventDynIdentity _ -> "EventDynIdentity"

183

193

184#else

194#else

185

195

186debugPropagate = False

196debugPropagate = False

187−

188debugInvalidateHeight = False

197debugInvalidateHeight = False

189−

190debugInvalidate = False

198debugInvalidate = False

191

199

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

@@ -194,6 +202,10 @@ debugInvalidate = False

194showNodeId :: a -> String

202showNodeId :: a -> String

195showNodeId _ = ""

203showNodeId _ = ""

196

204

205+{-# INLINE showNodeId' #-}

206+showNodeId' :: Int -> String

207+showNodeId' _ = ""

208+

197#endif

209#endif

198

210

199#ifdef DEBUG_NODEIDS

211#ifdef DEBUG_NODEIDS

@@ -239,9 +251,9 @@ subscribeAndRead = unEvent

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

240-- efficient than 'push'

252-- efficient than 'push'

241{-# INLINE [1] pushCheap #-}

253{-# INLINE [1] pushCheap #-}

242−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

243pushCheap !f e = Event $ \sub -> do

255pushCheap !f e = Event $ \sub -> do

244− (subscription, occ) <- subscribeAndRead e $ sub

256+ (subscription, occ) <- subscribeAndRead e $ debugSubscriber' "push" $ sub

245 { subscriberPropagate = \a -> do

257 { subscriberPropagate = \a -> do

246 mb <- f a

258 mb <- f a

247 mapM_ (subscriberPropagate sub) mb

259 mapM_ (subscriberPropagate sub) mb

@@ -260,10 +272,10 @@ terminalSubscriber p = Subscriber

260

272

261-- | Subscribe to an Event only for the duration of one occurrence

273-- | Subscribe to an Event only for the duration of one occurrence

262{-# INLINE subscribeAndReadHead #-}

274{-# INLINE subscribeAndReadHead #-}

263−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)

264subscribeAndReadHead e sub = do

276subscribeAndReadHead e sub = do

265 subscriptionRef <- liftIO $ newIORef $ error "subscribeAndReadHead: not initialized"

277 subscriptionRef <- liftIO $ newIORef $ error "subscribeAndReadHead: not initialized"

266− (subscription, occ) <- subscribeAndRead e $ sub

278+ (subscription, occ) <- subscribeAndRead e $ debugSubscriber' "head" $ sub

267 { subscriberPropagate = \a -> do

279 { subscriberPropagate = \a -> do

268 liftIO $ unsubscribe =<< readIORef subscriptionRef

280 liftIO $ unsubscribe =<< readIORef subscriptionRef

269 subscriberPropagate sub a

281 subscriberPropagate sub a

@@ -274,24 +286,42 @@ subscribeAndReadHead e sub = do

274 return (subscription, occ)

286 return (subscription, occ)

275

287

276--TODO: Make this lazy in its input event

288--TODO: Make this lazy in its input event

277−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)

278headE originalE = do

290headE originalE = do

279 parent <- liftIO $ newIORef $ Just originalE

291 parent <- liftIO $ newIORef $ Just originalE

280 defer $ SomeMergeInit $ do --TODO: Rename SomeMergeInit appropriately

292 defer $ SomeMergeInit $ do --TODO: Rename SomeMergeInit appropriately

281 let clearParent = liftIO $ writeIORef parent Nothing

293 let clearParent = liftIO $ writeIORef parent Nothing

282− (_, occ) <- subscribeAndReadHead originalE $ terminalSubscriber $ \_ -> clearParent

294+ (_, occ) <- subscribeAndReadHead originalE $ terminalSubscriber $ const clearParent

283 when (isJust occ) clearParent

295 when (isJust occ) clearParent

284− return $ Event $ \sub -> do

296+ return $ Event $ \sub ->

285 liftIO (readIORef parent) >>= \case

297 liftIO (readIORef parent) >>= \case

286− Nothing -> return (EventSubscription (return ()) $ EventSubscribed zeroRef $ toAny (), Nothing)

298+ Nothing -> subscribeAndReadNever

287 Just e -> subscribeAndReadHead e sub

299 Just e -> subscribeAndReadHead e sub

288

300

289data CacheSubscribed x a

301data CacheSubscribed x a

290 = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(FastWeakBag (Subscriber x a))

302 = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(FastWeakBag (Subscriber x a))

291 , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)

303 , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)

292 , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))

304 , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))

305+#ifdef DEBUG_NODEIDS

306+ , _cacheSubscribed_nodeId :: {-# UNPACK #-} !Int

307+#endif

293 }

308 }

294

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+

295-- | Construct an 'Event' whose value is guaranteed not to be recomputed

325-- | Construct an 'Event' whose value is guaranteed not to be recomputed

296-- repeatedly

326-- repeatedly

297--

327--

@@ -316,18 +346,23 @@ cacheEvent e =

316 subscribedTicket <- liftIO (readIORef mSubscribedRef >>= getFastWeakTicket) >>= \case

346 subscribedTicket <- liftIO (readIORef mSubscribedRef >>= getFastWeakTicket) >>= \case

317 Just subscribedTicket -> return subscribedTicket

347 Just subscribedTicket -> return subscribedTicket

318 Nothing -> do

348 Nothing -> do

349+#ifdef DEBUG_NODEIDS

350+ nodeId <- liftIO newNodeId

351+#endif

319 subscribers <- liftIO FastWeakBag.empty

352 subscribers <- liftIO FastWeakBag.empty

320 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

321 (parentSub, occ) <- subscribeAndRead e $ Subscriber

357 (parentSub, occ) <- subscribeAndRead e $ Subscriber

358+#endif

322− { subscriberPropagate = \a -> do

359+ { subscriberPropagate = \a -> do

323− liftIO $ writeIORef occRef $ Just a

360+ liftIO $ writeIORef occRef (Just a)

324− scheduleClear occRef

361+ scheduleClear occRef

325− propagateFast a subscribers

362+ propagateFast a subscribers

326− , subscriberInvalidateHeight = \old -> do

327− FastWeakBag.traverse subscribers $ invalidateSubscriberHeight old

363+ , subscriberInvalidateHeight = FastWeakBag.traverse_ subscribers . invalidateSubscriberHeight

328− , subscriberRecalculateHeight = \new -> do

329− FastWeakBag.traverse subscribers $ recalculateSubscriberHeight new

364+ , subscriberRecalculateHeight = FastWeakBag.traverse_ subscribers . recalculateSubscriberHeight

330− }

365+ }

331 when (isJust occ) $ do

366 when (isJust occ) $ do

332 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

333 scheduleClear occRef

368 scheduleClear occRef

@@ -335,29 +370,45 @@ cacheEvent e =

335 { _cacheSubscribed_subscribers = subscribers

370 { _cacheSubscribed_subscribers = subscribers

336 , _cacheSubscribed_parent = parentSub

371 , _cacheSubscribed_parent = parentSub

337 , _cacheSubscribed_occurrence = occRef

372 , _cacheSubscribed_occurrence = occRef

373+#ifdef DEBUG_NODEIDS

374+ , _cacheSubscribed_nodeId = nodeId

375+#endif

338 }

376 }

339 subscribedTicket <- liftIO $ mkFastWeakTicket subscribed

377 subscribedTicket <- liftIO $ mkFastWeakTicket subscribed

340 liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket

378 liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket

341 return subscribedTicket

379 return subscribedTicket

342− liftIO $ do

380+ liftIO $ cacheSubscription sub mSubscribedRef subscribedTicket

381+

382+cacheSubscription :: Subscriber x a -> IORef (FastWeak (CacheSubscribed x a))

383+ -> FastWeakTicket (CacheSubscribed x a) -> IO (EventSubscription x, Maybe a)

384+cacheSubscription sub mSubscribedRef subscribedTicket = do

343− subscribed <- getFastWeakTicketValue subscribedTicket

385+ subscribed <- getFastWeakTicketValue subscribedTicket

344− ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed

386+ ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed

345− occ <- readIORef $ _cacheSubscribed_occurrence subscribed

387+ occ <- readIORef $ _cacheSubscribed_occurrence subscribed

388+

389+ let parentSub = _cacheSubscribed_parent subscribed

346− let es = EventSubscription

390+ es = EventSubscription

347− { _eventSubscription_unsubscribe = do

391+ { _eventSubscription_unsubscribe = do

348− FastWeakBag.remove ticket

392+ FastWeakBag.remove ticket

393+

349− isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed

394+ isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed

350− when isEmpty $ do

395+ when isEmpty $ do

351− writeIORef mSubscribedRef emptyFastWeak

396+ writeIORef mSubscribedRef emptyFastWeak

352− unsubscribe $ _cacheSubscribed_parent subscribed

397+ unsubscribe parentSub

353− touch ticket

398+ touch ticket

354− touch subscribedTicket

399+ touch subscribedTicket

355− , _eventSubscription_subscribed = EventSubscribed

400+ , _eventSubscription_subscribed = EventSubscribed

356− { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed

401+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed parentSub

357− , eventSubscribedRetained = toAny subscribedTicket

402+ , eventSubscribedRetained = toAny subscribedTicket

403+#ifdef DEBUG_CYCLES

404+ , eventSubscribedGetParents = return [_eventSubscription_subscribed parentSub]

405+ , eventSubscribedHasOwnHeightRef = False

406+ , eventSubscribedWhoCreated = whoCreatedIORef mSubscribedRef

407+#endif

358− }

408+ }

359− }

409+ }

360− return (es, occ)

410+ return (es, occ)

411+

361

412

362subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)

413subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)

363subscribe e s = fst <$> subscribeAndRead e s

414subscribe e s = fst <$> subscribeAndRead e s

@@ -369,11 +420,14 @@ wrap tag getSpecificSubscribed sub = do

369 let es = tag subd

420 let es = tag subd

370 return (EventSubscription (WeakBag.remove sln >> touch sln) es, occ)

421 return (EventSubscription (WeakBag.remove sln >> touch sln) es, occ)

371

422

372−eventRoot :: GCompare k => k a -> Root x k -> Event x a

423+eventRoot :: (GCompare k, HasSpiderTimeline x) => k a -> Root x k -> Event x a

373eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r

424eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r

374

425

426+subscribeAndReadNever :: EventM x (EventSubscription x, Maybe a)

427+subscribeAndReadNever = return (EventSubscription (return ()) eventSubscribedNever, Nothing)

428+

375eventNever :: Event x a

429eventNever :: Event x a

376−eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)

430+eventNever = Event $ const subscribeAndReadNever

377

431

378eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k v -> Event x (v a)

432eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k v -> Event x (v a)

379eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f

433eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f

@@ -410,16 +464,6 @@ data Subscriber x a = Subscriber

410 , subscriberRecalculateHeight :: !(Height -> IO ())

464 , subscriberRecalculateHeight :: !(Height -> IO ())

411 }

465 }

412

466

413−--TODO: Move this comment to WeakBag

414−-- These function are constructor functions that are marked NOINLINE so they are

415−-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away

416−-- so any weak references that are attached to the constructors will have their

417−-- finalizer run. Using the opaque constructor, does not see the

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

419−--

420−-- The result is also evaluated to WHNF, since forcing a thunk invalidates

421−-- the weak pointer to it in some cases.

422−

423newSubscriberHold :: (HasSpiderTimeline x, Patch p) => Hold x p -> IO (Subscriber x p)

467newSubscriberHold :: (HasSpiderTimeline x, Patch p) => Hold x p -> IO (Subscriber x p)

424newSubscriberHold h = return $ Subscriber

468newSubscriberHold h = return $ Subscriber

425 { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h

469 { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h

@@ -428,10 +472,10 @@ newSubscriberHold h = return $ Subscriber

428 }

472 }

429

473

430newSubscriberFan :: forall x k v. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k v -> IO (Subscriber x (DMap k v))

474newSubscriberFan :: forall x k v. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k v -> IO (Subscriber x (DMap k v))

431−newSubscriberFan subscribed = return $ Subscriber

475+newSubscriberFan subscribed = debugSubscriber ("SubscriberFan " <> showNodeId subscribed) $ Subscriber

432 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do

476 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do

433 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed

477 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed

434− tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"

478+ tracePropagate (Proxy :: Proxy x) $ show (DMap.size subs) <> " keys subscribed, " <> show (DMap.size a) <> " keys firing"

435 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a

479 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a

436 scheduleClear $ fanSubscribedOccurrence subscribed

480 scheduleClear $ fanSubscribedOccurrence subscribed

437 let f _ (Pair v subsubs) = do

481 let f _ (Pair v subsubs) = do

@@ -440,72 +484,55 @@ newSubscriberFan subscribed = return $ Subscriber

440 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_

484 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_

441 return ()

485 return ()

442 , subscriberInvalidateHeight = \old -> do

486 , subscriberInvalidateHeight = \old -> do

443− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed

444 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

487 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

445− 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

446− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"

447 , subscriberRecalculateHeight = \new -> do

489 , subscriberRecalculateHeight = \new -> do

448− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed

449 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

490 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

450− 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

451− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"

452 }

492 }

453

493

454newSubscriberSwitch :: 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)

455−newSubscriberSwitch subscribed = return $ Subscriber

495+newSubscriberSwitch subscribed = debugSubscriber ("SubscriberCoincidenceOuter" <> showNodeId subscribed) $ Subscriber

456 { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do

496 { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do

457− tracePropagate (Proxy :: Proxy x) $ "SubscriberSwitch" <> showNodeId subscribed

458 liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a

497 liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a

459 scheduleClear $ switchSubscribedOccurrence subscribed

498 scheduleClear $ switchSubscribedOccurrence subscribed

460 propagate a $ switchSubscribedSubscribers subscribed

499 propagate a $ switchSubscribedSubscribers subscribed

461 , subscriberInvalidateHeight = \_ -> do

500 , subscriberInvalidateHeight = \_ -> do

462− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed

463 oldHeight <- readIORef $ switchSubscribedHeight subscribed

501 oldHeight <- readIORef $ switchSubscribedHeight subscribed

464 when (oldHeight /= invalidHeight) $ do

502 when (oldHeight /= invalidHeight) $ do

465 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight

503 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight

466− WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

504+ WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

467− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"

468− , subscriberRecalculateHeight = \new -> do

505+ , subscriberRecalculateHeight = (`updateSwitchHeight` subscribed)

469− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed

470− updateSwitchHeight new subscribed

471− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"

472− }

506+ }

473

507

474newSubscriberCoincidenceOuter :: forall x b. HasSpiderTimeline x => CoincidenceSubscribed x b -> IO (Subscriber x (Event x b))

508newSubscriberCoincidenceOuter :: forall x b. HasSpiderTimeline x => CoincidenceSubscribed x b -> IO (Subscriber x (Event x b))

475−newSubscriberCoincidenceOuter subscribed = return $ Subscriber

509+newSubscriberCoincidenceOuter subscribed = debugSubscriber ("SubscriberCoincidenceOuter" <> showNodeId subscribed) $ Subscriber

476 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do

510 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do

477− tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceOuter" <> showNodeId subscribed

478 outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed

511 outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed

479 tracePropagate (Proxy :: Proxy x) $ " outerHeight = " <> show outerHeight

512 tracePropagate (Proxy :: Proxy x) $ " outerHeight = " <> show outerHeight

480 (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed

513 (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed

481 tracePropagate (Proxy :: Proxy x) $ " isJust occ = " <> show (isJust occ)

514 tracePropagate (Proxy :: Proxy x) $ " isJust occ = " <> show (isJust occ)

482 tracePropagate (Proxy :: Proxy x) $ " innerHeight = " <> show innerHeight

515 tracePropagate (Proxy :: Proxy x) $ " innerHeight = " <> show innerHeight

516+

483 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd

517 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd

484 scheduleClear $ coincidenceSubscribedInnerParent subscribed

518 scheduleClear $ coincidenceSubscribedInnerParent subscribed

485 case occ of

519 case occ of

486− Nothing -> do

520+ Nothing ->

487 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

488 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight

522 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight

489− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight

523+ WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight

490− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight

524+ WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight

491 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

492 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ

526 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ

493 scheduleClear $ coincidenceSubscribedOccurrence subscribed

527 scheduleClear $ coincidenceSubscribedOccurrence subscribed

494 propagate o $ coincidenceSubscribedSubscribers subscribed

528 propagate o $ coincidenceSubscribedSubscribers subscribed

495− , subscriberInvalidateHeight = \_ -> do

496− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed

497− invalidateCoincidenceHeight subscribed

529+ , subscriberInvalidateHeight = \_ -> invalidateCoincidenceHeight subscribed

498− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"

499− , subscriberRecalculateHeight = \_ -> do

500− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed

501− recalculateCoincidenceHeight subscribed

530+ , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed

502− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"

503 }

531 }

504

532

505newSubscriberCoincidenceInner :: 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)

506−newSubscriberCoincidenceInner subscribed = return $ Subscriber

534+newSubscriberCoincidenceInner subscribed = debugSubscriber ("SubscriberCoincidenceInner" <> showNodeId subscribed) $ Subscriber

507 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do

535 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do

508− tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceInner" <> showNodeId subscribed

509 occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed

536 occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed

510 case occ of

537 case occ of

511 Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event

538 Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event

@@ -513,14 +540,8 @@ newSubscriberCoincidenceInner subscribed = return $ Subscriber

513 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a

540 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a

514 scheduleClear $ coincidenceSubscribedOccurrence subscribed

541 scheduleClear $ coincidenceSubscribedOccurrence subscribed

515 propagate a $ coincidenceSubscribedSubscribers subscribed

542 propagate a $ coincidenceSubscribedSubscribers subscribed

516− , subscriberInvalidateHeight = \_ -> do

517− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed

518− invalidateCoincidenceHeight subscribed

543+ , subscriberInvalidateHeight = \_ -> invalidateCoincidenceHeight subscribed

519− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"

520− , subscriberRecalculateHeight = \_ -> do

521− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed

522− recalculateCoincidenceHeight subscribed

544+ , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed

523− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"

524 }

545 }

525

546

526invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()

547invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()

@@ -530,18 +551,18 @@ recalculateSubscriberHeight :: Height -> Subscriber x a -> IO ()

530recalculateSubscriberHeight = flip subscriberRecalculateHeight

551recalculateSubscriberHeight = flip subscriberRecalculateHeight

531

552

532-- | Propagate everything at the current height

553-- | Propagate everything at the current height

533−propagate :: a -> WeakBag (Subscriber x a) -> EventM x ()

554+propagate :: forall x a. HasSpiderTimeline x => a -> WeakBag (Subscriber x a) -> EventM x ()

534−propagate a subscribers = withIncreasedDepth $ do

555+propagate a subscribers = withIncreasedDepth (Proxy::Proxy x) $

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

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

537− WeakBag.traverse subscribers $ \s -> subscriberPropagate s a

558+ WeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a

538

559

539-- | Propagate everything at the current height

560-- | Propagate everything at the current height

540−propagateFast :: a -> FastWeakBag (Subscriber x a) -> EventM x ()

561+propagateFast :: forall x a. HasSpiderTimeline x => a -> FastWeakBag (Subscriber x a) -> EventM x ()

541−propagateFast a subscribers = withIncreasedDepth $ do

562+propagateFast a subscribers = withIncreasedDepth (Proxy::Proxy x) $

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

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

544− FastWeakBag.traverse subscribers $ \s -> subscriberPropagate s a

565+ FastWeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a

545

566

546--------------------------------------------------------------------------------

567--------------------------------------------------------------------------------

547-- EventSubscribed

568-- EventSubscribed

@@ -550,11 +571,16 @@ propagateFast a subscribers = withIncreasedDepth $ do

550toAny :: a -> Any

571toAny :: a -> Any

551toAny = unsafeCoerce

572toAny = unsafeCoerce

552

573

574+-- Why do we use Any here, instead of just giving eventSubscribedRetained an

575+-- existential type? Sadly, GHC does not currently know how to unbox types

576+-- with existentially quantified fields. So instead we just coerce values

577+-- to type Any on the way in. Since we never coerce them back, this is

578+-- perfectly safe.

553data EventSubscribed x = EventSubscribed

579data EventSubscribed x = EventSubscribed

554 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)

580 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)

555 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any

581 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any

556#ifdef DEBUG_CYCLES

582#ifdef DEBUG_CYCLES

557− , eventSubscribedGetParents :: !(IO [Some (EventSubscribed x)]) -- For debugging loops

583+ , eventSubscribedGetParents :: !(IO [EventSubscribed x]) -- For debugging loops

558 , eventSubscribedHasOwnHeightRef :: !Bool

584 , eventSubscribedHasOwnHeightRef :: !Bool

559 , eventSubscribedWhoCreated :: !(IO [String])

585 , eventSubscribedWhoCreated :: !(IO [String])

560#endif

586#endif

@@ -581,13 +607,23 @@ eventSubscribedNever = EventSubscribed

581 , eventSubscribedWhoCreated = return ["never"]

607 , eventSubscribedWhoCreated = return ["never"]

582#endif

608#endif

583 }

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

584

620

585eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x

621eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x

586eventSubscribedFan !subscribed = EventSubscribed

622eventSubscribedFan !subscribed = EventSubscribed

587 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed

623 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed

588 , eventSubscribedRetained = toAny subscribed

624 , eventSubscribedRetained = toAny subscribed

589#ifdef DEBUG_CYCLES

625#ifdef DEBUG_CYCLES

590− , eventSubscribedGetParents = return [Some $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]

626+ , eventSubscribedGetParents = return [_eventSubscription_subscribed $ fanSubscribedParent subscribed]

591 , eventSubscribedHasOwnHeightRef = False

627 , eventSubscribedHasOwnHeightRef = False

592 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed

628 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed

593#endif

629#endif

@@ -600,7 +636,7 @@ eventSubscribedSwitch !subscribed = EventSubscribed

600#ifdef DEBUG_CYCLES

636#ifdef DEBUG_CYCLES

601 , eventSubscribedGetParents = do

637 , eventSubscribedGetParents = do

602 s <- readIORef $ switchSubscribedCurrentParent subscribed

638 s <- readIORef $ switchSubscribedCurrentParent subscribed

603− return [Some $ _eventSubscription_subscribed s]

639+ return [_eventSubscription_subscribed s]

604 , eventSubscribedHasOwnHeightRef = True

640 , eventSubscribedHasOwnHeightRef = True

605 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed

641 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed

606#endif

642#endif

@@ -613,8 +649,8 @@ eventSubscribedCoincidence !subscribed = EventSubscribed

613#ifdef DEBUG_CYCLES

649#ifdef DEBUG_CYCLES

614 , eventSubscribedGetParents = do

650 , eventSubscribedGetParents = do

615 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed

651 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed

616− let outerParent = Some $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed

652+ let outerParent = _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed

617− innerParents = maybeToList $ fmap Some innerSubscription

653+ innerParents = maybeToList $ innerSubscription

618 return $ outerParent : innerParents

654 return $ outerParent : innerParents

619 , eventSubscribedHasOwnHeightRef = True

655 , eventSubscribedHasOwnHeightRef = True

620 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed

656 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed

@@ -628,15 +664,15 @@ getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es

628whoCreatedEventSubscribed :: EventSubscribed x -> IO [String]

664whoCreatedEventSubscribed :: EventSubscribed x -> IO [String]

629whoCreatedEventSubscribed = eventSubscribedWhoCreated

665whoCreatedEventSubscribed = eventSubscribedWhoCreated

630

666

631−walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)]

667+walkInvalidHeightParents :: EventSubscribed x -> IO [EventSubscribed x]

632walkInvalidHeightParents s0 = do

668walkInvalidHeightParents s0 = do

633− subscribers <- flip execStateT mempty $ ($ Some s0) $ fix $ \loop (Some s) -> do

669+ subscribers <- flip execStateT mempty $ ($ s0) $ fix $ \loop s -> do

634 h <- liftIO $ readIORef $ eventSubscribedHeightRef s

670 h <- liftIO $ readIORef $ eventSubscribedHeightRef s

635 when (h == invalidHeight) $ do

671 when (h == invalidHeight) $ do

636 when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed

672 when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed

637− modify (Some s :)

673+ modify (s :)

638 mapM_ loop =<< liftIO (eventSubscribedGetParents s)

674 mapM_ loop =<< liftIO (eventSubscribedGetParents s)

639− forM_ subscribers $ \(Some s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight

675+ forM_ subscribers $ \s -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight

640 return subscribers

676 return subscribers

641#endif

677#endif

642

678

@@ -673,7 +709,7 @@ behaviorPull !p = Behavior $ do

673 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"

709 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"

674 parentsRef <- liftIO $ newIORef []

710 parentsRef <- liftIO $ newIORef []

675 holdInits <- askBehaviorHoldInits

711 holdInits <- askBehaviorHoldInits

676− a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)

712+ a <- liftIO $ runReaderIO (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)

677 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator

713 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator

678 parents <- liftIO $ readIORef parentsRef

714 parents <- liftIO $ readIORef parentsRef

679 let subscribed = PullSubscribed

715 let subscribed = PullSubscribed

@@ -708,42 +744,46 @@ readBehaviorUntracked b = do

708-- Dynamic

744-- Dynamic

709--------------------------------------------------------------------------------

745--------------------------------------------------------------------------------

710

746

747+type DynamicS x p = Dynamic x (PatchTarget p) p

748+

711−data Dynamic x p = Dynamic

749+data Dynamic x target p = Dynamic

712− { dynamicCurrent :: !(Behavior x (PatchTarget p))

750+ { dynamicCurrent :: !(Behavior x target)

713 , dynamicUpdated :: Event x p -- This must be lazy; see the comment on holdEvent --TODO: Would this let us eliminate `Dyn`?

751 , dynamicUpdated :: Event x p -- This must be lazy; see the comment on holdEvent --TODO: Would this let us eliminate `Dyn`?

714 }

752 }

715

753

754+deriving instance (HasSpiderTimeline x) => Functor (Dynamic x target)

755+

756+

757+

758+

716−dynamicHold :: Hold x p -> Dynamic x p

759+dynamicHold :: Hold x p -> DynamicS x p

717dynamicHold !h = Dynamic

760dynamicHold !h = Dynamic

718 { dynamicCurrent = behaviorHold h

761 { dynamicCurrent = behaviorHold h

719 , dynamicUpdated = eventHold h

762 , dynamicUpdated = eventHold h

720 }

763 }

721

764

722−dynamicHoldIdentity :: Hold x (Identity a) -> Dynamic x (Identity a)

765+dynamicHoldIdentity :: Hold x (Identity a) -> DynamicS x (Identity a)

723dynamicHoldIdentity = dynamicHold

766dynamicHoldIdentity = dynamicHold

724

767

725−dynamicConst :: PatchTarget p -> Dynamic x p

768+dynamicConst :: PatchTarget p -> DynamicS x p

726dynamicConst !a = Dynamic

769dynamicConst !a = Dynamic

727 { dynamicCurrent = behaviorConst a

770 { dynamicCurrent = behaviorConst a

728 , dynamicUpdated = eventNever

771 , dynamicUpdated = eventNever

729 }

772 }

730

773

731−dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p

774+dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> DynamicS x p

732dynamicDyn !d = Dynamic

775dynamicDyn !d = Dynamic

733 { dynamicCurrent = behaviorDyn d

776 { dynamicCurrent = behaviorDyn d

734 , dynamicUpdated = eventDyn d

777 , dynamicUpdated = eventDyn d

735 }

778 }

736

779

737−dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a)

780+dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> DynamicS x (Identity a)

738dynamicDynIdentity = dynamicDyn

781dynamicDynIdentity = dynamicDyn

739

782

740--------------------------------------------------------------------------------

783--------------------------------------------------------------------------------

741-- Combinators

784-- Combinators

742--------------------------------------------------------------------------------

785--------------------------------------------------------------------------------

743

786

744−--TODO: Figure out why certain things are not 'representational', then make them

745−--representational so we can use coerce

746−

747--type role Hold representational

787--type role Hold representational

748data Hold x p

788data Hold x p

749 = Hold { holdValue :: !(IORef (PatchTarget p))

789 = Hold { holdValue :: !(IORef (PatchTarget p))

@@ -764,20 +804,25 @@ globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv

764

804

765-- | Stores all global data relevant to a particular Spider timeline; only one

805-- | Stores all global data relevant to a particular Spider timeline; only one

766-- value should exist for each type @x@

806-- value should exist for each type @x@

807+newtype SpiderTimelineEnv x = STE {unSTE :: SpiderTimelineEnv' x}

808+-- We implement SpiderTimelineEnv with a newtype wrapper so

809+-- we can get the coercions we want safely.

810+type role SpiderTimelineEnv nominal

811+

767−data SpiderTimelineEnv x = SpiderTimelineEnv

812+data SpiderTimelineEnv' x = SpiderTimelineEnv

768 { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())

813 { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())

769 , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)

814 , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)

770#ifdef DEBUG

815#ifdef DEBUG

771 , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)

816 , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)

772#endif

817#endif

773 }

818 }

774−type role SpiderTimelineEnv nominal

819+type role SpiderTimelineEnv' phantom

775

820

776instance Eq (SpiderTimelineEnv x) where

821instance Eq (SpiderTimelineEnv x) where

777 _ == _ = True -- Since only one exists of each type

822 _ == _ = True -- Since only one exists of each type

778

823

779instance GEq SpiderTimelineEnv where

824instance GEq SpiderTimelineEnv where

780− a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b

825+ a `geq` b = if _spiderTimeline_lock (unSTE a) == _spiderTimeline_lock (unSTE b)

781 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments

826 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments

782 else Nothing

827 else Nothing

783

828

@@ -800,7 +845,7 @@ runEventM :: EventM x a -> IO a

800runEventM = unEventM

845runEventM = unEventM

801

846

802asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a

847asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a

803−asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)

848+asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (unSTE (spiderTimeline :: SpiderTimelineEnv x))

804

849

805class MonadIO m => Defer a m where

850class MonadIO m => Defer a m where

806 getDeferralQueue :: m (IORef [a])

851 getDeferralQueue :: m (IORef [a])

@@ -938,9 +983,9 @@ getHoldEventSubscription h = do

938

983

939type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])

984type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])

940

985

941−--type role BehaviorM representational

942-- BehaviorM can sample behaviors

986-- BehaviorM can sample behaviors

943−newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderT (BehaviorEnv x) IO a } deriving (Functor, Applicative, MonadIO, MonadFix)

987+newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderIO (BehaviorEnv x) a }

988+ deriving (Functor, Applicative, MonadIO, MonadFix, MonadReader (BehaviorEnv x))

944

989

945instance Monad (BehaviorM x) where

990instance Monad (BehaviorM x) where

946 {-# INLINE (>>=) #-}

991 {-# INLINE (>>=) #-}

@@ -949,8 +994,10 @@ instance Monad (BehaviorM x) where

949 BehaviorM x >> BehaviorM y = BehaviorM $ x >> y

994 BehaviorM x >> BehaviorM y = BehaviorM $ x >> y

950 {-# INLINE return #-}

995 {-# INLINE return #-}

951 return x = BehaviorM $ return x

996 return x = BehaviorM $ return x

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

952 {-# INLINE fail #-}

998 {-# INLINE fail #-}

953 fail s = BehaviorM $ fail s

999 fail s = BehaviorM $ fail s

1000+#endif

954

1001

955data BehaviorSubscribed x a

1002data BehaviorSubscribed x a

956 = forall p. BehaviorSubscribedHold (Hold x p)

1003 = forall p. BehaviorSubscribedHold (Hold x p)

@@ -1010,7 +1057,7 @@ data SomeMergeUpdate x = SomeMergeUpdate

1010newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }

1057newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }

1011

1058

1012-- EventM can do everything BehaviorM can, plus create holds

1059-- EventM can do everything BehaviorM can, plus create holds

1013−newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException) -- The environment should be Nothing if we are not in a frame, and Just if we are - in which case it is a list of assignments to be done after the frame is over

1060+newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException)

1014

1061

1015newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }

1062newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }

1016

1063

@@ -1035,7 +1082,8 @@ heightBagFromList :: [Height] -> HeightBag

1035heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights

1082heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights

1036

1083

1037heightBagAdd :: Height -> HeightBag -> HeightBag

1084heightBagAdd :: Height -> HeightBag -> HeightBag

1038−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

1039

1087

1040heightBagRemove :: Height -> HeightBag -> HeightBag

1088heightBagRemove :: Height -> HeightBag -> HeightBag

1041heightBagRemove (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

@@ -1044,6 +1092,13 @@ heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.loo

1044 0 -> IntMap.delete h c

1092 0 -> IntMap.delete h c

1045 _ -> IntMap.insert h (pred old) c

1093 _ -> IntMap.insert h (pred old) c

1046

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+

1047heightBagMax :: HeightBag -> Height

1102heightBagMax :: HeightBag -> Height

1048heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of

1103heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of

1049 Just ((h, _), _) -> Height h

1104 Just ((h, _), _) -> Height h

@@ -1144,7 +1199,10 @@ instance HasSpiderTimeline x => Semialign (Event x) where

1144 align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $

1199 align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $

1145 DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]

1200 DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]

1146

1201

1147−#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

1148 zip x y = mapMaybe justThese $ align x y

1206 zip x y = mapMaybe justThese $ align x y

1149#endif

1207#endif

1150

1208

@@ -1154,11 +1212,11 @@ data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)

1154

1212

1155newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }

1213newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }

1156

1214

1157−newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)

1215+newMapDyn :: HasSpiderTimeline x => (a -> b) -> DynamicS x (Identity a) -> DynamicS x (Identity b)

1158newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)

1216newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)

1159

1217

1160--TODO: Avoid the duplication between this and R.zipDynWith

1218--TODO: Avoid the duplication between this and R.zipDynWith

1161−zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c)

1219+zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> DynamicS x (Identity a) -> DynamicS x (Identity b) -> DynamicS x (Identity c)

1162zipDynWith f da db =

1220zipDynWith f da db =

1163 let eab = align (dynamicUpdated da) (dynamicUpdated db)

1221 let eab = align (dynamicUpdated da) (dynamicUpdated db)

1164 ec = flip push eab $ \o -> do

1222 ec = flip push eab $ \o -> do

@@ -1234,7 +1292,7 @@ run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> Res

1234run roots after = do

1292run roots after = do

1235 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"

1293 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"

1236 let t = spiderTimeline :: SpiderTimelineEnv x

1294 let t = spiderTimeline :: SpiderTimelineEnv x

1237− result <- SpiderHost $ withMVar (_spiderTimeline_lock t) $ \_ -> unSpiderHost $ runFrame $ do

1295+ result <- SpiderHost $ withMVar (_spiderTimeline_lock (unSTE t)) $ \_ -> unSpiderHost $ runFrame $ do

1238 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do

1296 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do

1239 occBefore <- liftIO $ do

1297 occBefore <- liftIO $ do

1240 occBefore <- readIORef occRef

1298 occBefore <- readIORef occRef

@@ -1288,55 +1346,110 @@ mkWeakPtrWithDebug x debugNote = do

1288 x' <- evaluate x

1346 x' <- evaluate x

1289 mkWeakPtr x' $

1347 mkWeakPtr x' $

1290 if debugFinalize

1348 if debugFinalize

1291− then Just $ putStrLn $ "finalizing: " ++ debugNote

1349+ then Just $ debugStrLn $ "finalizing: " ++ debugNote

1292 else Nothing

1350 else Nothing

1293

1351

1294type WeakList a = [Weak a]

1352type WeakList a = [Weak a]

1295

1353

1296−{-# INLINE withIncreasedDepth #-}

1354+type CanTrace x m = (HasSpiderTimeline x, MonadIO m)

1355+

1356+

1357+

1358+

1297#ifdef DEBUG

1359#ifdef DEBUG

1360+

1361+debugSubscriber :: forall x a. HasSpiderTimeline x => String -> Subscriber x a -> IO (Subscriber x a)

1362+debugSubscriber description = return . debugSubscriber' description

1363+

1364+debugSubscriber' :: forall x a. HasSpiderTimeline x => String -> Subscriber x a -> Subscriber x a

1365+debugSubscriber' description subscribed = Subscriber

1366+ {

1367+ subscriberPropagate = \m -> do

1368+ tracePropagate (Proxy :: Proxy x) ("subscriberPropagate: " <> description)

1369+ subscriberPropagate subscribed m

1370+ , subscriberInvalidateHeight = \old -> do

1371+ traceInvalidateHeight $ "invalidateSubscriberHeight: " <> description <> ", old = " <> show (unHeight old)

1372+ subscriberInvalidateHeight subscribed old

1373+ traceInvalidateHeight $ "invalidateSubscriberHeight: " <> description <> ", done"

1374+ , subscriberRecalculateHeight = \new -> do

1375+ traceInvalidateHeight $ "subscriberRecalculateHeight: " <> description <> ", new = " <> show (unHeight new)

1376+ subscriberRecalculateHeight subscribed new

1377+ traceInvalidateHeight $ "subscriberRecalculateHeight: " <> description <> ", done"

1378+ }

1379+

1380+

1298−withIncreasedDepth :: CanTrace x m => m a -> m a

1381+{-# INLINE withIncreasedDepth #-}

1382+withIncreasedDepth :: forall proxy x m a. CanTrace x m => proxy x -> m a -> m a

1299−withIncreasedDepth a = do

1383+withIncreasedDepth _ a = do

1300− spiderTimeline <- askSpiderTimelineEnv

1301− liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ

1384+ liftIO $ modifyIORef' (_spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)) succ

1302 result <- a

1385 result <- a

1303− liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred

1386+ liftIO $ modifyIORef' (_spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)) pred

1304 return result

1387 return result

1305−#else

1306−withIncreasedDepth :: m a -> m a

1307−withIncreasedDepth = id

1308−#endif

1309−

1310−type CanTrace x m = (HasSpiderTimeline x, MonadIO m)

1311

1388

1312{-# INLINE tracePropagate #-}

1389{-# INLINE tracePropagate #-}

1313tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()

1390tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()

1314−tracePropagate p = traceWhen p debugPropagate

1391+tracePropagate p = when debugPropagate . trace p

1315

1392

1316{-# INLINE traceInvalidate #-}

1393{-# INLINE traceInvalidate #-}

1317traceInvalidate :: String -> IO ()

1394traceInvalidate :: String -> IO ()

1318−traceInvalidate = when debugInvalidate . liftIO . putStrLn

1395+traceInvalidate = when debugInvalidate . liftIO . debugStrLn

1396+

1397+{-# INLINE traceInvalidateHeight #-}

1398+traceInvalidateHeight :: String -> IO ()

1399+traceInvalidateHeight = when debugInvalidateHeight . liftIO . debugStrLn

1319

1400

1320−{-# INLINE traceWhen #-}

1401+{-# INLINE trace #-}

1321−traceWhen :: (CanTrace x m) => proxy x -> Bool -> String -> m ()

1402+trace :: (CanTrace x m) => proxy x -> String -> m ()

1322−traceWhen p b message = traceMWhen p b $ return message

1403+trace p message = traceM p $ return message

1323

1404

1324−{-# INLINE traceMWhen #-}

1405+{-# INLINE traceM #-}

1325−traceMWhen :: (CanTrace x m) => proxy x -> Bool -> m String -> m ()

1406+traceM :: forall x proxy m. (CanTrace x m) => proxy x -> m String -> m ()

1326−traceMWhen _ b getMessage = when b $ do

1407+traceM _ getMessage = do

1327 message <- getMessage

1408 message <- getMessage

1328−#ifdef DEBUG

1329− spiderTimeline <- askSpiderTimelineEnv

1330− d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline

1409+ d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)

1410+ liftIO $ debugStrLn $ replicate d ' ' <> message

1411+

1331#else

1412#else

1332− let d = 0

1413+

1414+{-# INLINE withIncreasedDepth #-}

1415+withIncreasedDepth :: proxy x -> m a -> m a

1416+withIncreasedDepth _ = id

1417+

1418+{-# INLINE tracePropagate #-}

1419+tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()

1420+tracePropagate _ _ = return ()

1421+

1422+{-# INLINE traceInvalidate #-}

1423+traceInvalidate :: String -> IO ()

1424+traceInvalidate _ = return ()

1425+

1426+{-# INLINE traceInvalidateHeight #-}

1427+traceInvalidateHeight :: String -> IO ()

1428+traceInvalidateHeight _ = return ()

1429+

1430+{-# INLINE debugSubscriber #-}

1431+debugSubscriber :: String -> Subscriber x a -> IO (Subscriber x a)

1432+debugSubscriber _ = return

1433+

1434+{-# INLINE debugSubscriber' #-}

1435+debugSubscriber' :: String -> Subscriber x a -> Subscriber x a

1436+debugSubscriber' _ = id

1437+

1438+

1439+

1440+{-# INLINE trace #-}

1441+trace :: (CanTrace x m) => proxy x -> String -> m ()

1442+trace _ _ = return ()

1443+

1444+{-# INLINE traceM #-}

1445+traceM :: (CanTrace x m) => proxy x -> m String -> m ()

1446+traceM _ _ = return ()

1447+

1333#endif

1448#endif

1334− liftIO $ putStrLn $ replicate d ' ' <> message

1335

1449

1336whoCreatedIORef :: IORef a -> IO [String]

1450whoCreatedIORef :: IORef a -> IO [String]

1337whoCreatedIORef (IORef a) = whoCreated $! a

1451whoCreatedIORef (IORef a) = whoCreated $! a

1338

1452

1339−#ifdef DEBUG_CYCLES

1340groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]

1453groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]

1341groupByHead = \case

1454groupByHead = \case

1342 [] -> []

1455 [] -> []

@@ -1347,20 +1460,54 @@ groupByHead = \case

1347 | otherwise -> (x, xs :| []) : l

1460 | otherwise -> (x, xs :| []) : l

1348

1461

1349listsToForest :: Eq a => [[a]] -> Forest a

1462listsToForest :: Eq a => [[a]] -> Forest a

1350−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

1351#endif

1474#endif

1352

1475

1476+#ifdef DEBUG_CYCLES

1477+

1478+data EventLoopException = EventLoopException [[String]]

1479+instance Exception EventLoopException

1480+

1481+instance Show EventLoopException where

1482+ show (EventLoopException stacks) = "causality loop detected:\n" <> if null stacks

1483+ then "no location information, compile with profiling enabled for stack tree"

1484+ else showStacks stacks

1485+

1486+#else

1487+

1488+data EventLoopException = EventLoopException

1489+instance Exception EventLoopException

1490+

1491+instance Show EventLoopException where

1492+ show EventLoopException = "causality loop detected: \n" <>

1493+ "compile reflex with flag 'debug-cycles' and compile with profiling enabled for stack tree"

1494+

1495+#endif

1496+

1497+

1353{-# INLINE propagateSubscriberHold #-}

1498{-# INLINE propagateSubscriberHold #-}

1354propagateSubscriberHold :: 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 ()

1355propagateSubscriberHold h a = do

1500propagateSubscriberHold h a = do

1356− {-# SCC "trace" #-} traceMWhen (Proxy :: Proxy x) debugPropagate $ liftIO $ do

1501+ {-# SCC "trace" #-} when debugPropagate $ traceM (Proxy :: Proxy x) $ liftIO $ do

1357 invalidators <- liftIO $ readIORef $ holdInvalidators h

1502 invalidators <- liftIO $ readIORef $ holdInvalidators h

1358 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)

1503 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)

1504+

1359 v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h

1505 v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h

1360 case {-# SCC "apply" #-} apply a v of

1506 case {-# SCC "apply" #-} apply a v of

1361 Nothing -> return ()

1507 Nothing -> return ()

1362 Just v' -> do

1508 Just v' -> do

1509+ {-# SCC "trace2" #-} withIncreasedDepth (Proxy :: Proxy x) $

1363− {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate (Proxy :: Proxy x) $ "propagateSubscriberHold: assigning Hold" <> showNodeId h

1510+ tracePropagate (Proxy :: Proxy x) ("propagateSubscriberHold: assigning Hold" <> showNodeId h)

1364 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h

1511 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h

1365 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h

1512 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h

1366 defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'

1513 defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'

@@ -1368,25 +1515,25 @@ propagateSubscriberHold h a = do

1368data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset

1515data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset

1369

1516

1370runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a

1517runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a

1371−runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)

1518+runBehaviorM a mwi holdInits = runReaderIO (unBehaviorM a) (mwi, holdInits)

1372

1519

1373askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))

1520askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))

1374askInvalidator = do

1521askInvalidator = do

1375− (!m, _) <- BehaviorM ask

1522+ (!m, _) <- ask

1376 case m of

1523 case m of

1377 Nothing -> return Nothing

1524 Nothing -> return Nothing

1378 Just (!wi, _) -> return $ Just wi

1525 Just (!wi, _) -> return $ Just wi

1379

1526

1380askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))

1527askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))

1381askParentsRef = do

1528askParentsRef = do

1382− (!m, _) <- BehaviorM ask

1529+ (!m, _) <- ask

1383 case m of

1530 case m of

1384 Nothing -> return Nothing

1531 Nothing -> return Nothing

1385 Just (_, !p) -> return $ Just p

1532 Just (_, !p) -> return $ Just p

1386

1533

1387askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])

1534askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])

1388askBehaviorHoldInits = do

1535askBehaviorHoldInits = do

1389− (_, !his) <- BehaviorM ask

1536+ (_, !his) <- ask

1390 return his

1537 return his

1391

1538

1392{-# INLINE getDynHold #-}

1539{-# INLINE getDynHold #-}

@@ -1414,7 +1561,7 @@ getDynHold d = do

1414zeroRef :: IORef Height

1561zeroRef :: IORef Height

1415zeroRef = unsafePerformIO $ newIORef zeroHeight

1562zeroRef = unsafePerformIO $ newIORef zeroHeight

1416

1563

1417−getRootSubscribed :: GCompare k => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)

1564+getRootSubscribed :: forall k x a. (GCompare k, HasSpiderTimeline x) => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)

1418getRootSubscribed k r sub = do

1565getRootSubscribed k r sub = do

1419 mSubscribed <- readIORef $ rootSubscribed r

1566 mSubscribed <- readIORef $ rootSubscribed r

1420 let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r

1567 let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r

@@ -1428,7 +1575,9 @@ getRootSubscribed k r sub = do

1428 let !cached = rootSubscribed r

1575 let !cached = rootSubscribed r

1429 uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"

1576 uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"

1430 (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed

1577 (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed

1578+

1431− when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"

1579+ tracePropagate (Proxy::Proxy x) $ "getRootSubscribed: calling rootInit"

1580+

1432 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)

1581 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)

1433 writeIORef uninitRef $! uninit

1582 writeIORef uninitRef $! uninit

1434#ifdef DEBUG_NODEIDS

1583#ifdef DEBUG_NODEIDS

@@ -1478,6 +1627,9 @@ data FanInt x a = FanInt

1478 { _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

1479 , _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

1480 , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a))

1629 , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a))

1630+#ifdef DEBUG_NODEIDS

1631+ , _fanInt_nodeId :: {-# UNPACK #-} !Int

1632+#endif

1481 }

1633 }

1482

1634

1483newFanInt :: IO (FanInt x a)

1635newFanInt :: IO (FanInt x a)

@@ -1485,10 +1637,16 @@ newFanInt = do

1485 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

1486 subscriptionRef <- newIORef $ error "fanInt: no subscription"

1638 subscriptionRef <- newIORef $ error "fanInt: no subscription"

1487 occRef <- newIORef $ error "fanInt: no occurrence"

1639 occRef <- newIORef $ error "fanInt: no occurrence"

1640+#ifdef DEBUG_NODEIDS

1641+ nodeId <- newNodeId

1642+#endif

1488 return $ FanInt

1643 return $ FanInt

1489 { _fanInt_subscribers = subscribers

1644 { _fanInt_subscribers = subscribers

1490 , _fanInt_subscriptionRef = subscriptionRef

1645 , _fanInt_subscriptionRef = subscriptionRef

1491 , _fanInt_occRef = occRef

1646 , _fanInt_occRef = occRef

1647+#ifdef DEBUG_NODEIDS

1648+ , _fanInt_nodeId = nodeId

1649+#endif

1492 }

1650 }

1493

1651

1494fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a

1652fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a

@@ -1497,20 +1655,21 @@ fanInt p = unsafePerformIO $ do

1497 pure $ EventSelectorInt $ \k -> Event $ \sub -> do

1655 pure $ EventSelectorInt $ \k -> Event $ \sub -> do

1498 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)

1656 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)

1499 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

1500− (subscription, parentOcc) <- subscribeAndRead p $ Subscriber

1659+ (subscription, parentOcc) <- subscribeAndRead p $ debugSubscriber' desc $ Subscriber

1501 { subscriberPropagate = \m -> do

1660 { subscriberPropagate = \m -> do

1502 liftIO $ writeIORef (_fanInt_occRef self) m

1661 liftIO $ writeIORef (_fanInt_occRef self) m

1503 scheduleIntClear $ _fanInt_occRef self

1662 scheduleIntClear $ _fanInt_occRef self

1504− FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> do --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?

1505− FastWeakBag.traverse b $ \s -> do

1664+ FastWeakBag.traverse_ b $ \s ->

1506 subscriberPropagate s v

1665 subscriberPropagate s v

1507− , subscriberInvalidateHeight = \old -> do

1666+ , subscriberInvalidateHeight = \old ->

1508− FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do

1667+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->

1509− FastWeakBag.traverse b $ \s -> do

1668+ FastWeakBag.traverse_ b $ \s ->

1510 subscriberInvalidateHeight s old

1669 subscriberInvalidateHeight s old

1511− , subscriberRecalculateHeight = \new -> do

1670+ , subscriberRecalculateHeight = \new ->

1512− FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do

1671+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->

1513− FastWeakBag.traverse b $ \s -> do

1672+ FastWeakBag.traverse_ b $ \s ->

1514 subscriberRecalculateHeight s new

1673 subscriberRecalculateHeight s new

1515 }

1674 }

1516 liftIO $ do

1675 liftIO $ do

@@ -1524,10 +1683,25 @@ fanInt p = unsafePerformIO $ do

1524 FastMutableIntMap.insert (_fanInt_subscribers self) k b

1683 FastMutableIntMap.insert (_fanInt_subscribers self) k b

1525 return b

1684 return b

1526 Just b -> return b

1685 Just b -> return b

1527− t <- liftIO $ FastWeakBag.insert sub b

1686+ ticket <- liftIO $ FastWeakBag.insert sub b

1528 currentOcc <- readIORef (_fanInt_occRef self)

1687 currentOcc <- readIORef (_fanInt_occRef self)

1529− (EventSubscription _ (EventSubscribed !heightRef _)) <- readIORef (_fanInt_subscriptionRef self)

1688+

1689+ subscribed <- fanIntSubscribed ticket self

1530− return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)

1690+ return (EventSubscription (FastWeakBag.remove ticket) subscribed, IntMap.lookup k currentOcc)

1691+

1692+fanIntSubscribed :: FastWeakBagTicket k -> FanInt x a -> IO (EventSubscribed x)

1693+fanIntSubscribed ticket self = do

1694+ subscribedParent <- _eventSubscription_subscribed <$> readIORef (_fanInt_subscriptionRef self)

1695+ return $ EventSubscribed

1696+ { eventSubscribedHeightRef = eventSubscribedHeightRef subscribedParent

1697+ , eventSubscribedRetained = toAny (_fanInt_subscriptionRef self, ticket)

1698+#ifdef DEBUG_CYCLES

1699+ , eventSubscribedGetParents = return [subscribedParent]

1700+ , eventSubscribedHasOwnHeightRef = False

1701+ , eventSubscribedWhoCreated = whoCreatedIORef $ _fanInt_subscriptionRef self

1702+#endif

1703+ }

1704+

1531

1705

1532{-# INLINABLE getFanSubscribed #-}

1706{-# INLINABLE getFanSubscribed #-}

1533getFanSubscribed :: (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))

@@ -1710,22 +1884,22 @@ subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceS

1710{-# INLINE mergeG #-}

1884{-# INLINE mergeG #-}

1711mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k)

1885mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k)

1712 => (forall a. q a -> Event x (v a))

1886 => (forall a. q a -> Event x (v a))

1713− -> Dynamic x (PatchDMap k q) -> Event x (DMap k v)

1887+ -> DynamicS x (PatchDMap k q) -> Event x (DMap k v)

1714mergeG nt d = cacheEvent (mergeCheap nt d)

1888mergeG nt d = cacheEvent (mergeCheap nt d)

1715

1889

1716{-# INLINE mergeWithMove #-}

1890{-# INLINE mergeWithMove #-}

1717mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k)

1891mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k)

1718 => (forall a. q a -> Event x (v a))

1892 => (forall a. q a -> Event x (v a))

1719− -> Dynamic x (PatchDMapWithMove k q) -> Event x (DMap k v)

1893+ -> DynamicS x (PatchDMapWithMove k q) -> Event x (DMap k v)

1720mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)

1894mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)

1721

1895

1722{-# INLINE [1] mergeCheap #-}

1896{-# INLINE [1] mergeCheap #-}

1723mergeCheap

1897mergeCheap

1724 :: forall k x q v. (HasSpiderTimeline x, GCompare k)

1898 :: forall k x q v. (HasSpiderTimeline x, GCompare k)

1725 => (forall a. q a -> Event x (v a))

1899 => (forall a. q a -> Event x (v a))

1726− -> Dynamic x (PatchDMap k q)

1900+ -> DynamicS x (PatchDMap k q)

1727 -> Event x (DMap k v)

1901 -> Event x (DMap k v)

1728−mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy

1902+mergeCheap nt = mergeGCheap' unMergeSubscribedParent getInitialSubscribers updateMe destroy

1729 where

1903 where

1730 updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)

1904 updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)

1731 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do

1905 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do

@@ -1740,7 +1914,9 @@ mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy

1740 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight

1914 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight

1741 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps

1915 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps

1742 forM_ mOldSubd $ \oldSubd -> do

1916 forM_ mOldSubd $ \oldSubd -> do

1917+ oldHeight <- liftIO $ getEventSubscribedHeight $

1743− oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd

1918+ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd

1919+

1744 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

1920 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

1745 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)

1921 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)

1746 foldM f ([], oldParents) $ DMap.toList p

1922 foldM f ([], oldParents) $ DMap.toList p

@@ -1763,9 +1939,9 @@ mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy

1763{-# INLINE [1] mergeCheapWithMove #-}

1939{-# INLINE [1] mergeCheapWithMove #-}

1764mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)

1940mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)

1765 => (forall a. q a -> Event x (v a))

1941 => (forall a. q a -> Event x (v a))

1766− -> Dynamic x (PatchDMapWithMove k q)

1942+ -> DynamicS x (PatchDMapWithMove k q)

1767 -> Event x (DMap k v)

1943 -> Event x (DMap k v)

1768−mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy

1944+mergeCheapWithMove nt = mergeGCheap' _mergeSubscribedParentWithMove_subscription getInitialSubscribers updateMe destroy

1769 where

1945 where

1770 updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)

1946 updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)

1771 updateMe subscriber heightBagRef oldParents p = do

1947 updateMe subscriber heightBagRef oldParents p = do

@@ -1784,13 +1960,17 @@ mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy

1784 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

1785 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of

1961 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of

1786 Nothing -> do

1962 Nothing -> do

1787− oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent

1963+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $

1964+ _mergeSubscribedParentWithMove_subscription parent

1965+

1788 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

1966 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

1789 return $ Just $ _mergeSubscribedParentWithMove_subscription parent

1967 return $ Just $ _mergeSubscribedParentWithMove_subscription parent

1790 Just toKey -> do

1968 Just toKey -> do

1791 liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey

1969 liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey

1792 return Nothing

1970 return Nothing

1971+ toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $

1793− toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents

1972+ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents

1973+

1794 return (toDelete, applyAlways p' oldParents)

1974 return (toDelete, applyAlways p' oldParents)

1795 getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)

1975 getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)

1796 getInitialSubscribers initialParents subscriber = do

1976 getInitialSubscribers initialParents subscriber = do

@@ -1815,6 +1995,8 @@ type MergeUpdateFunc k v x p s

1815 -> p

1995 -> p

1816 -> EventM x ([EventSubscription x], DMap k s)

1996 -> EventM x ([EventSubscription x], DMap k s)

1817

1997

1998+type MergeGetSubscription x s = forall a. s a -> EventSubscription x

1999+

1818type MergeInitFunc k v q x s

2000type MergeInitFunc k v q x s

1819 = DMap k q

2001 = DMap k q

1820 -> (forall a. EventM x (k a) -> Subscriber x (v a))

2002 -> (forall a. EventM x (k a) -> Subscriber x (v a))

@@ -1838,14 +2020,17 @@ invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_su

1838invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()

2020invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()

1839invalidateMergeHeight' heightRef sub = do

2021invalidateMergeHeight' heightRef sub = do

1840 oldHeight <- readIORef heightRef

2022 oldHeight <- readIORef heightRef

1841− when (oldHeight /= invalidHeight) $ do -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents

2023+ -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents

2024+ when (oldHeight /= invalidHeight) $ do

1842 writeIORef heightRef $! invalidHeight

2025 writeIORef heightRef $! invalidHeight

1843 subscriberInvalidateHeight sub oldHeight

2026 subscriberInvalidateHeight sub oldHeight

1844

2027

1845revalidateMergeHeight :: Merge x k v s -> IO ()

2028revalidateMergeHeight :: Merge x k v s -> IO ()

1846revalidateMergeHeight m = do

2029revalidateMergeHeight m = do

1847 currentHeight <- readIORef $ _merge_heightRef m

2030 currentHeight <- readIORef $ _merge_heightRef m

2031+

1848− when (currentHeight == invalidHeight) $ do -- 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

2033+ when (currentHeight == invalidHeight) $ do

1849 heights <- readIORef $ _merge_heightBagRef m

2034 heights <- readIORef $ _merge_heightBagRef m

1850 parents <- readIORef $ _merge_parentsRef m

2035 parents <- readIORef $ _merge_parentsRef m

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

@@ -1853,7 +2038,7 @@ revalidateMergeHeight m = do

1853 LT -> return ()

2038 LT -> return ()

1854 EQ -> do

2039 EQ -> do

1855 let height = succHeight $ heightBagMax heights

2040 let height = succHeight $ heightBagMax heights

1856− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height

2041+ traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height

1857 writeIORef (_merge_heightRef m) $! height

2042 writeIORef (_merge_heightRef m) $! height

1858 subscriberRecalculateHeight (_merge_sub m) height

2043 subscriberRecalculateHeight (_merge_sub m) height

1859 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"

@@ -1861,36 +2046,45 @@ revalidateMergeHeight m = do

1861scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()

2046scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()

1862scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do

2047scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do

1863 vals <- liftIO $ readIORef $ _merge_accumRef m

2048 vals <- liftIO $ readIORef $ _merge_accumRef m

1864− liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us, it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers

2049+ -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us,

2050+ -- it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers

2051+ liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty

1865 --TODO: Assert that m is not empty

2052 --TODO: Assert that m is not empty

1866 subscriberPropagate (_merge_sub m) vals

2053 subscriberPropagate (_merge_sub m) vals

1867

2054

2055+checkCycle :: HasSpiderTimeline x => EventSubscribed x -> EventM x ()

2056+checkCycle subscribed = liftIO $ do

2057+ height <- readIORef (eventSubscribedHeightRef subscribed)

2058+

2059+ -- currentHeight <- getCurrentHeight

2060+ -- when (height <= currentHeight) $ if height /= invalidHeight

2061+ -- then do

2062+ -- myStack <- liftIO $ whoCreatedIORef undefined --TODO

2063+ -- error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)

2064+ -- else liftIO $

2065+ when (height == invalidHeight) $

2066+#ifdef DEBUG_CYCLES

2067+ do

2068+ nodesInvolvedInCycle <- walkInvalidHeightParents subscribed

2069+ stacks <- forM nodesInvolvedInCycle whoCreatedEventSubscribed

2070+ throwIO (EventLoopException stacks)

2071+#else

2072+ throwIO EventLoopException

2073+#endif

2074+

2075+

1868−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)

1869−mergeSubscriber m getKey = Subscriber

2077+mergeSubscriber subscribed m getKey = Subscriber

1870 { subscriberPropagate = \a -> do

2078 { subscriberPropagate = \a -> do

1871 oldM <- liftIO $ readIORef $ _merge_accumRef m

2079 oldM <- liftIO $ readIORef $ _merge_accumRef m

1872 k <- getKey

2080 k <- getKey

1873− let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k a oldM

2081+ let newM = DMap.insertWith (error "Same key fired multiple times for Merge") k a oldM

1874 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)

2082 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)

1875 liftIO $ writeIORef (_merge_accumRef m) $! newM

2083 liftIO $ writeIORef (_merge_accumRef m) $! newM

1876 when (DMap.null oldM) $ do -- Only schedule the firing once

2084 when (DMap.null oldM) $ do -- Only schedule the firing once

1877 height <- liftIO $ readIORef $ _merge_heightRef m

2085 height <- liftIO $ readIORef $ _merge_heightRef m

1878− --TODO: assertions about height

2086+ checkCycle subscribed

1879− currentHeight <- getCurrentHeight

2087+

1880− when (height <= currentHeight) $ do

1881− if height /= invalidHeight

1882− then do

1883− myStack <- liftIO $ whoCreatedIORef undefined --TODO

1884− error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)

1885− else liftIO $ do

1886−#ifdef DEBUG_CYCLES

1887− nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed

1888− stacks <- forM nodesInvolvedInCycle $ \(Some es) -> whoCreatedEventSubscribed es

1889− let cycleInfo = ":\n" <> drawForest (listsToForest stacks)

1890−#else

1891− let cycleInfo = ""

1892−#endif

1893− error $ "Causality loop found" <> cycleInfo

1894 scheduleMergeSelf m height

2088 scheduleMergeSelf m height

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

1896 modifyIORef' (_merge_heightBagRef m) $ heightBagRemove old

2090 modifyIORef' (_merge_heightBagRef m) $ heightBagRemove old

@@ -1901,31 +2095,45 @@ mergeSubscriber m getKey = Subscriber

1901 }

2095 }

1902

2096

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

1904−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

1905−updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)

2099+updateMerge subscribed m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)

1906 where updateMe = do

2100 where updateMe = do

1907 oldParents <- liftIO $ readIORef $ _merge_parentsRef m

2101 oldParents <- liftIO $ readIORef $ _merge_parentsRef m

1908− (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber m) (_merge_heightBagRef m) oldParents p

2102+ (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber subscribed m) (_merge_heightBagRef m) oldParents p

1909 liftIO $ writeIORef (_merge_parentsRef m) $! newParents

2103 liftIO $ writeIORef (_merge_parentsRef m) $! newParents

1910 return subscriptionsToKill

2104 return subscriptionsToKill

1911

2105

1912{-# INLINE mergeGCheap' #-}

2106{-# INLINE mergeGCheap' #-}

1913mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)

2107mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)

1914− => MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> Dynamic x p -> Event x (DMap k v)

2108+ => MergeGetSubscription x s -> MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> DynamicS x p -> Event x (DMap k v)

1915−mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do

2109+mergeGCheap' getParent getInitialSubscribers updateFunc destroy d = Event $ \sub -> do

1916 initialParents <- readBehaviorUntracked $ dynamicCurrent d

2110 initialParents <- readBehaviorUntracked $ dynamicCurrent d

1917 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"

2111 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"

1918 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"

2112 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"

1919 heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"

2113 heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"

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

1921− let m = Merge

2129+ m = Merge

1922 { _merge_parentsRef = parentsRef

2130 { _merge_parentsRef = parentsRef

1923 , _merge_heightBagRef = heightBagRef

2131 , _merge_heightBagRef = heightBagRef

1924 , _merge_heightRef = heightRef

2132 , _merge_heightRef = heightRef

1925 , _merge_sub = sub

2133 , _merge_sub = sub

1926 , _merge_accumRef = accumRef

2134 , _merge_accumRef = accumRef

1927 }

2135 }

1928− (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber m

2136+ (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber subscribed m

1929 let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights

2137 let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights

1930 myHeight = if invalidHeight `elem` heights

2138 myHeight = if invalidHeight `elem` heights

1931 then invalidHeight

2139 then invalidHeight

@@ -1934,50 +2142,57 @@ mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do

1934 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

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

1936 else (Nothing, dm)

2144 else (Nothing, dm)

1937− unless (DMap.null accum) $ do

1938− scheduleMergeSelf m myHeight

2145+ unless (DMap.null accum) $ scheduleMergeSelf m myHeight

1939 liftIO $ writeIORef accumRef $! accum

2146 liftIO $ writeIORef accumRef $! accum

1940 liftIO $ writeIORef heightRef $! myHeight

2147 liftIO $ writeIORef heightRef $! myHeight

1941 liftIO $ writeIORef heightBagRef $! myHeightBag

2148 liftIO $ writeIORef heightBagRef $! myHeightBag

1942− changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"

1943 liftIO $ writeIORef parentsRef $! initialParentState

2149 liftIO $ writeIORef parentsRef $! initialParentState

1944 defer $ SomeMergeInit $ do

2150 defer $ SomeMergeInit $ do

1945− let s = Subscriber

2151+ let changeSubscriber = Subscriber

1946 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

2152 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

1947− tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change"

2153+ tracePropagate (Proxy :: Proxy x) "SubscriberMerge/Change"

1948− defer $ updateMerge m updateFunc a

2154+ defer $ updateMerge subscribed m updateFunc a

1949 , subscriberInvalidateHeight = \_ -> return ()

2155 , subscriberInvalidateHeight = \_ -> return ()

1950 , subscriberRecalculateHeight = \_ -> return ()

2156 , subscriberRecalculateHeight = \_ -> return ()

1951 }

2157 }

1952− (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s

2158+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) changeSubscriber

1953− forM_ change $ \c -> defer $ updateMerge m updateFunc c

2159+ forM_ change $ \c -> defer $ updateMerge subscribed m updateFunc c

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

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

1956 -- its subscription.

2162 -- its subscription.

1957− liftIO $ writeIORef changeSubdRef (s, changeSubscription)

2163+ liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)

1958 let unsubscribeAll = destroy =<< readIORef parentsRef

2164 let unsubscribeAll = destroy =<< readIORef parentsRef

1959− return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parentsRef, changeSubdRef)

1960− , occ

1961− )

1962

2165

2166+ return (EventSubscription unsubscribeAll subscribed, occ)

2167+

2168+

1963−mergeInt :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)

2169+mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)

1964mergeInt = cacheEvent . mergeIntCheap

2170mergeInt = cacheEvent . mergeIntCheap

1965

2171

1966{-# INLINABLE mergeIntCheap #-}

2172{-# INLINABLE mergeIntCheap #-}

1967−mergeIntCheap :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)

2173+mergeIntCheap :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)

1968mergeIntCheap d = Event $ \sub -> do

2174mergeIntCheap d = Event $ \sub -> do

1969 initialParents <- readBehaviorUntracked $ dynamicCurrent d

2175 initialParents <- readBehaviorUntracked $ dynamicCurrent d

1970 accum <- liftIO $ FastMutableIntMap.newEmpty

2176 accum <- liftIO $ FastMutableIntMap.newEmpty

1971 heightRef <- liftIO $ newIORef zeroHeight

2177 heightRef <- liftIO $ newIORef zeroHeight

1972 heightBagRef <- liftIO $ newIORef heightBagEmpty

2178 heightBagRef <- liftIO $ newIORef heightBagEmpty

1973 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+ }

1974 let scheduleSelf = do

2190 let scheduleSelf = do

1975 height <- liftIO $ readIORef $ heightRef

2191 height <- liftIO $ readIORef $ heightRef

1976 scheduleMerge' height heightRef $ do

2192 scheduleMerge' height heightRef $ do

1977 vals <- liftIO $ FastMutableIntMap.getFrozenAndClear accum

2193 vals <- liftIO $ FastMutableIntMap.getFrozenAndClear accum

1978 subscriberPropagate sub vals

2194 subscriberPropagate sub vals

1979− invalidateMyHeight = do

1980− invalidateMergeHeight' heightRef sub

2195+ invalidateMyHeight = invalidateMergeHeight' heightRef sub

1981 recalculateMyHeight = do

2196 recalculateMyHeight = do

1982 currentHeight <- readIORef heightRef

2197 currentHeight <- readIORef heightRef

1983 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?

@@ -1987,12 +2202,14 @@ mergeIntCheap d = Event $ \sub -> do

1987 LT -> return ()

2202 LT -> return ()

1988 EQ -> do

2203 EQ -> do

1989 let height = succHeight $ heightBagMax heights

2204 let height = succHeight $ heightBagMax heights

1990− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height

2205+ traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height

1991 writeIORef heightRef $! height

2206 writeIORef heightRef $! height

1992 subscriberRecalculateHeight sub height

2207 subscriberRecalculateHeight sub height

1993 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"

1994 mySubscriber k = Subscriber

2209 mySubscriber k = Subscriber

1995 { subscriberPropagate = \a -> do

2210 { subscriberPropagate = \a -> do

2211+ checkCycle subscribed

2212+

1996 wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum

2213 wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum

1997 liftIO $ FastMutableIntMap.insert accum k a

2214 liftIO $ FastMutableIntMap.insert accum k a

1998 when wasEmpty scheduleSelf

2215 when wasEmpty scheduleSelf

@@ -2026,7 +2243,6 @@ mergeIntCheap d = Event $ \sub -> do

2026 else liftIO $ Just <$> FastMutableIntMap.getFrozenAndClear accum

2243 else liftIO $ Just <$> FastMutableIntMap.getFrozenAndClear accum

2027 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

2028 return Nothing

2245 return Nothing

2029− changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"

2030 defer $ SomeMergeInit $ do

2246 defer $ SomeMergeInit $ do

2031 let updateMe a = SomeMergeUpdate u invalidateMyHeight recalculateMyHeight

2247 let updateMe a = SomeMergeUpdate u invalidateMyHeight recalculateMyHeight

2032 where

2248 where

@@ -2040,25 +2256,27 @@ mergeIntCheap d = Event $ \sub -> do

2040 oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions

2256 oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions

2041 liftIO $ for_ oldParents $ \oldParent -> do

2257 liftIO $ for_ oldParents $ \oldParent -> do

2042 oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent

2258 oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent

2259+

2260+ print ("updateMe", oldParentHeight)

2043 modifyIORef' heightBagRef $ heightBagRemove oldParentHeight

2261 modifyIORef' heightBagRef $ heightBagRemove oldParentHeight

2044 return $ IntMap.elems oldParents

2262 return $ IntMap.elems oldParents

2045− let s = Subscriber

2263+ let changeSubscriber = Subscriber

2046 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

2264 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

2047 tracePropagate (Proxy :: Proxy x) $ "SubscriberMergeInt/Change"

2265 tracePropagate (Proxy :: Proxy x) $ "SubscriberMergeInt/Change"

2048 defer $ updateMe a

2266 defer $ updateMe a

2049 , subscriberInvalidateHeight = \_ -> return ()

2267 , subscriberInvalidateHeight = \_ -> return ()

2050 , subscriberRecalculateHeight = \_ -> return ()

2268 , subscriberRecalculateHeight = \_ -> return ()

2051 }

2269 }

2052− (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s

2270+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) changeSubscriber

2053 forM_ change $ \c -> defer $ updateMe c

2271 forM_ change $ \c -> defer $ updateMe c

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

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

2056 -- its subscription.

2274 -- its subscription.

2057− liftIO $ writeIORef changeSubdRef (s, changeSubscription)

2275+ liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)

2058 let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents

2276 let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents

2277+

2278+

2059− return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parents, changeSubdRef)

2279+ return (EventSubscription unsubscribeAll subscribed, occ)

2060− , occ

2061− )

2062

2280

2063newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }

2281newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }

2064newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) }

2282newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) }

@@ -2124,7 +2342,7 @@ clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeI

2124-- | Run an event action outside of a frame

2342-- | Run an event action outside of a frame

2125runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex

2343runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex

2126runFrame a = SpiderHost $ do

2344runFrame a = SpiderHost $ do

2127− let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)

2345+ let env = _spiderTimeline_eventEnv $ unSTE (spiderTimeline :: SpiderTimelineEnv x)

2128 let go = do

2346 let go = do

2129 result <- a

2347 result <- a

2130 runHoldInits (eventEnvHoldInits env) (eventEnvDynInits env) (eventEnvMergeInits env) -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events

2348 runHoldInits (eventEnvHoldInits env) (eventEnvDynInits env) (eventEnvMergeInits env) -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events

@@ -2141,19 +2359,19 @@ runFrame a = SpiderHost $ do

2141 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env

2359 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env

2142 forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do

2360 forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do

2143 writeIORef vRef v

2361 writeIORef vRef v

2144− when debugInvalidate $ putStrLn $ "Invalidating Hold"

2362+ traceInvalidate $ "Invalidating Hold"

2145 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef

2363 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef

2146 mergeUpdates <- readIORef $ eventEnvMergeUpdates env

2364 mergeUpdates <- readIORef $ eventEnvMergeUpdates env

2147 writeIORef (eventEnvMergeUpdates env) []

2365 writeIORef (eventEnvMergeUpdates env) []

2148− when debugPropagate $ putStrLn "Updating merges"

2366+ tracePropagate (Proxy::Proxy x) $ "Updating merges"

2149 mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates

2367 mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates

2150− when debugPropagate $ putStrLn "Updating merges done"

2368+ tracePropagate (Proxy::Proxy x) $ "Updating merges done"

2151 toReconnect <- readIORef toReconnectRef

2369 toReconnect <- readIORef toReconnectRef

2152 clearEventEnv env

2370 clearEventEnv env

2153 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do

2371 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do

2154 oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed

2372 oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed

2155 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed

2373 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed

2156− when debugInvalidate $ putStrLn $ "Finalizing invalidator for Switch" <> showNodeId subscribed

2374+ traceInvalidate $ "Finalizing invalidator for Switch" <> showNodeId subscribed

2157 finalize wi

2375 finalize wi

2158 i <- evaluate $ switchSubscribedOwnInvalidator subscribed

2376 i <- evaluate $ switchSubscribedOwnInvalidator subscribed

2159 wi' <- mkWeakPtrWithDebug i "wi'"

2377 wi' <- mkWeakPtrWithDebug i "wi'"

@@ -2167,7 +2385,7 @@ runFrame a = SpiderHost $ do

2167 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

2168 {-

2386 {-

2169 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)

2387 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)

2170− liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of

2388+ liftIO $ debugStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of

2171 EventRoot _ -> "EventRoot"

2389 EventRoot _ -> "EventRoot"

2172 EventNever -> "EventNever"

2390 EventNever -> "EventNever"

2173 _ -> "something else"

2391 _ -> "something else"

@@ -2182,7 +2400,7 @@ runFrame a = SpiderHost $ do

2182 myHeight <- readIORef $ switchSubscribedHeight subscribed

2400 myHeight <- readIORef $ switchSubscribedHeight subscribed

2183 when (parentHeight /= myHeight) $ do

2401 when (parentHeight /= myHeight) $ do

2184 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight

2402 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight

2185− WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight

2403+ WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight

2186 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

2187 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do

2405 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do

2188 unsubscribe subscription

2406 unsubscribe subscription

@@ -2223,7 +2441,7 @@ invalidateCoincidenceHeight subscribed = do

2223 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed

2441 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed

2224 when (oldHeight /= invalidHeight) $ do

2442 when (oldHeight /= invalidHeight) $ do

2225 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight

2443 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight

2226− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

2444+ WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

2227

2445

2228updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()

2446updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()

2229updateSwitchHeight new subscribed = do

2447updateSwitchHeight new subscribed = do

@@ -2231,7 +2449,7 @@ updateSwitchHeight new subscribed = do

2231 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

2232 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

2233 writeIORef (switchSubscribedHeight subscribed) $! new

2451 writeIORef (switchSubscribedHeight subscribed) $! new

2234− WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new

2452+ WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new

2235

2453

2236recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()

2454recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()

2237recalculateCoincidenceHeight subscribed = do

2455recalculateCoincidenceHeight subscribed = do

@@ -2240,7 +2458,7 @@ recalculateCoincidenceHeight subscribed = do

2240 height <- calculateCoincidenceHeight subscribed

2458 height <- calculateCoincidenceHeight subscribed

2241 when (height /= invalidHeight) $ do

2459 when (height /= invalidHeight) $ do

2242 writeIORef (coincidenceSubscribedHeight subscribed) $! height

2460 writeIORef (coincidenceSubscribedHeight subscribed) $! height

2243− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height

2461+ WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height

2244

2462

2245calculateSwitchHeight :: SwitchSubscribed x a -> IO Height

2463calculateSwitchHeight :: SwitchSubscribed x a -> IO Height

2246calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)

2464calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)

@@ -2302,6 +2520,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Event

2302 {-# INLINABLE headE #-}

2520 {-# INLINABLE headE #-}

2303 headE = R.slowHeadE

2521 headE = R.slowHeadE

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

2305

2525

2306instance Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where

2526instance Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where

2307 {-# INLINABLE sample #-}

2527 {-# INLINABLE sample #-}

@@ -2323,6 +2543,9 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide

2323 {-# INLINABLE headE #-}

2543 {-# INLINABLE headE #-}

2324 headE = R.slowHeadE

2544 headE = R.slowHeadE

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

2326

2549

2327instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where

2550instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where

2328 {-# INLINE return #-}

2551 {-# INLINE return #-}

@@ -2331,11 +2554,13 @@ instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x))

2331 x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x

2554 x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x

2332 {-# INLINE (>>) #-}

2555 {-# INLINE (>>) #-}

2333 (>>) = (*>)

2556 (>>) = (*>)

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

2334 {-# INLINE fail #-}

2558 {-# INLINE fail #-}

2335 fail _ = error "Dynamic does not support 'fail'"

2559 fail _ = error "Dynamic does not support 'fail'"

2560+#endif

2336

2561

2337{-# INLINABLE newJoinDyn #-}

2562{-# INLINABLE newJoinDyn #-}

2338−newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)

2563+newJoinDyn :: HasSpiderTimeline x => DynamicS x (Identity (DynamicS x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)

2339newJoinDyn d =

2564newJoinDyn d =

2340 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)

2565 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)

2341 eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d

2566 eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d

@@ -2384,6 +2609,9 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide

2384 buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e

2609 buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e

2385 {-# INLINABLE headE #-}

2610 {-# INLINABLE headE #-}

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

2387

2615

2388instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where

2616instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where

2389 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

@@ -2400,6 +2628,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide

2400 {-# INLINABLE headE #-}

2628 {-# INLINABLE headE #-}

2401 headE = R.slowHeadE

2629 headE = R.slowHeadE

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

2403

2633

2404instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where

2634instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where

2405 {-# INLINABLE sample #-}

2635 {-# INLINABLE sample #-}

@@ -2420,6 +2650,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Refle

2420 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

2421 {-# INLINABLE headE #-}

2651 {-# INLINABLE headE #-}

2422 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

2423

2655

2424--------------------------------------------------------------------------------

2656--------------------------------------------------------------------------------

2425-- Deprecated items

2657-- Deprecated items

@@ -2457,13 +2689,13 @@ instance HasSpiderTimeline x => Reflex.Host.Class.MonadReadEvent (SpiderTimeline

2457 touch h

2689 touch h

2458 return result

2690 return result

2459

2691

2460−instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where

2692+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where

2461 newEventWithTrigger = SpiderHost . fmap SpiderEvent . newEventWithTriggerIO

2693 newEventWithTrigger = SpiderHost . fmap SpiderEvent . newEventWithTriggerIO

2462 newFanEventWithTrigger f = SpiderHost $ do

2694 newFanEventWithTrigger f = SpiderHost $ do

2463 es <- newFanEventWithTriggerIO f

2695 es <- newFanEventWithTriggerIO f

2464 return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es

2696 return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es

2465

2697

2466−instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where

2698+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where

2467 newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO

2699 newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO

2468 newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do

2700 newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do

2469 es <- newFanEventWithTriggerIO f

2701 es <- newFanEventWithTriggerIO f

@@ -2485,7 +2717,7 @@ unsafeNewSpiderTimelineEnv = do

2485#ifdef DEBUG

2717#ifdef DEBUG

2486 depthRef <- newIORef 0

2718 depthRef <- newIORef 0

2487#endif

2719#endif

2488− return $ SpiderTimelineEnv

2720+ return $ STE $ SpiderTimelineEnv

2489 { _spiderTimeline_lock = lock

2721 { _spiderTimeline_lock = lock

2490 , _spiderTimeline_eventEnv = env

2722 , _spiderTimeline_eventEnv = env

2491#ifdef DEBUG

2723#ifdef DEBUG

@@ -2501,13 +2733,13 @@ data LocalSpiderTimeline (x :: Type) s

2501

2733

2502instance Reifies s (SpiderTimelineEnv x) =>

2734instance Reifies s (SpiderTimelineEnv x) =>

2503 HasSpiderTimeline (LocalSpiderTimeline x s) where

2735 HasSpiderTimeline (LocalSpiderTimeline x s) where

2504− spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s)

2736+ spiderTimeline = localSpiderTimeline Proxy $ reflect (Proxy :: Proxy s)

2505

2737

2506localSpiderTimeline

2738localSpiderTimeline

2507− :: Proxy s

2739+ :: proxy s

2508 -> SpiderTimelineEnv x

2740 -> SpiderTimelineEnv x

2509 -> SpiderTimelineEnv (LocalSpiderTimeline x s)

2741 -> SpiderTimelineEnv (LocalSpiderTimeline x s)

2510−localSpiderTimeline _ = unsafeCoerce

2742+localSpiderTimeline _ = coerce

2511

2743

2512-- | Pass a new timeline to the given function.

2744-- | Pass a new timeline to the given function.

2513withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r

2745withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r

@@ -2525,8 +2757,8 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2525 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}

2757 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}

2526 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }

2758 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }

2527 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }

2759 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }

2528− newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad)

2760+ newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: DynamicS x (Identity a) } -- deriving (Functor, Applicative, Monad)

2529− newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }

2761+ newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: DynamicS x p }

2530 type PullM (SpiderTimeline x) = SpiderPullM x

2762 type PullM (SpiderTimeline x) = SpiderPullM x

2531 type PushM (SpiderTimeline x) = SpiderPushM x

2763 type PushM (SpiderTimeline x) = SpiderPushM x

2532 {-# INLINABLE never #-}

2764 {-# INLINABLE never #-}

@@ -2543,7 +2775,7 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2543 fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))

2775 fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))

2544 {-# INLINABLE mergeG #-}

2776 {-# INLINABLE mergeG #-}

2545 mergeG

2777 mergeG

2546− :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k

2778+ :: forall k2 (k :: k2 -> *) q (v :: k2 -> *). GCompare k

2547 => (forall a. q a -> R.Event (SpiderTimeline x) (v a))

2779 => (forall a. q a -> R.Event (SpiderTimeline x) (v a))

2548 -> DMap k q

2780 -> DMap k q

2549 -> R.Event (SpiderTimeline x) (DMap k v)

2781 -> R.Event (SpiderTimeline x) (DMap k v)

@@ -2555,7 +2787,7 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2555 {-# INLINABLE current #-}

2787 {-# INLINABLE current #-}

2556 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic

2788 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic

2557 {-# INLINABLE updated #-}

2789 {-# INLINABLE updated #-}

2558− updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic

2790+ updated = SpiderEvent #. dynamicUpdated .# fmap coerce . unSpiderDynamic

2559 {-# INLINABLE unsafeBuildDynamic #-}

2791 {-# INLINABLE unsafeBuildDynamic #-}

2560 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'

2792 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'

2561 {-# INLINABLE unsafeBuildIncremental #-}

2793 {-# INLINABLE unsafeBuildIncremental #-}

@@ -2574,9 +2806,10 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2574 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'

2806 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'

2575 eventCoercion Coercion = Coercion

2807 eventCoercion Coercion = Coercion

2576 behaviorCoercion Coercion = Coercion

2808 behaviorCoercion Coercion = Coercion

2577− dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance

2809+ dynamicCoercion Coercion = Coercion

2810+ incrementalCoercion Coercion Coercion = Coercion

2578 {-# INLINABLE mergeIntIncremental #-}

2811 {-# INLINABLE mergeIntIncremental #-}

2579− mergeIntIncremental = SpiderEvent . mergeInt . (unsafeCoerce :: Dynamic x (PatchIntMap (R.Event (SpiderTimeline x) a)) -> Dynamic x (PatchIntMap (Event x a))) . unSpiderIncremental

2812+ mergeIntIncremental = SpiderEvent . mergeInt . coerce

2580 {-# INLINABLE fanInt #-}

2813 {-# INLINABLE fanInt #-}

2581 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))

2814 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))

2582

2815

@@ -2610,8 +2843,14 @@ instance Monad (SpiderHost x) where

2610 SpiderHost x >> SpiderHost y = SpiderHost $ x >> y

2843 SpiderHost x >> SpiderHost y = SpiderHost $ x >> y

2611 {-# INLINABLE return #-}

2844 {-# INLINABLE return #-}

2612 return x = SpiderHost $ return x

2845 return x = SpiderHost $ return x

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

2613 {-# INLINABLE fail #-}

2847 {-# INLINABLE fail #-}

2848+ fail = MonadFail.fail

2849+#endif

2850+

2851+instance MonadFail (SpiderHost x) where

2852+ {-# INLINABLE fail #-}

2614− fail s = SpiderHost $ fail s

2853+ fail s = SpiderHost $ MonadFail.fail s

2615

2854

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

2617-- a mutex for that timeline

2856-- a mutex for that timeline

@@ -2633,19 +2872,21 @@ instance Monad (SpiderHostFrame x) where

2633 SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y

2872 SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y

2634 {-# INLINABLE return #-}

2873 {-# INLINABLE return #-}

2635 return x = SpiderHostFrame $ return x

2874 return x = SpiderHostFrame $ return x

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

2636 {-# INLINABLE fail #-}

2876 {-# INLINABLE fail #-}

2637 fail s = SpiderHostFrame $ fail s

2877 fail s = SpiderHostFrame $ fail s

2878+#endif

2638

2879

2639instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where

2880instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where

2640 notReadyUntil _ = pure ()

2881 notReadyUntil _ = pure ()

2641 notReady = pure ()

2882 notReady = pure ()

2642

2883

2643−newEventWithTriggerIO :: (RootTrigger x a -> IO (IO ())) -> IO (Event x a)

2884+newEventWithTriggerIO :: forall x a. HasSpiderTimeline x => (RootTrigger x a -> IO (IO ())) -> IO (Event x a)

2644newEventWithTriggerIO f = do

2885newEventWithTriggerIO f = do

2645 es <- newFanEventWithTriggerIO $ \Refl -> f

2886 es <- newFanEventWithTriggerIO $ \Refl -> f

2646 return $ select es Refl

2887 return $ select es Refl

2647

2888

2648−newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)

2889+newFanEventWithTriggerIO :: (HasSpiderTimeline x, GCompare k) => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)

2649newFanEventWithTriggerIO f = do

2890newFanEventWithTriggerIO f = do

2650 occRef <- newIORef DMap.empty

2891 occRef <- newIORef DMap.empty

2651 subscribedRef <- newIORef DMap.empty

2892 subscribedRef <- newIORef DMap.empty

@@ -2679,3 +2920,11 @@ instance MonadAtomicRef (SpiderHostFrame x) where

2679instance PrimMonad (SpiderHostFrame x) where

2920instance PrimMonad (SpiderHostFrame x) where

2680 type PrimState (SpiderHostFrame x) = PrimState IO

2921 type PrimState (SpiderHostFrame x) = PrimState IO

2681 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−1

@@ -2,7 +2,6 @@

2-- new 'Event's that can be triggered from 'IO'.

3{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FunctionalDependencies #-}

5−{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE UndecidableInstances #-}

5{-# LANGUAGE UndecidableInstances #-}

7module Reflex.TriggerEvent.Class

6module Reflex.TriggerEvent.Class

8 ( TriggerEvent (..)

7 ( TriggerEvent (..)

@@ -13,6 +12,7 @@ import Reflex.Class

13import Control.Monad.Reader

12import Control.Monad.Reader

14import Control.Monad.State

13import Control.Monad.State

15import qualified Control.Monad.State.Strict as Strict

14import qualified Control.Monad.State.Strict as Strict

15+import Control.Monad.Trans.Maybe (MaybeT)

17--TODO: Shouldn't have IO hard-coded

18-- | 'TriggerEvent' represents actions that can create 'Event's that can be

@@ -48,3 +48,8 @@ instance TriggerEvent t m => TriggerEvent t (Strict.StateT s m) where

48 newTriggerEvent = lift newTriggerEvent

49 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

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.hsnew file+171

@@ -0,0 +1,171 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ConstraintKinds #-}

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE GADTs #-}

5+{-# LANGUAGE RecursiveDo #-}

6+{-# LANGUAGE ScopedTypeVariables #-}

7+{-# LANGUAGE PatternSynonyms #-}

8+{-# LANGUAGE RankNTypes #-}

10+module Main where

11+

12+import Data.Foldable

13+import Control.Lens

14+import Control.Applicative

15+import Control.Monad

16+import Control.Monad.Fix

17+import Control.Exception

18+import System.Timeout

19+import Data.Maybe (isJust)

20+import Data.Functor.Misc

21+import qualified Data.Map as Map

22+import Data.Map (Map)

23+import qualified Data.IntMap as IntMap

24+import Data.IntMap (IntMap)

25+import Data.These

26+import Data.Align

27+import Reflex

28+import Reflex.EventWriter.Base

29+import Test.Run

30+import Test.Hspec

31+import Reflex.Spider.Internal (EventLoopException)

32+import Data.Witherable (Filterable)

33+

34+#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))

35+import Data.These.Lens

36+#endif

37+

38+type Widget t m = (MonadHold t m, Reflex t, MonadFix m)

39+

40+connectDyn :: Widget t m => Event t () -> (Dynamic t a, Dynamic t a) -> m (Dynamic t a)

41+connectDyn e (d, d') = do

42+ dd <- holdDyn d (d' <$ e)

43+ return $ join dd

44+

45+dynLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

46+dynLoop (e1, e2) = do

47+ -- "heightBagRemove: Height 2 not present in bag HeightBag {_heightBag_size = 2, _heightBag_contents = fromList [(0,1)]}"

48+ rec

49+ d <- count e1

50+ d' <- connectDyn e2 (d, liftA2 (+) d d')

51+ return $ updated d'

52+

53+connectOnCoincidence :: Widget t m => Event t () -> Event t a -> m (Event t a)

54+connectOnCoincidence click e = do

55+ d <- holdDyn never (e <$ click)

56+ return $ coincidence (updated d)

57+

58+coincidenceLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

59+coincidenceLoop (e1, e2) = do

60+-- "heightBagRemove: Height 1 not present in bag HeightBag {_heightBag_size = 1, _heightBag_contents = fromList [(0,0)]}"

61+-- (simpler version of dynLoop)

62+ rec

63+ e' <- connectOnCoincidence e2 (updated d)

64+ d <- count (align e' e1)

65+ return $ updated d

66+

67+addHeight :: Reflex t => Event t a -> Event t a

68+addHeight e = leftmost [e4, e4] where

69+ e1 = leftmost [e, e]

70+ e2 = leftmost [e1, e1]

71+ e3 = leftmost [e2, e2]

72+ e4 = leftmost [e3, e3]

73+

74+-- Take an existing test and build it inside a

75+buildLoop :: Widget t m => (forall t m. Widget t m => (Event t Int, Event t ()) -> m (Event t Int)) -> (Event t Int, Event t ()) -> m (Event t Int)

76+buildLoop test (e1, e2) = switchHold never buildLoop

77+ where buildLoop = pushAlways (const $ test (e1, e2)) e2

78+

79+connectButtonPromptly :: Widget t m => Event t () -> Event t a -> m (Event t a)

80+connectButtonPromptly click e = do

81+ d <- holdDyn never (e <$ click)

82+ return (switchDyn d)

83+

84+connectButton :: Widget t m => Event t () -> Event t a -> m (Event t a)

85+connectButton click e = do

86+ d <- hold never (e <$ click)

87+ return (switch d)

88+

89+switchLoop01 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

90+switchLoop01 (e1, e2) = do

91+ rec

92+ e' <- connectButton e2 (updated d)

93+ d <- count (align e' e1)

94+ return $ updated d

95+

96+mergeLoop :: forall t m. (Adjustable t m, Widget t m) => (Event t Int, Event t ()) -> m (Event t Int)

97+mergeLoop (e1, e2) = do

98+ rec

99+ (_, e) <- runEventWriterT $

100+ runWithReplace w (leftmost [w <$ e1])

101+ return (sum <$> e)

102+ where

103+ w = do

104+ c <- count e1

105+ tellEvent (updated ((pure <$> c) :: Dynamic t [Int]))

106+

107+switchLoop02 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

108+switchLoop02 (e1, e2) = do

109+ rec

110+ e' <- connectButton e2 (updated d)

111+ d <- count (leftmost [e', e1])

112+ return $ updated d

113+

114+switchLoop03 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

115+switchLoop03 (e1, e2) = do

116+ rec

117+ e' <- connectButton e2 (addHeight $ updated d)

118+ d <- count (align e' e1)

119+ return $ updated d

120+

121+staticLoop01 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

122+staticLoop01 (e1, e2) = do

123+ rec

124+ d <- foldDyn (+) (0 :: Int) (1 <$ align e1 (updated d))

125+ return $ updated d

126+

127+staticLoop02 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

128+staticLoop02 (e1, e2) = do

129+ rec

130+ d <- foldDyn (+) (0 :: Int) (leftmost [e1, updated d])

131+ return $ updated d

132+

133+buildStaticLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

134+buildStaticLoop (e1, e2) = switchHold never buildLoop

135+ where buildLoop = pushAlways (const $ staticLoop01 (e1, e2)) e2

136+

137+splitThese :: Filterable f => f (These a b) -> (f a, f b)

138+splitThese f = (mapMaybe (preview here) f, mapMaybe (preview there) f)

139+

140+main :: IO ()

141+main = hspec $ do

142+ describe "DebugCycles" $ do

143+ it "throws EventLoopException on switchLoop01" $ do

144+ check switchLoop01

145+ it "throws EventLoopException on switchLoop02" $ do

146+ check switchLoop02

147+ it "throws EventLoopException on switchLoop03" $ do

148+ check switchLoop03

149+ it "throws EventLoopException on buildSwitchLoop" $ do

150+ check $ buildLoop switchLoop01

151+ xit "throws EventLoopException on mergeLoop" $ do

152+ check mergeLoop

153+ xit "throws EventLoopException on staticLoop01" $ do

154+ check staticLoop01

155+ xit "throws EventLoopException on staticLoop02" $ do

156+ check staticLoop02

157+ xit "throws EventLoopException on buildStaticLoop" $ do

158+ check buildStaticLoop

159+ xit "throws EventLoopException on coincidenceLoop" $ do

160+ check coincidenceLoop

161+ xit "throws EventLoopException on dynLoop" $ do

162+ check dynLoop

163+ xit "throws EventLoopException on buildCoincidenceLoop" $ do

164+ check $ buildLoop coincidenceLoop

165+ where

166+ milliseconds = (*1000)

167+ occs = [ This 1, This 2, That (), This 3, That (), This 1 ]

168+ check test = do

169+ let action = timeout (milliseconds 50) $ do

170+ runApp' (test . splitThese) (Just <$> occs)

171+ action `shouldThrow` (const True :: Selector EventLoopException)

test/GC.hs+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+12

@@ -130,6 +130,16 @@ mapDynChain = iterM (return . fmap (+1))

130joinDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

131joinDynChain = iterM (\d -> return $ join $ fmap (const d) d)

132

133+holdDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

134+holdDynChain = iterM (\d -> sample (current d) >>= flip holdDyn (updated d))

135+

136+buildDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

137+buildDynChain = iterM (\d -> do

138+ let b = fmap (+1) (current d)

139+ e = fmap (*2) (updated d)

140+ buildDynamic (sample b) e)

141+

142+

133combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

143combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

134combineDynChain = iterM (\d -> return $ zipDynWith (+) d d)

144combineDynChain = iterM (\d -> return $ zipDynWith (+) d d)

135

145

@@ -308,6 +318,8 @@ dynamics :: Word -> [(String, TestCase)]

308dynamics n =

318dynamics n =

309 [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d

319 [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d

310 , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d

320 , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d

321+ , testE "holdDynChain" $ fmap updated $ holdDynChain n =<< d

322+ , testE "buildDynChain" $ fmap updated $ buildDynChain n =<< d

311 , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d

323 , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d

312 , testE "dense mergeTree" $ fmap (updated . mergeTreeDyn 8) dense

324 , testE "dense mergeTree" $ fmap (updated . mergeTreeDyn 8) dense

313 , testE "sparse mergeTree" $ fmap (updated . mergeTreeDyn 8) sparse

325 , testE "sparse mergeTree" $ fmap (updated . mergeTreeDyn 8) sparse

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+18−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))

@@ -218,6 +223,11 @@ testCases =

218 bb <- hold b $ pushAlways (const $ hold "asdf" eo) eo

223 bb <- hold b $ pushAlways (const $ hold "asdf" eo) eo

219 let b' = pull $ sample =<< sample bb

224 let b' = pull $ sample =<< sample bb

220 return (b', e)

225 return (b', e)

226+ , (,) "foldDynWhileFiring" $ TestCase (Map.singleton 0 "zxc", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(_, e) -> do

227+ d <- foldDyn (:) [] $

228+ pushAlways (\a -> foldDyn (:) [a] e) e

229+ let b = current (join (fmap distributeListOverDynPure d))

230+ return (b, e)

221 , (,) "joinDyn" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

231 , (,) "joinDyn" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

222 bb <- hold "b" e

232 bb <- hold "b" e

223 bd <- hold never . fmap (const e) =<< headE e

233 bd <- hold never . fmap (const e) =<< headE e

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− ]