0071805...develop · reflex

git.iko.soy/reflex

66 files changed+1971−2001

since splitsnapshots

unifiedsplit

.github/workflows/haskell.yml+41 .travis.yml−169 CONTRIBUTING.md+4 ChangeLog.md+121−6 Quickref.md+15−11 README.md+15−17 cabal.haskell-ci+17−1 default.nix−42 dep/reflex-platform/default.nix+7 dep/reflex-platform/github.json+7 hydra.json−29 jobsets.nix−70 reflex-platform.nix−8 reflex.cabal+151−49 release.nix+56−7 src/Control/Monad/ReaderIO.hs+60 src/Data/AppendMap.hs+7−3 src/Data/FastMutableIntMap.hs+7−3 src/Data/FastWeakBag.hs+9−4 src/Data/Functor/Misc.hs−234 src/Data/Map/Misc.hs+1−1 src/Data/WeakBag.hs+8−3 src/Reflex/Adjustable/Class.hs+3−2 src/Reflex/BehaviorWriter/Base.hs+16−7 src/Reflex/BehaviorWriter/Class.hs+11−5 src/Reflex/Class.hs+56−12 src/Reflex/Collection.hs+5−2 src/Reflex/Dynamic.hs+17−2 src/Reflex/DynamicWriter/Base.hs+14−5 src/Reflex/DynamicWriter/Class.hs−2 src/Reflex/EventWriter/Base.hs+16−5 src/Reflex/FastWeak.hs+10 src/Reflex/Host/Headless.hs+128 src/Reflex/Network.hs+1−1 src/Reflex/Patch.hs−46 src/Reflex/Patch/Class.hs−34 src/Reflex/Patch/DMap.hs−82 src/Reflex/Patch/DMapWithMove.hs−363 src/Reflex/Patch/IntMap.hs−59 src/Reflex/Patch/Map.hs−55 src/Reflex/Patch/MapWithMove.hs−270 src/Reflex/PerformEvent/Base.hs+3−1 src/Reflex/PerformEvent/Class.hs+6−1 src/Reflex/PostBuild/Base.hs+2−1 src/Reflex/PostBuild/Class.hs−1 src/Reflex/Profiled.hs+70−12 src/Reflex/Pure.hs+9−2 src/Reflex/Query/Base.hs+15−4 src/Reflex/Query/Class.hs+44−4 src/Reflex/Requester/Base.hs+97−27 src/Reflex/Spider/Internal.hs+562−313 src/Reflex/TriggerEvent/Base.hs+2 src/Reflex/TriggerEvent/Class.hs+6−1 src/Reflex/Widget/Basic.hs+1−1 src/Reflex/Workflow.hs+1−1 test/Adjustable.hs+62 test/DebugCycles.hs+171 test/GC.hs+2−2 test/Headless.hs+10 test/QueryT.hs+1−1 test/Reflex/Bench/Focused.hs+12 test/Reflex/Plan/Pure.hs+1 test/Reflex/Test/CrossImpl.hs+18−8 test/Reflex/Test/Micro.hs+8−2 test/RequesterT.hs+63−2 test/hlint.hs+2−8

.github/workflows/haskell.ymlnew file+41

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

1+name: github-action

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

@@ -1,169 +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− - "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"

123− - cat cabal.project || true

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

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

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

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

128− - rm cabal.project.freeze

129−script:

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

131− # Packaging...

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

133− # Unpacking...

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

135− - cd ${DISTDIR} || false

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

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

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

139− # Generate cabal.project

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

141− - touch cabal.project

142− - |

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

144− - |

145− - "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"

146− - cat cabal.project || true

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

148− # Building...

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

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

151− # Building with tests and benchmarks...

152− # build & run tests, build benchmarks

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

154− # Testing...

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

156− # cabal check...

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

158− # haddock...

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

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

161− - rm -f cabal.project.local

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

163− # Constraint sets

164− - rm -rf cabal.project.local

165− # Constraint set no-th

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

167−

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

169−# EOF

CONTRIBUTING.md+4

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

4545

4646Make 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!

4747

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+

4852### Documentation

4953

5054#### In the code

ChangeLog.md+121−6

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

11# 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+

3101## 0.6.2.1

4102

5103* 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

7111

8112* Generalize merging functions:

9− `merge` to `mergeG`,

10− `mergeIncremental` to `mergeIncrementalG`,

11− `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`,

12− `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`.

113+ `merge` to `mergeG`,

114+ `mergeIncremental` to `mergeIncrementalG`,

115+ `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`.

13116

117+* Generalize distribute function:

118+ `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`,

14119

15120## 0.6.2.0

16121

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

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

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

124+

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

126+

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

21128

22129## 0.6.1.0

23130

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

132+

25133* Fix `QueryT` and `RequesterT` tests

26134

27135## 0.6.0.0 -- 2019-03-20

28136

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

138+

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

140+

31141* Remove many deprecated functions.

142+

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

144+

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

146+

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

148+

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

150+

36151* 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

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

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

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

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

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

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

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

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

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

199200There 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.

200201

201−Th typeclasses and their associated annotations include:

202+The typeclasses and their associated annotations include:

202203

203204- `PostBuild`

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

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

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

207208 ```

208209

209−- `Adjustable`

210+- `Adjustable`

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

211212 ```haskell

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

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

271272```haskell

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

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

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

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

277278

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

295296## Networks

296297

297298```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)

299300

300−-- 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,

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

302+

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

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

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

304307

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

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

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

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

309312

310313-- 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/).**

1010

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

11+## Resources

1212

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

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

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

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

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

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

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

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

1420

15−### Resources

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

21+## Hacking

1722

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

19−

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

21−

22−### Hacking

23−

24−Use the `./scripts/hack-on reflex` script in [Reflex Platform](https://github.com/reflex-frp/reflex-platform) to checkout the source code of `reflex` locally in `reflex-platform/reflex` directory.

25−Then do modifications to the source in place, and use the `./try-reflex` or `./scripts/work-on` scripts to create the shell to test your changes.

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

cabal.haskell-ci+17−1

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

1−distribution: bionic

1+distribution: xenial

2+benchmarks: False

3+unconstrained: False

4+installed: -all

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

47install-dependencies: False

69constraint-set no-th

710 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+151−49

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

11Name: reflex

2−Version: 0.6.2.2

2+Version: 0.8.2.0

33Synopsis: Higher-order Functional Reactive Programming

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

4+Description:

5+ Interactive programs without callbacks or side-effects.

6+ Functional Reactive Programming (FRP) uses composable events and time-varying

7+ values to describe interactive systems as pure functions.

8+ Just like other pure functional code, functional reactive code is easier

9+ to get right on the first try, maintain, and reuse.

10+ .

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

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

13+ .

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

515License: BSD3

616License-file: LICENSE

717Author: Ryan Trinkle

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

919Stability: Experimental

1020Category: FRP

1121Build-type: Simple

12−Cabal-version: >=1.9.2

22+Cabal-version: 1.22

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

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

1525extra-source-files:

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

1828 ChangeLog.md

1929

2030tested-with:

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

22− GHCJS ==8.4

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

32+ GHCJS ==8.6

2333

2434flag use-reflex-optimizer

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

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

4151 default: False

4252 manual: True

4353

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+

4464flag split-these

4565 description: Use split these/semialign packages

4666 manual: False

4767 default: True

4868

4969library

70+ default-language: Haskell2010

5071 hs-source-dirs: src

5172 build-depends:

5273 MemoTrie == 0.6.*,

53− base >= 4.9 && < 4.13,

74+ base >= 4.11 && < 4.15,

5475 bifunctors >= 5.2 && < 5.6,

5576 comonad >= 5.0.4 && < 5.1,

77+ constraints >= 0.10 && <0.14,

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

5779 containers >= 0.6 && < 0.7,

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

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

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

6082 exception-transformers == 0.4.*,

61− profunctors >= 5.3 && < 5.5,

6283 lens >= 4.7 && < 5,

84+ mmorph >= 1.0 && < 1.2,

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

6486 mtl >= 2.1 && < 2.3,

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

87+ patch >= 0.0.1 && < 0.1,

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

6689 primitive >= 0.5 && < 0.8,

90+ profunctors >= 5.3 && < 5.7,

6791 random == 1.1.*,

6892 ref-tf == 0.4.*,

6993 reflection == 2.1.*,

7094 semigroupoids >= 4.0 && < 6,

7195 stm >= 2.4 && < 2.6,

7296 syb >= 0.5 && < 0.8,

73− time >= 1.4 && < 1.9,

97+ time >= 1.4 && < 1.10,

7498 transformers >= 0.5.6.0 && < 0.6,

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

76− witherable >= 0.2 && < 0.4

100+ witherable >= 0.3 && < 0.5

77101

78102 if flag(split-these)

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

80− semialign >=1 && <1.1,

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

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

104+ semialign >=1 && <1.2,

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

82106 else

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

84− monoidal-containers == 0.5.0.0

108+ monoidal-containers == 0.4.0.0

85109

86110 exposed-modules:

111+ Control.Monad.ReaderIO

87112 Data.AppendMap,

88113 Data.FastMutableIntMap,

89114 Data.FastWeakBag,

90− Data.Functor.Misc,

91115 Data.Map.Misc,

92116 Data.WeakBag,

93117 Reflex,

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

107131 Reflex.FastWeak,

108132 Reflex.FunctorMaybe,

109133 Reflex.Host.Class,

134+ Reflex.Host.Headless,

110135 Reflex.Network,

111136 Reflex.NotReady.Class,

112− Reflex.Patch,

113− Reflex.Patch.Class,

114− Reflex.Patch.DMap,

115− Reflex.Patch.DMapWithMove,

116− Reflex.Patch.IntMap,

117− Reflex.Patch.Map,

118− Reflex.Patch.MapWithMove,

119137 Reflex.PerformEvent.Base,

120138 Reflex.PerformEvent.Class,

121139 Reflex.PostBuild.Base,

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

134152 Reflex.Widget.Basic,

135153 Reflex.Workflow

136154

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+

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

138166

139167 if flag(debug-trace-events)

140168 cpp-options: -DDEBUG_TRACE_EVENTS

141− build-depends: bytestring

169+ build-depends:

170+ bytestring >= 0.10.8 && < 0.11

142171

143172 if flag(use-reflex-optimizer)

144173 cpp-options: -DUSE_REFLEX_OPTIMIZER

145174 build-depends: ghc

146175 exposed-modules: Reflex.Optimizer

147176

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+

148183 if flag(use-template-haskell)

149184 cpp-options: -DUSE_TEMPLATE_HASKELL

150185 build-depends:

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

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

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

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

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

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

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

155190 exposed-modules:

156191 Reflex.Dynamic.TH

157192 other-extensions: TemplateHaskell

158193 else

159194 build-depends:

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

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

161196

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

163198 cpp-options: -DGHCJS_FAST_WEAK

164199

165200 if impl(ghcjs)

166− build-depends: ghcjs-base

201+ build-depends:

202+ ghcjs-base == 0.2.*

167203

168204test-suite semantics

205+ default-language: Haskell2010

169206 type: exitcode-stdio-1.0

170207 main-is: semantics.hs

171208 hs-source-dirs: test

@@ -174,7 +211,7 @@ test-suite semantics

174211 base,

175212 bifunctors,

176213 containers,

177− deepseq >= 1.3 && < 1.5,

214+ deepseq,

178215 dependent-map,

179216 dependent-sum,

180217 mtl,

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

191228 Reflex.TestPlan

192229

193230test-suite CrossImpl

231+ default-language: Haskell2010

194232 type: exitcode-stdio-1.0

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

196234 hs-source-dirs: test

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

200238 containers,

201239 dependent-map,

202240 dependent-sum,

203− deepseq >= 1.3 && < 1.5,

241+ deepseq,

204242 mtl,

205243 transformers,

206244 ref-tf,

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

212250 Reflex.Plan.Pure

213251

214252test-suite hlint

253+ default-language: Haskell2010

215254 type: exitcode-stdio-1.0

216255 main-is: hlint.hs

217256 hs-source-dirs: test

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

219258 , directory

220259 , filepath

221260 , filemanip

222− , 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

223265 if impl(ghcjs)

224266 buildable: False

225267

226268test-suite EventWriterT

269+ default-language: Haskell2010

227270 type: exitcode-stdio-1.0

228271 main-is: EventWriterT.hs

229272 hs-source-dirs: test

230273 build-depends: base

231274 , containers

232− , deepseq >= 1.3 && < 1.5

275+ , deepseq

233276 , dependent-map

234277 , dependent-sum

235278 , lens

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

243286 build-depends: these-lens

244287

245288 other-modules:

246− Reflex.Test

247− Reflex.TestPlan

248− Reflex.Plan.Reflex

249− Reflex.Plan.Pure

250289 Test.Run

251290

252291

253−test-suite RequesterT

292+test-suite DebugCycles

293+ default-language: Haskell2010

254294 type: exitcode-stdio-1.0

255− main-is: RequesterT.hs

295+ main-is: DebugCycles.hs

256296 hs-source-dirs: test

297+ ghc-options: -threaded

257298 build-depends: base

258299 , containers

259− , deepseq >= 1.3 && < 1.5

260− , dependent-sum

300+ , deepseq

261301 , dependent-map

302+ , dependent-sum

303+ , hspec

262304 , lens

263305 , mtl

264306 , these

265307 , transformers

266308 , reflex

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

268340

269341 if flag(split-these)

270342 build-depends: these-lens

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

274346 Reflex.Plan.Pure

275347 Test.Run

276348

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+

277372test-suite QueryT

373+ default-language: Haskell2010

278374 type: exitcode-stdio-1.0

279375 main-is: QueryT.hs

280376 hs-source-dirs: test

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

282378 , containers

283379 , dependent-map

284380 , dependent-sum

285− , deepseq >= 1.3 && < 1.5

381+ , deepseq

286382 , lens

287383 , monoidal-containers

288384 , mtl

385+ , patch

289386 , ref-tf

290387 , reflex

291388 , these

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

301398 Reflex.Plan.Pure

302399

303400test-suite GC-Semantics

401+ default-language: Haskell2010

304402 type: exitcode-stdio-1.0

305403 main-is: GC.hs

306404 hs-source-dirs: test

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

308406 , containers

309407 , dependent-sum

310408 , dependent-map

311− , deepseq >= 1.3 && < 1.5

409+ , deepseq

312410 , mtl

411+ , patch

313412 , these

314413 , transformers

315414 , reflex

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

325424 Test.Run

326425

327426test-suite rootCleanup

427+ default-language: Haskell2010

328428 type: exitcode-stdio-1.0

329429 main-is: rootCleanup.hs

330430 hs-source-dirs: test

331431 build-depends: base

332432 , containers

333− , deepseq >= 1.3 && < 1.5

433+ , deepseq

334434 , dependent-sum

335435 , mtl

336436 , reflex

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

342442 Test.Run

343443

344444benchmark spider-bench

445+ default-language: Haskell2010

345446 type: exitcode-stdio-1.0

346447 hs-source-dirs: bench test

347448 main-is: Main.hs

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

349450 build-depends:

350451 base,

351452 containers,

352− criterion >= 1.1 && < 1.6,

353− deepseq >= 1.3 && < 1.5,

453+ criterion,

454+ deepseq,

354455 dependent-map,

355456 dependent-sum,

356457 ref-tf,

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

359460 reflex,

360461 split,

361462 stm,

362− transformers >= 0.3

463+ transformers

363464 other-modules:

364465 Reflex.TestPlan

365466 Reflex.Plan.Reflex

366467 Reflex.Bench.Focused

367468

368469benchmark saulzar-bench

470+ default-language: Haskell2010

369471 type: exitcode-stdio-1.0

370472 hs-source-dirs: bench test

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

@@ -374,8 +476,8 @@ benchmark saulzar-bench

374476 build-depends:

375477 base,

376478 containers,

377− criterion >= 1.1 && < 1.6,

378− deepseq >= 1.3 && < 1.5,

479+ criterion,

480+ deepseq,

379481 dependent-map,

380482 dependent-sum,

381483 loch-th,

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"]

23}:

35let

4− inherit (rp.nixpkgs) lib;

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

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

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

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

9−}))

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

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

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

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

11+ compilers = [

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

2020 , module Data.Map.Monoidal

2121 ) where

2222

23−import Prelude hiding (map, null)

23+import Prelude hiding (null)

2424

2525import Data.Coerce

2626import Data.Default

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

3232#endif

3333import qualified Data.Witherable as W

3434import Data.Map.Monoidal

35+import qualified Data.Map.Monoidal as MonoidalMap

36+

3537

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

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

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

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

4749pattern AppendMap m = MonoidalMap m

4850

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

4952instance W.Filterable (MonoidalMap k) where

50− mapMaybe = mapMaybe

53+ mapMaybe = MonoidalMap.mapMaybe

54+#endif

5155

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

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

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

6771 then Nothing

6872 else Just bs

6973

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

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

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

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

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

src/Data/FastMutableIntMap.hs+7−3

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

2121 , patchIntMapNewElements

2222 , patchIntMapNewElementsMap

2323 , getDeletions

24+ , toList

2425 ) where

2526

2627--TODO: Pure JS version

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

3435import Data.IntMap.Strict (IntMap)

3536import qualified Data.IntMap.Strict as IntMap

3637import Data.IORef

37−import Reflex.Patch.Class

38−import Reflex.Patch.IntMap

38+import Data.Patch.Class

39+import Data.Patch.IntMap

3940

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

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

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

8485 writeIORef r IntMap.empty

8586 return result

8687

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

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

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

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

9192 v <- readIORef r

9293 writeIORef r $! applyAlways p v

9394 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

1818 , isEmpty

1919 , insert

2020 , traverse

21+ , traverse_

2122 , remove

2223 -- * Internal functions

2324 -- These will not always be available.

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

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

117118#endif

118119

119−{-# INLINE traverse #-}

120+{-# INLINE traverse_ #-}

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

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

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

123124-- 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 ()

125126#ifdef GHCJS_FAST_WEAK

126−traverse wb f = do

127+traverse_ wb f = do

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

128129 val <- liftIO $ js_getTicketValue cursor

129130 f $ unsafeFromRawJSVal val

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

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

135136foreign 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

136137#else

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

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

138139 cs <- liftIO $ readIORef children

139140 forM_ cs $ \c -> do

140141 ma <- liftIO $ deRefWeak c

141142 mapM_ f ma

142143#endif

143144

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

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

147+traverse = traverse_

148+

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

145150-- on the same 'FastWeakBagTicket'.

146151{-# 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

4343

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

4545--

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

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

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

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

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

src/Data/WeakBag.hs+8−3

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

1515 , singleton

1616 , insert

1717 , traverse

18+ , traverse_

1819 , remove

1920 -- * Internal functions

2021 -- These will not always be available.

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

99100 ticket <- insert a bag wbRef finalizer

100101 return (bag, ticket)

101102

102−{-# INLINE traverse #-}

103+{-# INLINE traverse_ #-}

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

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

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

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

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

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

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

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

109110 cs <- liftIO $ readIORef children

110111 forM_ cs $ \c -> do

111112 ma <- liftIO $ deRefWeak c

112113 mapM_ f ma

113114

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

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

117+traverse = traverse_

118+

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

115120-- on the same 'WeakBagTicket'.

116121{-# INLINE remove #-}

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

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

3030

3131import Control.Monad.Identity

3232import Control.Monad.Reader

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

33+import Data.Dependent.Map (DMap)

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

3435import qualified Data.Dependent.Map as DMap

3536import Data.Functor.Constant

3637import Data.Functor.Misc

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

3940import Data.Map (Map)

4041

4142import Reflex.Class

42−import Reflex.Patch.DMapWithMove

43+import Data.Patch.DMapWithMove

4344

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

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

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

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

11{-|

22Module: Reflex.BehaviorWriter.Base

3−Description: Implementation of MonadBehaviorWriter

3+Description: Implementation of BehaviorWriter

44-}

55{-# LANGUAGE CPP #-}

66{-# LANGUAGE FlexibleInstances #-}

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

2424import Control.Monad.Exception

2525import Control.Monad.Identity

2626import Control.Monad.IO.Class

27+import Control.Monad.Morph

2728import Control.Monad.Reader

2829import Control.Monad.Ref

2930import Control.Monad.State.Strict

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

4647import Reflex.Requester.Class

4748import Reflex.TriggerEvent.Class

4849

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

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

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

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

52+ -- The list is kept in reverse order

53+ deriving

54+ ( Functor

55+ , Applicative

56+ , Monad

57+ , MonadTrans

58+ , MFunctor

59+ , MonadIO

60+ , MonadFix

61+ , MonadAsyncException

62+ , MonadException

63+ )

5264

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

5466-- along with the result of the action.

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

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

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

7587

76−instance MonadTrans (BehaviorWriterT t w) where

77− lift = BehaviorWriterT . lift

78−

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

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

8190 newRef = lift . newRef

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

8998 newEventWithTrigger = lift . newEventWithTrigger

9099 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

91100

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

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

93102 tellBehavior w = BehaviorWriterT $ modify (w :)

94103

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

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

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

11{-|

22Module: Reflex.BehaviorWriter.Class

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

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

44-}

55{-# LANGUAGE CPP #-}

6+{-# LANGUAGE ConstraintKinds #-}

67{-# LANGUAGE FlexibleInstances #-}

78{-# LANGUAGE FunctionalDependencies #-}

89{-# LANGUAGE UndecidableInstances #-}

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

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

1112#endif

1213module Reflex.BehaviorWriter.Class

13− ( MonadBehaviorWriter (..)

14+ ( MonadBehaviorWriter

15+ , BehaviorWriter(..)

1416 ) where

1517

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

1719import Reflex.Class (Behavior)

1820

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

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

22+-- | Type synonym for 'BehaviorWriter'

23+type MonadBehaviorWriter = BehaviorWriter

24+

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

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

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

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

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

2329

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

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

2531 tellBehavior = lift . tellBehavior

src/Reflex/Class.hs+56−12

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

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

3030-- signals.

3131module Reflex.Class

32− ( module Reflex.Patch

32+ ( module Data.Patch

3333 -- * Primitives

3434 , Reflex (..)

3535 , mergeInt

3636 , coerceBehavior

3737 , coerceEvent

3838 , coerceDynamic

39+ , coerceIncremental

3940 , MonadSample (..)

4041 , MonadHold (..)

4142 -- ** 'fan' related types

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

172173 , slowHeadE

173174 ) where

174175

175−#if defined(MIN_VERSION_semialign)

176+#ifdef MIN_VERSION_semialign

176177import Prelude hiding (zip, zipWith)

177178

178179#if MIN_VERSION_these(0,8,0)

179180import Data.These.Combinators (justThese)

180181#endif

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

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

184+#endif

181185#endif

182186

183187import Control.Applicative

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

192196import Data.Bifunctor

193197import Data.Coerce

194198import Data.Default

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

199+import Data.Dependent.Map (DMap)

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

196201import qualified Data.Dependent.Map as DMap

197202import Data.Functor.Compose

198203import Data.Functor.Product

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

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

200205import Data.FastMutableIntMap (PatchIntMap)

201206import Data.Foldable

202207import Data.Functor.Bind

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

206211import qualified Data.IntMap.Strict as IntMap

207212import Data.List.NonEmpty (NonEmpty (..))

208213import Data.Map (Map)

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

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

210215import Data.Some (Some(Some))

211216import Data.String

212217import Data.These

213218import Data.Type.Coercion

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

214220import Data.Witherable (Filterable(..))

215221import qualified Data.Witherable as W

216222import Reflex.FunctorMaybe (FunctorMaybe)

217223import qualified Reflex.FunctorMaybe

218−import Reflex.Patch

219−import qualified Reflex.Patch.MapWithMove as PatchMapWithMove

224+import Data.Patch

225+import qualified Data.Patch.MapWithMove as PatchMapWithMove

220226

221227import Debug.Trace (trace)

222228

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

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

283289 -- 'Event' occurs

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

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

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

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

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

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

320327 -- occurrence type

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

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

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

324335

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

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

353364coerceDynamic = coerceWith $ dynamicCoercion Coercion

354365

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+

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

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

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

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

405422 -- the supplied 'Event'.

406423 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

407431

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

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

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

549573 holdIncremental a0 = lift . holdIncremental a0

550574 buildDynamic a0 = lift . buildDynamic a0

551575 headE = lift . headE

576+ now = lift now

552577

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

554579 sample = lift . sample

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

559584 holdIncremental a0 = lift . holdIncremental a0

560585 buildDynamic a0 = lift . buildDynamic a0

561586 headE = lift . headE

587+ now = lift now

562588

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

564590 sample = lift . sample

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

569595 holdIncremental a0 = lift . holdIncremental a0

570596 buildDynamic a0 = lift . buildDynamic a0

571597 headE = lift . headE

598+ now = lift now

572599

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

574601 sample = lift . sample

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

579606 holdIncremental a0 = lift . holdIncremental a0

580607 buildDynamic a0 = lift . buildDynamic a0

581608 headE = lift . headE

609+ now = lift now

582610

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

584612 sample = lift . sample

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

589617 holdIncremental a0 = lift . holdIncremental a0

590618 buildDynamic a0 = lift . buildDynamic a0

591619 headE = lift . headE

620+ now = lift now

592621

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

594623 sample = lift . sample

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

599628 holdIncremental a0 = lift . holdIncremental a0

600629 buildDynamic a0 = lift . buildDynamic a0

601630 headE = lift . headE

631+ now = lift now

602632

603633--------------------------------------------------------------------------------

604634-- Convenience functions

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

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

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

650680 return = constant

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

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

683+#endif

652684

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

654686 mempty = constant mempty

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

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

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

705737

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

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

707739instance 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+

709744

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

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

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

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

10631098#endif

10641099 align = alignEventWithMaybe Just

1065−

1066−#if defined(MIN_VERSION_semialign)

1100+

1101+#ifdef MIN_VERSION_semialign

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

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

1104+#endif

10671105 zip x y = mapMaybe justThese $ align x y

10681106#endif

10691107

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

10701114

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

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

src/Reflex/Collection.hs+5−2

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

2727 , simpleList

2828 ) where

2929

30−#if defined(MIN_VERSION_semialign)

30+#ifdef MIN_VERSION_semialign

3131import Prelude hiding (zip, zipWith)

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

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

34+#endif

3235#endif

3336

3437import Control.Monad.Identity

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

127130 Nothing -> Just Nothing

128131

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

130− Just _ -> Nothing

133+ Just _ -> Nothing

131134 listHoldWithKey

132135 initialVals

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

src/Reflex/Dynamic.hs+17−2

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

5353 , foldDynMaybe

5454 , foldDynMaybeM

5555 , joinDynThroughMap

56+ , joinDynThroughIntMap

5657 , traceDyn

5758 , traceDynWith

5859 , splitDynPure

5960 , distributeMapOverDynPure

61+ , distributeIntMapOverDynPure

6062 , distributeDMapOverDynPure

6163 , distributeListOverDynPure

6264 , Demux

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

8789import Data.Dependent.Map (DMap)

8890import qualified Data.Dependent.Map as DMap

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

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

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

93+import Data.IntMap (IntMap)

94+import qualified Data.IntMap as IntMap

9195import Data.Map (Map)

9296import Data.Maybe

9397import Data.Monoid ((<>))

9498import Data.These

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

95100

96101import Debug.Trace

97102

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

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

202207distributeMapOverDynPure = fmap dmapToMap . distributeDMapOverDynPure . mapWithFunctorToDMap

203208

209+-- | Convert an 'IntMap' with 'Dynamic' elements into a 'Dynamic' of an 'IntMap' with

210+-- non-'Dynamic' elements.

211+distributeIntMapOverDynPure :: (Reflex t) => IntMap (Dynamic t v) -> Dynamic t (IntMap v)

212+distributeIntMapOverDynPure = fmap dmapToIntMap . distributeDMapOverDynPure . intMapWithFunctorToDMap

213+

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

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

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

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

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

214224joinDynThroughMap = (distributeMapOverDynPure =<<)

215225

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

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

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

229+joinDynThroughIntMap = (distributeIntMapOverDynPure =<<)

230+

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

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

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

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

333348--

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

335350--

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

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

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

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

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

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

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

2222import Control.Monad.Exception

2323import Control.Monad.Identity

2424import Control.Monad.IO.Class

25+import Control.Monad.Morph

2526import Control.Monad.Primitive

2627import Control.Monad.Reader

2728import Control.Monad.Ref

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

4445import Reflex.DynamicWriter.Class

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

4647import Reflex.Host.Class

47−import qualified Reflex.Patch.MapWithMove as MapWithMove

48+import qualified Data.Patch.MapWithMove as MapWithMove

4849import Reflex.PerformEvent.Class

4950import Reflex.PostBuild.Class

5051import Reflex.Query.Class

5152import Reflex.Requester.Class

5253import Reflex.TriggerEvent.Class

5354

54−instance MonadTrans (DynamicWriterT t w) where

55− lift = DynamicWriterT . lift

56−

5755mapIncrementalMapValues :: (Reflex t, Patch (p v), Patch (p v'), PatchTarget (p v) ~ f v, PatchTarget (p v') ~ f v', Functor p, Functor f) => (v -> v') -> Incremental t (p v) -> Incremental t (p v')

5856mapIncrementalMapValues f = unsafeMapIncremental (fmap f) (fmap f)

5957

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

9088

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

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

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

91+ -- The list is kept in reverse order

92+ deriving

93+ ( Functor

94+ , Applicative

95+ , Monad

96+ , MonadTrans

97+ , MFunctor

98+ , MonadIO

99+ , MonadFix

100+ , MonadAsyncException

101+ , MonadException

102+ )

94103

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

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

src/Reflex/DynamicWriter/Class.hs−2

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

33{-# LANGUAGE CPP #-}

44{-# LANGUAGE FlexibleInstances #-}

55{-# LANGUAGE FunctionalDependencies #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

76{-# LANGUAGE UndecidableInstances #-}

87#ifdef USE_REFLEX_OPTIMIZER

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

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

2726

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

2928 tellDyn = lift . tellDyn

30−

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

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

3535

3636import Control.Monad.Exception

3737import Control.Monad.Identity

38+import Control.Monad.Morph

3839import Control.Monad.Primitive

3940import Control.Monad.Reader

4041import Control.Monad.Ref

4142import Control.Monad.State.Strict

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

43+import Data.Dependent.Map (DMap)

4344import qualified Data.Dependent.Map as DMap

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

4446import Data.Functor.Compose

4547import Data.Functor.Misc

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

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

9698

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

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

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

101+ deriving

102+ ( Functor

103+ , Applicative

104+ , Monad

105+ , MonadTrans

106+ , MFunctor

107+ , MonadFix

108+ , MonadIO

109+ , MonadException

110+ , MonadAsyncException

111+ )

100112

101113-- | Run a 'EventWriterT' action.

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

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

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

117129 }

118130

119−instance MonadTrans (EventWriterT t w) where

120− lift = EventWriterT . lift

121−

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

123132 sample = lift . sample

124133

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

133142 buildDynamic a0 = lift . buildDynamic a0

134143 {-# INLINABLE headE #-}

135144 headE = lift . headE

145+ {-# INLINABLE now #-}

146+ now = lift now

136147

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

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

src/Reflex/FastWeak.hs+10

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

151151

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

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

154+--

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

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

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

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

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

160+--

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

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

163+{-# NOINLINE mkFastWeakTicket #-}

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

155165-- I think it's fine if this is lazy - it'll retain the 'a', but so would the output; we just need to make sure it's forced before we start relying on the

156166-- associated FastWeak to actually be weak

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

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

1+{-# LANGUAGE LambdaCase #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE RankNTypes #-}

4+{-# LANGUAGE TypeFamilies #-}

5+{-# LANGUAGE ConstraintKinds #-}

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

2020import Reflex.PostBuild.Class

2121

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

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

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

2626networkView :: (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

141141 case mToPerform of

142142 Nothing -> return [result']

143143 Just toPerform -> do

144− responses <- runHostFrame $ traverseRequesterData (\v -> Identity <$> v) toPerform

144+ responses <- runHostFrame $ traverseRequesterData (fmap Identity) toPerform

145145 mrt <- readRef responseTrigger

146146 let followupEventTriggers = case mrt of

147147 Just rt -> [rt :=> Identity responses]

@@ -164,6 +164,8 @@ instance (ReflexHost t, MonadHold t m) => MonadHold t (PerformEventT t m) where

164164 buildDynamic getV0 v' = PerformEventT $ lift $ buildDynamic getV0 v'

165165 {-# INLINABLE headE #-}

166166 headE = PerformEventT . lift . headE

167+ {-# INLINABLE now #-}

168+ now = PerformEventT . lift $ now

167169

168170instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m) where

169171 type Ref (PerformEventT t m) = Ref (HostFrame t)

src/Reflex/PerformEvent/Class.hs+6−1

@@ -8,7 +8,6 @@

88{-# LANGUAGE RankNTypes #-}

99{-# LANGUAGE ScopedTypeVariables #-}

1010{-# LANGUAGE TypeFamilies #-}

11−{-# LANGUAGE TypeOperators #-}

1211{-# LANGUAGE UndecidableInstances #-}

1312#ifdef USE_REFLEX_OPTIMIZER

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

@@ -22,6 +21,7 @@ import Reflex.Class

2221import Reflex.TriggerEvent.Class

2322

2423import Control.Monad.Reader

24+import Control.Monad.Trans.Maybe (MaybeT (..))

2525

2626-- | 'PerformEvent' represents actions that can trigger other actions based on

2727-- 'Event's.

@@ -61,3 +61,8 @@ instance PerformEvent t m => PerformEvent t (ReaderT r m) where

6161 performEvent e = do

6262 r <- ask

6363 lift $ performEvent $ flip runReaderT r <$> e

64+

65+instance PerformEvent t m => PerformEvent t (MaybeT m) where

66+ type Performable (MaybeT m) = MaybeT (Performable m)

67+ performEvent_ = lift . performEvent_ . fmapCheap (void . runMaybeT)

68+ performEvent = lift . fmap (fmapMaybe id) . performEvent . fmapCheap runMaybeT

src/Reflex/PostBuild/Base.hs+2−1

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

99{-# LANGUAGE RecursiveDo #-}

1010{-# LANGUAGE ScopedTypeVariables #-}

1111{-# LANGUAGE TypeFamilies #-}

12−{-# LANGUAGE TypeOperators #-}

1312{-# LANGUAGE UndecidableInstances #-}

1413#ifdef USE_REFLEX_OPTIMIZER

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

@@ -84,6 +83,8 @@ instance MonadHold t m => MonadHold t (PostBuildT t m) where

8483 buildDynamic a0 = lift . buildDynamic a0

8584 {-# INLINABLE headE #-}

8685 headE = lift . headE

86+ {-# INLINABLE now #-}

87+ now = lift now

8788

8889instance PerformEvent t m => PerformEvent t (PostBuildT t m) where

8990 type Performable (PostBuildT t m) = Performable m

src/Reflex/PostBuild/Class.hs−1

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

66{-# LANGUAGE FunctionalDependencies #-}

77{-# LANGUAGE ScopedTypeVariables #-}

88{-# LANGUAGE TypeFamilies #-}

9−{-# LANGUAGE TypeOperators #-}

109{-# LANGUAGE UndecidableInstances #-}

1110#ifdef USE_REFLEX_OPTIMIZER

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

src/Reflex/Profiled.hs+70−12

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

99{-# LANGUAGE TypeFamilies #-}

1010{-# LANGUAGE UndecidableInstances #-}

1111{-# LANGUAGE PolyKinds #-}

12+{-# LANGUAGE TypeApplications #-}

1213{-# LANGUAGE RankNTypes #-}

1314-- |

1415-- Module:

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

2526import Control.Monad.Reader

2627import Control.Monad.Ref

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

29+import Data.Bifunctor

2830import Data.Coerce

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

31+import Data.Dependent.Map (DMap)

32+import Data.GADT.Compare (GCompare)

3033import Data.FastMutableIntMap

3134import Data.IORef

3235import Data.List

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

4144import GHC.Foreign

4245import GHC.IO.Encoding

4346import GHC.Stack

47+import Reflex.Adjustable.Class

48+import Reflex.BehaviorWriter.Class

4449import Reflex.Class

50+import Reflex.DynamicWriter.Class

51+import Reflex.EventWriter.Class

4552import Reflex.Host.Class

53+import Reflex.NotReady.Class

4654import Reflex.PerformEvent.Class

55+import Reflex.PostBuild.Class

56+import Reflex.Query.Class

57+import Reflex.Requester.Class

58+import Reflex.TriggerEvent.Class

4759

4860import System.IO.Unsafe

49−import Unsafe.Coerce

5061

5162data ProfiledTimeline t

5263

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

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

137148 pull = Behavior_Profiled . pull . coerce

138149 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

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

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

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

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

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

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

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

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

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

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

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

151162 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i

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

153164 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i

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

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

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

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

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

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

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

165+ behaviorCoercion c =

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

167+ eventCoercion c =

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

169+ dynamicCoercion c =

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

171+ incrementalCoercion c d =

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

173+ mergeIntIncremental = Event_Profiled . mergeIntIncremental .

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

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

162176

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

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

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

171185 buildDynamic (ProfiledM v0) (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> buildDynamic v0 v'

172186 headE (Event_Profiled e) = ProfiledM $ Event_Profiled <$> headE e

187+ now = ProfiledM $ Event_Profiled <$> now

173188

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

175190 sample (Behavior_Profiled b) = ProfiledM $ sample b

176191

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+

177202instance MonadTrans ProfiledM where

178203 lift = ProfiledM

179204

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

185210 performEvent_ = lift . performEvent_ . coerce

186211 performEvent = lift . fmap coerce . performEvent . coerce

187212

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+

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

189247 type Ref (ProfiledM m) = Ref m

190248 newRef = lift . newRef

src/Reflex/Pure.hs+9−2

@@ -32,7 +32,8 @@ module Reflex.Pure

3232 ) where

3333

3434import Control.Monad

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

35+import Data.Dependent.Map (DMap)

36+import Data.GADT.Compare (GCompare)

3637import qualified Data.Dependent.Map as DMap

3738import Data.IntMap (IntMap)

3839import qualified Data.IntMap as IntMap

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

8889 then Nothing

8990 else Just currentOccurrences

9091

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

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

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

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

9395

9496 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

128130 behaviorCoercion Coercion = Coercion

129131 eventCoercion Coercion = Coercion

130132 dynamicCoercion Coercion = Coercion

133+ incrementalCoercion Coercion Coercion = Coercion

131134

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

133136

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

208211 Just x -> fromMaybe lastValue $ apply x lastValue

209212

210213 headE = slowHeadE

214+ now t = Event $ guard . (t ==)

215+

216+

217+

src/Reflex/Query/Base.hs+15−4

@@ -16,21 +16,25 @@ module Reflex.Query.Base

1616 , mapQueryResult

1717 , dynWithQueryT

1818 , withQueryT

19+ , mapQueryT

1920 ) where

2021

2122import Control.Applicative (liftA2)

2223import Control.Monad.Exception

2324import Control.Monad.Fix

25+import Control.Monad.Morph

2426import Control.Monad.Primitive

2527import Control.Monad.Reader

2628import Control.Monad.Ref

2729import Control.Monad.State.Strict

2830import Data.Align

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

31+import Data.Dependent.Map (DMap)

3032import qualified Data.Dependent.Map as DMap

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

3134import Data.Foldable

3235import Data.Functor.Compose

3336import Data.Functor.Misc

37+import Data.GADT.Compare (GCompare)

3438import Data.IntMap (IntMap)

3539import qualified Data.IntMap as IntMap

3640import Data.Map (Map)

@@ -46,7 +50,7 @@ import Reflex.DynamicWriter.Class

4650import Reflex.EventWriter.Base

4751import Reflex.EventWriter.Class

4852import Reflex.Host.Class

49−import qualified Reflex.Patch.MapWithMove as MapWithMove

53+import qualified Data.Patch.MapWithMove as MapWithMove

5054import Reflex.PerformEvent.Class

5155import Reflex.PostBuild.Class

5256import Reflex.Query.Class

@@ -134,7 +138,7 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t

134138 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch

135139 return (liftedResult0, liftedResult')

136140

137− traverseDMapWithKeyWithAdjust :: forall (k :: * -> *) v v'. (DMap.GCompare k) => (forall a. k a -> v a -> QueryT t q m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> QueryT t q m (DMap k v', Event t (PatchDMap k v'))

141+ traverseDMapWithKeyWithAdjust :: forall (k :: * -> *) v v'. (GCompare k) => (forall a. k a -> v a -> QueryT t q m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> QueryT t q m (DMap k v', Event t (PatchDMap k v'))

138142 traverseDMapWithKeyWithAdjust f dm0 dm' = do

139143 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)

140144 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v

@@ -179,7 +183,7 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t

179183 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch

180184 return (liftedResult0, liftedResult')

181185

182− traverseDMapWithKeyWithAdjustWithMove :: forall (k :: * -> *) v v'. (DMap.GCompare k) => (forall a. k a -> v a -> QueryT t q m (v' a)) -> DMap k v -> Event t (PatchDMapWithMove k v) -> QueryT t q m (DMap k v', Event t (PatchDMapWithMove k v'))

186+ traverseDMapWithKeyWithAdjustWithMove :: forall (k :: * -> *) v v'. (GCompare k) => (forall a. k a -> v a -> QueryT t q m (v' a)) -> DMap k v -> Event t (PatchDMapWithMove k v) -> QueryT t q m (DMap k v', Event t (PatchDMapWithMove k v'))

183187 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do

184188 let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)

185189 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v

@@ -236,6 +240,9 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t

236240instance MonadTrans (QueryT t q) where

237241 lift = QueryT . lift . lift . lift

238242

243+instance MFunctor (QueryT t q) where

244+ hoist = mapQueryT

245+

239246instance PrimMonad m => PrimMonad (QueryT t q m) where

240247 type PrimState (QueryT t q m) = PrimState m

241248 primitive = lift . primitive

@@ -287,6 +294,10 @@ withQueryT f a = do

287294 (fmapCheap (AdditivePatch . mapQuery f . unAdditivePatch) $ updatedIncremental q)

288295 return result

289296

297+-- | Maps a function over a 'QueryT' that can change the underlying monad

298+mapQueryT :: (forall b. m b -> n b) -> QueryT t q m a -> QueryT t q n a

299+mapQueryT f (QueryT a) = QueryT $ mapStateT (mapEventWriterT (mapReaderT f)) a

300+

290301-- | dynWithQueryT's (Dynamic t QueryMorphism) argument needs to be a group homomorphism at all times in order to behave correctly

291302dynWithQueryT :: (MonadFix m, PostBuild t m, Group q, Additive q, Group q', Additive q', Query q')

292303 => Dynamic t (QueryMorphism q q')

src/Reflex/Query/Class.hs+44−4

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE DeriveDataTypeable #-}

23{-# LANGUAGE FlexibleContexts #-}

34{-# LANGUAGE FlexibleInstances #-}

@@ -21,6 +22,7 @@ module Reflex.Query.Class

2122 , MonadQuery (..)

2223 , tellQueryDyn

2324 , queryDyn

25+ , subQuery

2426 , mapQuery

2527 , mapQueryResult

2628 ) where

@@ -35,6 +37,9 @@ import Data.Map.Monoidal (MonoidalMap)

3537import qualified Data.Map.Monoidal as MonoidalMap

3638import Data.Semigroup (Semigroup(..))

3739import Foreign.Storable

40+import Data.Void

41+import Data.Monoid hiding ((<>))

42+import Control.Applicative

3843

3944import Reflex.Class

4045

@@ -50,6 +55,37 @@ instance (Ord k, Query v) => Query (MonoidalMap k v) where

5055 type QueryResult (MonoidalMap k v) = MonoidalMap k (QueryResult v)

5156 crop q r = MonoidalMap.intersectionWith (flip crop) r q

5257

58+-- | the result of two queries is both results.

59+instance (Query a, Query b) => Query (a, b) where

60+ type QueryResult (a, b) = (QueryResult a, QueryResult b)

61+ crop (x, x') (y, y') = (crop x y, crop x' y')

62+

63+-- | Trivial queries have trivial results.

64+instance Query () where

65+ type QueryResult () = ()

66+ crop _ _ = ()

67+

68+-- | The result of an absurd query is trivial; If you can ask the question, the

69+-- answer cannot tell you anything you didn't already know.

70+--

71+-- 'QueryResult Void = @Void@' seems like it would also work, but that has

72+-- problems of robustness. In some applications, an unasked question can still

73+-- be answered, so it is important that the result is inhabited even when the

74+-- question isn't. Applications that wish to prevent this can mandate that the

75+-- query result be paired with the query: then the whole response will be

76+-- uninhabited as desired.

77+instance Query Void where

78+ type QueryResult Void = ()

79+ crop = absurd

80+

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

82+-- | We can lift queries into monoidal containers.

83+-- But beware of Applicatives whose monoid is different from (pure mempty, liftA2 mappend)

84+instance (Query q, Applicative f) => Query (Ap f q) where

85+ type QueryResult (Ap f q) = Ap f (QueryResult q)

86+ crop = liftA2 crop

87+#endif

88+

5389-- | QueryMorphism's must be group homomorphisms when acting on the query type

5490-- and compatible with the query relationship when acting on the query result.

5591data QueryMorphism q q' = QueryMorphism

@@ -89,7 +125,7 @@ instance Group SelectedCount where

89125

90126instance Additive SelectedCount

91127

92−-- | The Semigroup/Monoid/Group instances for a Query containing 'SelectedCount's should use

128+-- | The Semigroup\/Monoid\/Group instances for a Query containing 'SelectedCount's should use

93129-- this function which returns Nothing if the result is 0. This allows the pruning of leaves

94130-- of the 'Query' that are no longer wanted.

95131combineSelectedCounts :: SelectedCount -> SelectedCount -> Maybe SelectedCount

@@ -97,12 +133,12 @@ combineSelectedCounts (SelectedCount i) (SelectedCount j) = if i == negate j the

97133

98134-- | A class that allows sending of 'Query's and retrieval of 'QueryResult's. See 'queryDyn' for a commonly

99135-- used interface.

100−class (Group q, Additive q, Query q) => MonadQuery t q m | m -> q t where

136+class (Group q, Additive q, Query q, Monad m) => MonadQuery t q m | m -> q t where

101137 tellQueryIncremental :: Incremental t (AdditivePatch q) -> m ()

102138 askQueryResult :: m (Dynamic t (QueryResult q))

103139 queryIncremental :: Incremental t (AdditivePatch q) -> m (Dynamic t (QueryResult q))

104140

105−instance (Monad m, MonadQuery t q m) => MonadQuery t q (ReaderT r m) where

141+instance MonadQuery t q m => MonadQuery t q (ReaderT r m) where

106142 tellQueryIncremental = lift . tellQueryIncremental

107143 askQueryResult = lift askQueryResult

108144 queryIncremental = lift . queryIncremental

@@ -112,7 +148,11 @@ tellQueryDyn :: (Reflex t, MonadQuery t q m) => Dynamic t q -> m ()

112148tellQueryDyn d = tellQueryIncremental $ unsafeBuildIncremental (sample (current d)) $ attachWith (\old new -> AdditivePatch $ new ~~ old) (current d) (updated d)

113149

114150-- | Retrieve 'Dynamic'ally updating 'QueryResult's for a 'Dynamic'ally updating 'Query'.

115−queryDyn :: (Reflex t, Monad m, MonadQuery t q m) => Dynamic t q -> m (Dynamic t (QueryResult q))

151+queryDyn :: (Reflex t, MonadQuery t q m) => Dynamic t q -> m (Dynamic t (QueryResult q))

116152queryDyn q = do

117153 tellQueryDyn q

118154 zipDynWith crop q <$> askQueryResult

155+

156+-- | Use a query morphism to operate on a smaller version of a query.

157+subQuery :: (Reflex t, MonadQuery t q2 m) => QueryMorphism q1 q2 -> Dynamic t q1 -> m (Dynamic t (QueryResult q1))

158+subQuery (QueryMorphism f g) x = fmap g <$> queryDyn (fmap f x)

src/Reflex/Requester/Base.hs+97−27

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

11-- | This module provides 'RequesterT', the standard implementation of

22-- 'Requester'.

33{-# LANGUAGE AllowAmbiguousTypes #-}

4+{-# LANGUAGE ApplicativeDo #-}

45{-# LANGUAGE CPP #-}

56{-# LANGUAGE EmptyDataDecls #-}

67{-# LANGUAGE ExistentialQuantification #-}

@@ -32,6 +33,7 @@ module Reflex.Requester.Base

3233 , requesterDataToList

3334 , singletonRequesterData

3435 , matchResponsesWithRequests

36+ , matchResponseMapWithRequests

3537 , multiEntry

3638 , unMultiEntry

3739 , requesting'

@@ -49,14 +51,17 @@ import Reflex.TriggerEvent.Class

4951import Control.Applicative (liftA2)

5052import Control.Monad.Exception

5153import Control.Monad.Identity

54+import Control.Monad.Morph

5255import Control.Monad.Primitive

5356import Control.Monad.Reader

5457import Control.Monad.Ref

5558import Control.Monad.State.Strict

5659import Data.Bits

5760import Data.Coerce

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

61+import Data.Constraint

62+import Data.Dependent.Map (DMap)

5963import qualified Data.Dependent.Map as DMap

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

6065import Data.Functor.Compose

6166import Data.Functor.Misc

6267import Data.IntMap.Strict (IntMap)

@@ -79,19 +84,51 @@ newtype TagMap (f :: * -> *) = TagMap (IntMap Any)

7984

8085newtype RequesterData f = RequesterData (TagMap (Entry f))

8186

87+emptyRequesterData :: RequesterData f

88+emptyRequesterData = RequesterData $ TagMap IntMap.empty

89+

8290data RequesterDataKey a where

8391 RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a

8492 RequesterDataKey_Multi :: {-# UNPACK #-} !(MyTag Multi) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a --TODO: Don't put a second Int here (or in the other Multis); use a single Int instead

85− RequesterDataKey_Multi2 :: {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a

93+ RequesterDataKey_Multi2 :: GCompare k => {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a

8694 RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a

8795

8896singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f

8997singletonRequesterData rdk v = case rdk of

9098 RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v

9199 RequesterDataKey_Multi k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v

92− RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v

100+ RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Multi2Contents

101+ { _multi2Contents_values = Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v

102+ , _multi2Contents_dict = Dict

103+ }

93104 RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v

94105

106+mergeRequesterData :: RequesterData f -> RequesterData f -> RequesterData f

107+mergeRequesterData (RequesterData a) (RequesterData b) = RequesterData $ mergeTagMap a b

108+

109+mergeTagMap :: forall f. TagMap (Entry f) -> TagMap (Entry f) -> TagMap (Entry f)

110+mergeTagMap (TagMap m) (TagMap n) =

111+ TagMap $ IntMap.unionWithKey (g' combiner) m n

112+ where

113+ combiner :: forall a. MyTag a -> Entry f a -> Entry f a -> Entry f a

114+ combiner k (Entry a) (Entry b) = Entry $ case myKeyType k of

115+ MyTagType_Single -> a

116+ MyTagType_Multi -> IntMap.unionWith mergeRequesterData a b

117+ MyTagType_Multi2 -> case _multi2Contents_dict a of

118+ Dict -> Multi2Contents

119+ { _multi2Contents_values = Map.unionWith (IntMap.unionWith mergeRequesterData) (_multi2Contents_values a) (_multi2Contents_values b)

120+ , _multi2Contents_dict = Dict

121+ }

122+ MyTagType_Multi3 -> IntMap.unionWith (IntMap.unionWith mergeRequesterData) a b

123+ g' :: (forall a. MyTag a -> Entry f a -> Entry f a -> Entry f a) -> Int -> Any -> Any -> Any

124+ g' f rawKey a b =

125+ let k = MyTag rawKey :: MyTag a

126+ fromAny :: Any -> Entry f a

127+ fromAny = unsafeCoerce

128+ toAny :: Entry f a -> Any

129+ toAny = unsafeCoerce

130+ in toAny $ f k (fromAny a) (fromAny b)

131+

95132requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]

96133requesterDataToList (RequesterData m) = do

97134 k :=> Entry e <- tagMapToList m

@@ -101,11 +138,12 @@ requesterDataToList (RequesterData m) = do

101138 (k', e') <- IntMap.toList e

102139 k'' :=> e'' <- requesterDataToList e'

103140 return $ RequesterDataKey_Multi k k' k'' :=> e''

104− MyTagType_Multi2 -> do

105− (k', e') <- Map.toList e

106− (k'', e'') <- IntMap.toList e'

107− k''' :=> e''' <- requesterDataToList e''

108− return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''

141+ MyTagType_Multi2 -> case _multi2Contents_dict e of

142+ Dict -> do

143+ (k', e') <- Map.toList $ _multi2Contents_values e

144+ (k'', e'') <- IntMap.toList e'

145+ k''' :=> e''' <- requesterDataToList e''

146+ return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''

109147 MyTagType_Multi3 -> do

110148 (k', e') <- IntMap.toList e

111149 (k'', e'') <- IntMap.toList e'

@@ -133,7 +171,13 @@ traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWith

133171 go k (Entry request) = Entry <$> case myKeyType k of

134172 MyTagType_Single -> f request

135173 MyTagType_Multi -> traverse (traverseRequesterData f) request

136− MyTagType_Multi2 -> traverse (traverse (traverseRequesterData f)) request

174+ MyTagType_Multi2 -> case request of

175+ Multi2Contents { _multi2Contents_values = request', _multi2Contents_dict = Dict } -> do

176+ v <- traverse (traverse (traverseRequesterData f)) request'

177+ pure $ Multi2Contents

178+ { _multi2Contents_values = v

179+ , _multi2Contents_dict = Dict

180+ }

137181 MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request

138182

139183-- | 'traverseRequesterData' with its arguments flipped

@@ -177,9 +221,14 @@ instance MyTagTypeOffset Multi3 where

177221type family EntryContents request a where

178222 EntryContents request (Single a) = request a

179223 EntryContents request Multi = IntMap (RequesterData request)

180− EntryContents request (Multi2 k) = Map (Some k) (IntMap (RequesterData request))

224+ EntryContents request (Multi2 k) = Multi2Contents k request

181225 EntryContents request Multi3 = IntMap (IntMap (RequesterData request))

182226

227+data Multi2Contents k request = Multi2Contents

228+ { _multi2Contents_dict :: {-# UNPACK #-} !(Dict (GCompare k)) -- This is a Dict instead of an existential context because we only want to use it in certain circumstances

229+ , _multi2Contents_values :: {-# UNPACK #-} !(Map (Some k) (IntMap (RequesterData request)))

230+ }

231+

183232newtype Entry request x = Entry { unEntry :: EntryContents request x }

184233

185234{-# INLINE singleEntry #-}

@@ -308,7 +357,7 @@ tagRequest req = do

308357 return t

309358

310359{-# INLINE responseFromTag #-}

311−responseFromTag :: Monad m => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))

360+responseFromTag :: forall m t request response x. Monad m => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))

312361responseFromTag (MyTagWrap t) = do

313362 responses :: EventSelectorInt t Any <- RequesterT ask

314363 return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t

@@ -316,6 +365,9 @@ responseFromTag (MyTagWrap t) = do

316365instance MonadTrans (RequesterT t request response) where

317366 lift = RequesterT . lift . lift

318367

368+instance MFunctor (RequesterT t request response) where

369+ hoist f = RequesterT . hoist (hoist f) . unRequesterT

370+

319371instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where

320372 type Performable (RequesterT t request response m) = Performable m

321373 performEvent_ = lift . performEvent_

@@ -435,9 +487,9 @@ traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchN

435487 let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))

436488 responses = fanMap $ fmapCheap unpack response

437489 unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))

438− unpack = unEntry

490+ unpack = _multi2Contents_values . unEntry

439491 pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)

440− pack = Entry

492+ pack m = Entry $ Multi2Contents { _multi2Contents_values = m, _multi2Contents_dict = Dict }

441493 f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)

442494 f' k (Compose (n, v)) = do

443495 (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some k))

@@ -458,9 +510,6 @@ traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchN

458510data Decoder rawResponse response =

459511 forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)

460512

461−-- | Matches incoming responses with previously-sent requests

462−-- and uses the provided request "decoder" function to process

463−-- incoming responses.

464513matchResponsesWithRequests

465514 :: forall t rawRequest rawResponse request response m.

466515 ( MonadFix m

@@ -479,7 +528,30 @@ matchResponsesWithRequests

479528 )

480529 -- ^ A map of outgoing wire-format requests and an event of responses keyed

481530 -- by the 'RequesterData' key of the associated outgoing request

482−matchResponsesWithRequests f send recv = do

531+matchResponsesWithRequests f send recv = matchResponseMapWithRequests f send $ uncurry Map.singleton <$> recv

532+

533+-- | Matches incoming responses with previously-sent requests

534+-- and uses the provided request "decoder" function to process

535+-- incoming responses.

536+matchResponseMapWithRequests

537+ :: forall t rawRequest rawResponse request response m.

538+ ( MonadFix m

539+ , MonadHold t m

540+ , Reflex t

541+ )

542+ => (forall a. request a -> (rawRequest, rawResponse -> response a))

543+ -- ^ Given a request (from 'Requester'), produces the wire format of the

544+ -- request and a function used to process the associated response

545+ -> Event t (RequesterData request)

546+ -- ^ The outgoing requests

547+ -> Event t (Map Int rawResponse)

548+ -- ^ A map of incoming responses, tagged by an identifying key

549+ -> m ( Event t (Map Int rawRequest)

550+ , Event t (RequesterData response)

551+ )

552+ -- ^ A map of outgoing wire-format requests and an event of responses keyed

553+ -- by the 'RequesterData' key of the associated outgoing request

554+matchResponseMapWithRequests f send recv = do

483555 rec nextId <- hold 1 $ fmap (\(next, _, _) -> next) outgoing

484556 waitingFor :: Incremental t (PatchMap Int (Decoder rawResponse response)) <-

485557 holdIncremental mempty $ leftmost

@@ -521,17 +593,15 @@ matchResponsesWithRequests f send recv = do

521593 processIncoming

522594 :: Incremental t (PatchMap Int (Decoder rawResponse response))

523595 -- A map of outstanding expected responses

524− -> Event t (Int, rawResponse)

596+ -> Event t (Map Int rawResponse)

525597 -- A incoming response paired with its identifying key

526598 -> Event t (RequesterData response, PatchMap Int v)

527599 -- The decoded response and a patch that clears the outstanding responses queue

528− processIncoming waitingFor inc = flip push inc $ \(n, rawRsp) -> do

600+ processIncoming waitingFor inc = flip push inc $ \rspMap -> do

529601 wf <- sample $ currentIncremental waitingFor

530− case Map.lookup n wf of

531− Nothing -> return Nothing -- TODO How should lookup failures be handled here? They shouldn't ever happen..

532− Just (Decoder k rspF) -> do

533− let rsp = rspF rawRsp

534− return $ Just

535− ( singletonRequesterData k rsp

536− , PatchMap $ Map.singleton n Nothing

537− )

602+ let match rawRsp (Decoder k rspF) =

603+ let rsp = rspF rawRsp

604+ in singletonRequesterData k rsp

605+ matches = Map.intersectionWith match rspMap wf

606+ pure $ if Map.null matches then Nothing else Just

607+ (Map.foldl' mergeRequesterData emptyRequesterData matches, PatchMap $ Nothing <$ matches)

src/Reflex/Spider/Internal.hs+562−313

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

99{-# LANGUAGE GADTs #-}

1010{-# LANGUAGE GeneralizedNewtypeDeriving #-}

1111{-# LANGUAGE LambdaCase #-}

12−{-# LANGUAGE MultiWayIf #-}

1312{-# LANGUAGE RankNTypes #-}

1413{-# LANGUAGE RoleAnnotations #-}

1514{-# LANGUAGE ScopedTypeVariables #-}

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

1716{-# LANGUAGE TypeOperators #-}

1817{-# LANGUAGE UndecidableInstances #-}

1918{-# LANGUAGE PolyKinds #-}

19+{-# LANGUAGE DeriveFunctor #-}

20+{-# LANGUAGE StandaloneDeriving #-}

2021{-# LANGUAGE InstanceSigs #-}

22+{-# LANGUAGE MultiWayIf #-}

2123

2224#ifdef USE_REFLEX_OPTIMIZER

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

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

3638import Control.Monad.Exception

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

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

4044import Control.Monad.Ref

45+import Control.Monad.Fail (MonadFail)

46+import qualified Control.Monad.Fail as MonadFail

4147import Data.Align

4248import Data.Coerce

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

49+import Data.Dependent.Map (DMap)

4450import qualified Data.Dependent.Map as DMap

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

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

4653import qualified Data.FastMutableIntMap as FastMutableIntMap

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

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

5461import Data.IORef

5562import Data.Kind (Type)

5663import Data.Maybe hiding (mapMaybe)

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

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

5865import Data.Proxy

5966import Data.These

6067import Data.Traversable

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

6169import Data.Witherable (Filterable, mapMaybe)

62−import GHC.Exts

70+import GHC.Exts hiding (toList)

6371import GHC.IORef (IORef (..))

6472import GHC.Stack

6573import Reflex.FastWeak

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

6775import System.Mem.Weak

6876import Unsafe.Coerce

6977

70−#if defined(MIN_VERSION_semialign)

78+#ifdef MIN_VERSION_semialign

7179#if MIN_VERSION_these(0,8,0)

7280import Data.These.Combinators (justThese)

7381#endif

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

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

84+#endif

7485#endif

7586

7687#ifdef DEBUG_CYCLES

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

89+#endif

90+

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

7992import qualified Data.List.NonEmpty as NonEmpty

80−import Data.Monoid (mempty)

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

82−#endif

94+import Data.List (isPrefixOf)

8395

84−import Data.FastWeakBag (FastWeakBag)

96+import Data.FastWeakBag (FastWeakBag, FastWeakBagTicket)

8597import qualified Data.FastWeakBag as FastWeakBag

98+

8699import Data.Reflection

87100import Data.Some (Some(Some))

88101import Data.Type.Coercion

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

93106import qualified Reflex.Class as R

94107import qualified Reflex.Host.Class

95108import Reflex.NotReady.Class

96−import Reflex.Patch

97−import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove

109+import Data.Patch

110+import qualified Data.Patch.DMapWithMove as PatchDMapWithMove

111+import Reflex.PerformEvent.Base (PerformEventT)

98112

99113#ifdef DEBUG_TRACE_EVENTS

100114import qualified Data.ByteString.Char8 as BS8

101115import System.IO (stderr)

116+import Data.List (isPrefixOf)

102117#endif

103118

104−#ifdef DEBUG_TRACE_EVENTS

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

120+debugStrLn :: String -> IO ()

121+debugStrLn = putStrLn

105122

123+#ifdef DEBUG_TRACE_EVENTS

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

107125withStackOneLine expr = unsafePerformIO $ do

108126 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"

110129

111130#endif

112131

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

117136debugInvalidate :: Bool

118137

119138#ifdef DEBUG

120−

121139#define DEBUG_NODEIDS

122140

141+#ifdef DEBUG_TRACE_PROPAGATION

123142debugPropagate = True

143+#else

144+debugPropagate = False

145+#endif

124146

147+#ifdef DEBUG_TRACE_HEIGHT

148+debugInvalidateHeight = True

149+#else

125150debugInvalidateHeight = False

151+#endif

126152

153+#ifdef DEBUG_TRACE_INVALIDATION

127154debugInvalidate = True

155+#else

156+debugInvalidate = False

157+#endif

128158

129159class HasNodeId a where

130160 getNodeId :: a -> Int

131161

132−instance HasNodeId (Hold x p a) where

133− getNodeId = holdNodeId

162+instance HasNodeId (CacheSubscribed x a) where

163+ getNodeId = _cacheSubscribed_nodeId

164+

165+instance HasNodeId (FanInt x a) where

166+ getNodeId = _fanInt_nodeId

134167

135−instance HasNodeId (PushSubscribed x a b) where

136− getNodeId = pushSubscribedNodeId

168+instance HasNodeId (Hold x p) where

169+ getNodeId = holdNodeId

137170

138171instance HasNodeId (SwitchSubscribed x a) where

139172 getNodeId = switchSubscribedNodeId

140173

141−instance HasNodeId (FanSubscribed x a) where

174+instance HasNodeId (FanSubscribed x v a) where

142175 getNodeId = fanSubscribedNodeId

143176

144177instance HasNodeId (CoincidenceSubscribed x a) where

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

152185

153186{-# INLINE showNodeId #-}

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

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

156−

157−showSubscriberType :: Subscriber x a -> String

158−showSubscriberType = \case

159− SubscriberPush _ _ -> "SubscriberPush"

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"

188+showNodeId = showNodeId' . getNodeId

189+

190+showNodeId' :: Int -> String

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

192+

183193

184194#else

185195

186196debugPropagate = False

187−

188197debugInvalidateHeight = False

189−

190198debugInvalidate = False

191199

192200-- This must be inline, or error messages will cause memory leaks due to retaining the node in question

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

194202showNodeId :: a -> String

195203showNodeId _ = ""

196204

205+{-# INLINE showNodeId' #-}

206+showNodeId' :: Int -> String

207+showNodeId' _ = ""

208+

197209#endif

198210

199211#ifdef DEBUG_NODEIDS

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

239251-- caching; if the computation function is very cheap, this is (much) more

240252-- efficient than 'push'

241253{-# 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

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

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

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

245257 { subscriberPropagate = \a -> do

246258 mb <- f a

247259 mapM_ (subscriberPropagate sub) mb

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

260272

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

262274{-# 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)

264276subscribeAndReadHead e sub = do

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

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

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

267279 { subscriberPropagate = \a -> do

268280 liftIO $ unsubscribe =<< readIORef subscriptionRef

269281 subscriberPropagate sub a

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

274286 return (subscription, occ)

275287

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

278290headE originalE = do

279291 parent <- liftIO $ newIORef $ Just originalE

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

281293 let clearParent = liftIO $ writeIORef parent Nothing

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

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

283295 when (isJust occ) clearParent

284− return $ Event $ \sub -> do

296+ return $ Event $ \sub ->

285297 liftIO (readIORef parent) >>= \case

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

298+ Nothing -> subscribeAndReadNever

287299 Just e -> subscribeAndReadHead e sub

288300

289301data CacheSubscribed x a

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

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

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

305+#ifdef DEBUG_NODEIDS

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

307+#endif

293308 }

294309

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+

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

296326-- repeatedly

297327--

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

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

317347 Just subscribedTicket -> return subscribedTicket

318348 Nothing -> do

349+#ifdef DEBUG_NODEIDS

350+ nodeId <- liftIO newNodeId

351+#endif

319352 subscribers <- liftIO FastWeakBag.empty

320353 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

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

322− { subscriberPropagate = \a -> do

323− liftIO $ writeIORef occRef $ Just a

324− scheduleClear occRef

325− propagateFast a subscribers

326− , subscriberInvalidateHeight = \old -> do

327− FastWeakBag.traverse subscribers $ invalidateSubscriberHeight old

328− , subscriberRecalculateHeight = \new -> do

329− FastWeakBag.traverse subscribers $ recalculateSubscriberHeight new

330− }

358+#endif

359+ { subscriberPropagate = \a -> do

360+ liftIO $ writeIORef occRef (Just a)

361+ scheduleClear occRef

362+ propagateFast a subscribers

363+ , subscriberInvalidateHeight = FastWeakBag.traverse_ subscribers . invalidateSubscriberHeight

364+ , subscriberRecalculateHeight = FastWeakBag.traverse_ subscribers . recalculateSubscriberHeight

365+ }

331366 when (isJust occ) $ do

332367 liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing

333368 scheduleClear occRef

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

335370 { _cacheSubscribed_subscribers = subscribers

336371 , _cacheSubscribed_parent = parentSub

337372 , _cacheSubscribed_occurrence = occRef

373+#ifdef DEBUG_NODEIDS

374+ , _cacheSubscribed_nodeId = nodeId

375+#endif

338376 }

339377 subscribedTicket <- liftIO $ mkFastWeakTicket subscribed

340378 liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket

341379 return subscribedTicket

342− liftIO $ do

343− subscribed <- getFastWeakTicketValue subscribedTicket

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

345− occ <- readIORef $ _cacheSubscribed_occurrence subscribed

346− let es = EventSubscription

347− { _eventSubscription_unsubscribe = do

348− FastWeakBag.remove ticket

349− isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed

350− when isEmpty $ do

351− writeIORef mSubscribedRef emptyFastWeak

352− unsubscribe $ _cacheSubscribed_parent subscribed

353− touch ticket

354− touch subscribedTicket

355− , _eventSubscription_subscribed = EventSubscribed

356− { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed

357− , eventSubscribedRetained = toAny subscribedTicket

358− }

359− }

360− return (es, occ)

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

385+ subscribed <- getFastWeakTicketValue subscribedTicket

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

387+ occ <- readIORef $ _cacheSubscribed_occurrence subscribed

388+

389+ let parentSub = _cacheSubscribed_parent subscribed

390+ es = EventSubscription

391+ { _eventSubscription_unsubscribe = do

392+ FastWeakBag.remove ticket

393+

394+ isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed

395+ when isEmpty $ do

396+ writeIORef mSubscribedRef emptyFastWeak

397+ unsubscribe parentSub

398+ touch ticket

399+ touch subscribedTicket

400+ , _eventSubscription_subscribed = EventSubscribed

401+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed parentSub

402+ , eventSubscribedRetained = toAny subscribedTicket

403+#ifdef DEBUG_CYCLES

404+ , eventSubscribedGetParents = return [_eventSubscription_subscribed parentSub]

405+ , eventSubscribedHasOwnHeightRef = False

406+ , eventSubscribedWhoCreated = whoCreatedIORef mSubscribedRef

407+#endif

408+ }

409+ }

410+ return (es, occ)

411+

361412

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

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

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

369420 let es = tag subd

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

371422

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

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

374425

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

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

428+

375429eventNever :: Event x a

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

430+eventNever = Event $ const subscribeAndReadNever

377431

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

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

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

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

411465 }

412466

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−

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

424468newSubscriberHold h = return $ Subscriber

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

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

428472 }

429473

430474newSubscriberFan :: 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

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

433477 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"

435479 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a

436480 scheduleClear $ fanSubscribedOccurrence subscribed

437481 let f _ (Pair v subsubs) = do

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

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

441485 return ()

442486 , subscriberInvalidateHeight = \old -> do

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

444487 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

445− forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old

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

488+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old

447489 , subscriberRecalculateHeight = \new -> do

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

449490 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

450− forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new

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

491+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new

452492 }

453493

454494newSubscriberSwitch :: 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

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

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

458497 liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a

459498 scheduleClear $ switchSubscribedOccurrence subscribed

460499 propagate a $ switchSubscribedSubscribers subscribed

461500 , subscriberInvalidateHeight = \_ -> do

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

463501 oldHeight <- readIORef $ switchSubscribedHeight subscribed

464502 when (oldHeight /= invalidHeight) $ do

465503 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight

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

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

468− , subscriberRecalculateHeight = \new -> do

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

470− updateSwitchHeight new subscribed

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

472− }

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

505+ , subscriberRecalculateHeight = (`updateSwitchHeight` subscribed)

506+ }

473507

474508newSubscriberCoincidenceOuter :: 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

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

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

478511 outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed

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

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

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

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

516+

483517 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd

484518 scheduleClear $ coincidenceSubscribedInnerParent subscribed

485519 case occ of

486− Nothing -> do

520+ Nothing ->

487521 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height

488522 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight

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

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

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

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

491525 Just o -> do -- Since it's already firing, no need to adjust height

492526 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ

493527 scheduleClear $ coincidenceSubscribedOccurrence subscribed

494528 propagate o $ coincidenceSubscribedSubscribers subscribed

495− , subscriberInvalidateHeight = \_ -> do

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

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

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

529+ , subscriberInvalidateHeight = \_ -> invalidateCoincidenceHeight subscribed

530+ , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed

503531 }

504532

505533newSubscriberCoincidenceInner :: 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

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

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

509536 occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed

510537 case occ of

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

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

513540 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a

514541 scheduleClear $ coincidenceSubscribedOccurrence subscribed

515542 propagate a $ coincidenceSubscribedSubscribers subscribed

516− , subscriberInvalidateHeight = \_ -> do

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

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

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

543+ , subscriberInvalidateHeight = \_ -> invalidateCoincidenceHeight subscribed

544+ , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed

524545 }

525546

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

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

530551recalculateSubscriberHeight = flip subscriberRecalculateHeight

531552

532553-- | Propagate everything at the current height

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

534−propagate a subscribers = withIncreasedDepth $ do

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

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

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

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

538559

539560-- | Propagate everything at the current height

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

541−propagateFast a subscribers = withIncreasedDepth $ do

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

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

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

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

545566

546567--------------------------------------------------------------------------------

547568-- EventSubscribed

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

550571toAny :: a -> Any

551572toAny = unsafeCoerce

552573

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.

553579data EventSubscribed x = EventSubscribed

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

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

556582#ifdef DEBUG_CYCLES

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

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

558584 , eventSubscribedHasOwnHeightRef :: !Bool

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

560586#endif

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

581607 , eventSubscribedWhoCreated = return ["never"]

582608#endif

583609 }

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

584620

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

586622eventSubscribedFan !subscribed = EventSubscribed

587623 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed

588624 , eventSubscribedRetained = toAny subscribed

589625#ifdef DEBUG_CYCLES

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

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

591627 , eventSubscribedHasOwnHeightRef = False

592628 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed

593629#endif

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

600636#ifdef DEBUG_CYCLES

601637 , eventSubscribedGetParents = do

602638 s <- readIORef $ switchSubscribedCurrentParent subscribed

603− return [Some $ _eventSubscription_subscribed s]

639+ return [_eventSubscription_subscribed s]

604640 , eventSubscribedHasOwnHeightRef = True

605641 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed

606642#endif

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

613649#ifdef DEBUG_CYCLES

614650 , eventSubscribedGetParents = do

615651 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed

616− let outerParent = Some $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed

617− innerParents = maybeToList $ fmap Some innerSubscription

652+ let outerParent = _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed

653+ innerParents = maybeToList $ innerSubscription

618654 return $ outerParent : innerParents

619655 , eventSubscribedHasOwnHeightRef = True

620656 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed

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

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

629665whoCreatedEventSubscribed = eventSubscribedWhoCreated

630666

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

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

632668walkInvalidHeightParents s0 = do

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

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

634670 h <- liftIO $ readIORef $ eventSubscribedHeightRef s

635671 when (h == invalidHeight) $ do

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

637− modify (Some s :)

673+ modify (s :)

638674 mapM_ loop =<< liftIO (eventSubscribedGetParents s)

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

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

640676 return subscribers

641677#endif

642678

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

673709 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"

674710 parentsRef <- liftIO $ newIORef []

675711 holdInits <- askBehaviorHoldInits

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

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

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

678714 parents <- liftIO $ readIORef parentsRef

679715 let subscribed = PullSubscribed

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

708744-- Dynamic

709745--------------------------------------------------------------------------------

710746

711−data Dynamic x p = Dynamic

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

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

748+

749+data Dynamic x target p = Dynamic

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

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

714752 }

715753

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

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

755+

756+

757+

758+

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

717760dynamicHold !h = Dynamic

718761 { dynamicCurrent = behaviorHold h

719762 , dynamicUpdated = eventHold h

720763 }

721764

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

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

723766dynamicHoldIdentity = dynamicHold

724767

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

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

726769dynamicConst !a = Dynamic

727770 { dynamicCurrent = behaviorConst a

728771 , dynamicUpdated = eventNever

729772 }

730773

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

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

732775dynamicDyn !d = Dynamic

733776 { dynamicCurrent = behaviorDyn d

734777 , dynamicUpdated = eventDyn d

735778 }

736779

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

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

738781dynamicDynIdentity = dynamicDyn

739782

740783--------------------------------------------------------------------------------

741784-- Combinators

742785--------------------------------------------------------------------------------

743786

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

745−--representational so we can use coerce

746−

747787--type role Hold representational

748788data Hold x p

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

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

764804

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

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

767−data SpiderTimelineEnv x = SpiderTimelineEnv

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+

812+data SpiderTimelineEnv' x = SpiderTimelineEnv

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

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

770815#ifdef DEBUG

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

772817#endif

773818 }

774−type role SpiderTimelineEnv nominal

819+type role SpiderTimelineEnv' phantom

775820

776821instance Eq (SpiderTimelineEnv x) where

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

778823

779824instance 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)

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

782827 else Nothing

783828

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

800845runEventM = unEventM

801846

802847asksEventEnv :: 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))

804849

805850class MonadIO m => Defer a m where

806851 getDeferralQueue :: m (IORef [a])

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

938983

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

940985

941−--type role BehaviorM representational

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

944989

945990instance Monad (BehaviorM x) where

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

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

949994 BehaviorM x >> BehaviorM y = BehaviorM $ x >> y

950995 {-# INLINE return #-}

951996 return x = BehaviorM $ return x

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

952998 {-# INLINE fail #-}

953999 fail s = BehaviorM $ fail s

1000+#endif

9541001

9551002data BehaviorSubscribed x a

9561003 = forall p. BehaviorSubscribedHold (Hold x p)

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

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

10111058

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

10141061

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

10161063

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

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

10361083

10371084heightBagAdd :: 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

10391087

10401088heightBagRemove :: Height -> HeightBag -> HeightBag

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

10441092 0 -> IntMap.delete h c

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

10461094

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+

10471102heightBagMax :: HeightBag -> Height

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

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

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

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

11451200 DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]

11461201

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

11481206 zip x y = mapMaybe justThese $ align x y

11491207#endif

11501208

@@ -1154,11 +1212,11 @@ data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)

11541212

11551213newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }

11561214

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)

11581216newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)

11591217

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

11621220zipDynWith f da db =

11631221 let eab = align (dynamicUpdated da) (dynamicUpdated db)

11641222 ec = flip push eab $ \o -> do

@@ -1234,7 +1292,7 @@ run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> Res

12341292run roots after = do

12351293 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"

12361294 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

12381296 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do

12391297 occBefore <- liftIO $ do

12401298 occBefore <- readIORef occRef

@@ -1288,55 +1346,110 @@ mkWeakPtrWithDebug x debugNote = do

12881346 x' <- evaluate x

12891347 mkWeakPtr x' $

12901348 if debugFinalize

1291− then Just $ putStrLn $ "finalizing: " ++ debugNote

1349+ then Just $ debugStrLn $ "finalizing: " ++ debugNote

12921350 else Nothing

12931351

12941352type WeakList a = [Weak a]

12951353

1296−{-# INLINE withIncreasedDepth #-}

1354+type CanTrace x m = (HasSpiderTimeline x, MonadIO m)

1355+

1356+

1357+

1358+

12971359#ifdef DEBUG

1298−withIncreasedDepth :: CanTrace x m => m a -> m a

1299−withIncreasedDepth a = do

1300− spiderTimeline <- askSpiderTimelineEnv

1301− liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ

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+

1381+{-# INLINE withIncreasedDepth #-}

1382+withIncreasedDepth :: forall proxy x m a. CanTrace x m => proxy x -> m a -> m a

1383+withIncreasedDepth _ a = do

1384+ liftIO $ modifyIORef' (_spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)) succ

13021385 result <- a

1303− liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred

1386+ liftIO $ modifyIORef' (_spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)) pred

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

13111388

13121389{-# INLINE tracePropagate #-}

13131390tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()

1314−tracePropagate p = traceWhen p debugPropagate

1391+tracePropagate p = when debugPropagate . trace p

13151392

13161393{-# INLINE traceInvalidate #-}

13171394traceInvalidate :: 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

13191400

1320−{-# INLINE traceWhen #-}

1321−traceWhen :: (CanTrace x m) => proxy x -> Bool -> String -> m ()

1322−traceWhen p b message = traceMWhen p b $ return message

1401+{-# INLINE trace #-}

1402+trace :: (CanTrace x m) => proxy x -> String -> m ()

1403+trace p message = traceM p $ return message

13231404

1324−{-# INLINE traceMWhen #-}

1325−traceMWhen :: (CanTrace x m) => proxy x -> Bool -> m String -> m ()

1326−traceMWhen _ b getMessage = when b $ do

1405+{-# INLINE traceM #-}

1406+traceM :: forall x proxy m. (CanTrace x m) => proxy x -> m String -> m ()

1407+traceM _ getMessage = do

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

13311412#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+

13331448#endif

1334− liftIO $ putStrLn $ replicate d ' ' <> message

13351449

13361450whoCreatedIORef :: IORef a -> IO [String]

13371451whoCreatedIORef (IORef a) = whoCreated $! a

13381452

1339−#ifdef DEBUG_CYCLES

13401453groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]

13411454groupByHead = \case

13421455 [] -> []

@@ -1347,20 +1460,54 @@ groupByHead = \case

13471460 | otherwise -> (x, xs :| []) : l

13481461

13491462listsToForest :: 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

13511474#endif

13521475

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+

13531498{-# INLINE propagateSubscriberHold #-}

13541499propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()

13551500propagateSubscriberHold h a = do

1356− {-# SCC "trace" #-} traceMWhen (Proxy :: Proxy x) debugPropagate $ liftIO $ do

1501+ {-# SCC "trace" #-} when debugPropagate $ traceM (Proxy :: Proxy x) $ liftIO $ do

13571502 invalidators <- liftIO $ readIORef $ holdInvalidators h

13581503 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)

1504+

13591505 v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h

13601506 case {-# SCC "apply" #-} apply a v of

13611507 Nothing -> return ()

13621508 Just v' -> do

1363− {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate (Proxy :: Proxy x) $ "propagateSubscriberHold: assigning Hold" <> showNodeId h

1509+ {-# SCC "trace2" #-} withIncreasedDepth (Proxy :: Proxy x) $

1510+ tracePropagate (Proxy :: Proxy x) ("propagateSubscriberHold: assigning Hold" <> showNodeId h)

13641511 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h

13651512 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h

13661513 defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'

@@ -1368,25 +1515,25 @@ propagateSubscriberHold h a = do

13681515data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset

13691516

13701517runBehaviorM :: 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)

13721519

13731520askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))

13741521askInvalidator = do

1375− (!m, _) <- BehaviorM ask

1522+ (!m, _) <- ask

13761523 case m of

13771524 Nothing -> return Nothing

13781525 Just (!wi, _) -> return $ Just wi

13791526

13801527askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))

13811528askParentsRef = do

1382− (!m, _) <- BehaviorM ask

1529+ (!m, _) <- ask

13831530 case m of

13841531 Nothing -> return Nothing

13851532 Just (_, !p) -> return $ Just p

13861533

13871534askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])

13881535askBehaviorHoldInits = do

1389− (_, !his) <- BehaviorM ask

1536+ (_, !his) <- ask

13901537 return his

13911538

13921539{-# INLINE getDynHold #-}

@@ -1414,7 +1561,7 @@ getDynHold d = do

14141561zeroRef :: IORef Height

14151562zeroRef = unsafePerformIO $ newIORef zeroHeight

14161563

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)

14181565getRootSubscribed k r sub = do

14191566 mSubscribed <- readIORef $ rootSubscribed r

14201567 let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r

@@ -1428,7 +1575,9 @@ getRootSubscribed k r sub = do

14281575 let !cached = rootSubscribed r

14291576 uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"

14301577 (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed

1431− when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"

1578+

1579+ tracePropagate (Proxy::Proxy x) $ "getRootSubscribed: calling rootInit"

1580+

14321581 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)

14331582 writeIORef uninitRef $! uninit

14341583#ifdef DEBUG_NODEIDS

@@ -1478,6 +1627,9 @@ data FanInt x a = FanInt

14781627 { _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

14791628 , _fanInt_subscriptionRef :: {-# UNPACK #-} !(IORef (EventSubscription x)) -- This should have a valid subscription iff subscribers is non-empty

14801629 , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a))

1630+#ifdef DEBUG_NODEIDS

1631+ , _fanInt_nodeId :: {-# UNPACK #-} !Int

1632+#endif

14811633 }

14821634

14831635newFanInt :: IO (FanInt x a)

@@ -1485,10 +1637,16 @@ newFanInt = do

14851637 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

14861638 subscriptionRef <- newIORef $ error "fanInt: no subscription"

14871639 occRef <- newIORef $ error "fanInt: no occurrence"

1640+#ifdef DEBUG_NODEIDS

1641+ nodeId <- newNodeId

1642+#endif

14881643 return $ FanInt

14891644 { _fanInt_subscribers = subscribers

14901645 , _fanInt_subscriptionRef = subscriptionRef

14911646 , _fanInt_occRef = occRef

1647+#ifdef DEBUG_NODEIDS

1648+ , _fanInt_nodeId = nodeId

1649+#endif

14921650 }

14931651

14941652fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a

@@ -1497,20 +1655,21 @@ fanInt p = unsafePerformIO $ do

14971655 pure $ EventSelectorInt $ \k -> Event $ \sub -> do

14981656 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)

14991657 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input

1500− (subscription, parentOcc) <- subscribeAndRead p $ Subscriber

1658+ let desc = "fanInt" <> showNodeId self <> ", k = " <> show k

1659+ (subscription, parentOcc) <- subscribeAndRead p $ debugSubscriber' desc $ Subscriber

15011660 { subscriberPropagate = \m -> do

15021661 liftIO $ writeIORef (_fanInt_occRef self) m

15031662 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?

1505− FastWeakBag.traverse b $ \s -> do

1663+ FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> --TODO: Do we need to know that no subscribers are being added as we traverse?

1664+ FastWeakBag.traverse_ b $ \s ->

15061665 subscriberPropagate s v

1507− , subscriberInvalidateHeight = \old -> do

1508− FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do

1509− FastWeakBag.traverse b $ \s -> do

1666+ , subscriberInvalidateHeight = \old ->

1667+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->

1668+ FastWeakBag.traverse_ b $ \s ->

15101669 subscriberInvalidateHeight s old

1511− , subscriberRecalculateHeight = \new -> do

1512− FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do

1513− FastWeakBag.traverse b $ \s -> do

1670+ , subscriberRecalculateHeight = \new ->

1671+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->

1672+ FastWeakBag.traverse_ b $ \s ->

15141673 subscriberRecalculateHeight s new

15151674 }

15161675 liftIO $ do

@@ -1524,10 +1683,25 @@ fanInt p = unsafePerformIO $ do

15241683 FastMutableIntMap.insert (_fanInt_subscribers self) k b

15251684 return b

15261685 Just b -> return b

1527− t <- liftIO $ FastWeakBag.insert sub b

1686+ ticket <- liftIO $ FastWeakBag.insert sub b

15281687 currentOcc <- readIORef (_fanInt_occRef self)

1529− (EventSubscription _ (EventSubscribed !heightRef _)) <- readIORef (_fanInt_subscriptionRef self)

1530− return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)

1688+

1689+ subscribed <- fanIntSubscribed ticket self

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+

15311705

15321706{-# INLINABLE getFanSubscribed #-}

15331707getFanSubscribed :: (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

17101884{-# INLINE mergeG #-}

17111885mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k)

17121886 => (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)

17141888mergeG nt d = cacheEvent (mergeCheap nt d)

17151889

17161890{-# INLINE mergeWithMove #-}

17171891mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k)

17181892 => (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)

17201894mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)

17211895

17221896{-# INLINE [1] mergeCheap #-}

17231897mergeCheap

17241898 :: forall k x q v. (HasSpiderTimeline x, GCompare k)

17251899 => (forall a. q a -> Event x (v a))

1726− -> Dynamic x (PatchDMap k q)

1900+ -> DynamicS x (PatchDMap k q)

17271901 -> Event x (DMap k v)

1728−mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy

1902+mergeCheap nt = mergeGCheap' unMergeSubscribedParent getInitialSubscribers updateMe destroy

17291903 where

17301904 updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)

17311905 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do

@@ -1740,7 +1914,9 @@ mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy

17401914 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight

17411915 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps

17421916 forM_ mOldSubd $ \oldSubd -> do

1743− oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd

1917+ oldHeight <- liftIO $ getEventSubscribedHeight $

1918+ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd

1919+

17441920 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

17451921 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)

17461922 foldM f ([], oldParents) $ DMap.toList p

@@ -1763,9 +1939,9 @@ mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy

17631939{-# INLINE [1] mergeCheapWithMove #-}

17641940mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)

17651941 => (forall a. q a -> Event x (v a))

1766− -> Dynamic x (PatchDMapWithMove k q)

1942+ -> DynamicS x (PatchDMapWithMove k q)

17671943 -> Event x (DMap k v)

1768−mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy

1944+mergeCheapWithMove nt = mergeGCheap' _mergeSubscribedParentWithMove_subscription getInitialSubscribers updateMe destroy

17691945 where

17701946 updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)

17711947 updateMe subscriber heightBagRef oldParents p = do

@@ -1784,13 +1960,17 @@ mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy

17841960 let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a

17851961 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of

17861962 Nothing -> do

1787− oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent

1963+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $

1964+ _mergeSubscribedParentWithMove_subscription parent

1965+

17881966 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

17891967 return $ Just $ _mergeSubscribedParentWithMove_subscription parent

17901968 Just toKey -> do

17911969 liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey

17921970 return Nothing

1793− toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents

1971+ toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $

1972+ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents

1973+

17941974 return (toDelete, applyAlways p' oldParents)

17951975 getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)

17961976 getInitialSubscribers initialParents subscriber = do

@@ -1815,6 +1995,8 @@ type MergeUpdateFunc k v x p s

18151995 -> p

18161996 -> EventM x ([EventSubscription x], DMap k s)

18171997

1998+type MergeGetSubscription x s = forall a. s a -> EventSubscription x

1999+

18182000type MergeInitFunc k v q x s

18192001 = DMap k q

18202002 -> (forall a. EventM x (k a) -> Subscriber x (v a))

@@ -1838,14 +2020,17 @@ invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_su

18382020invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()

18392021invalidateMergeHeight' heightRef sub = do

18402022 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

18422025 writeIORef heightRef $! invalidHeight

18432026 subscriberInvalidateHeight sub oldHeight

18442027

18452028revalidateMergeHeight :: Merge x k v s -> IO ()

18462029revalidateMergeHeight m = do

18472030 currentHeight <- readIORef $ _merge_heightRef m

1848− when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check

2031+

2032+ -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check

2033+ when (currentHeight == invalidHeight) $ do

18492034 heights <- readIORef $ _merge_heightBagRef m

18502035 parents <- readIORef $ _merge_parentsRef m

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

18532038 LT -> return ()

18542039 EQ -> do

18552040 let height = succHeight $ heightBagMax heights

1856− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height

2041+ traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height

18572042 writeIORef (_merge_heightRef m) $! height

18582043 subscriberRecalculateHeight (_merge_sub m) height

18592044 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"

@@ -1861,36 +2046,45 @@ revalidateMergeHeight m = do

18612046scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()

18622047scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do

18632048 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

18652052 --TODO: Assert that m is not empty

18662053 subscriberPropagate (_merge_sub m) vals

18672054

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)

1869−mergeSubscriber m getKey = Subscriber

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+

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)

2077+mergeSubscriber subscribed m getKey = Subscriber

18702078 { subscriberPropagate = \a -> do

18712079 oldM <- liftIO $ readIORef $ _merge_accumRef m

18722080 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

18742082 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)

18752083 liftIO $ writeIORef (_merge_accumRef m) $! newM

18762084 when (DMap.null oldM) $ do -- Only schedule the firing once

18772085 height <- liftIO $ readIORef $ _merge_heightRef m

1878− --TODO: assertions about height

1879− currentHeight <- getCurrentHeight

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

2086+ checkCycle subscribed

2087+

18942088 scheduleMergeSelf m height

18952089 , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating

18962090 modifyIORef' (_merge_heightBagRef m) $ heightBagRemove old

@@ -1901,31 +2095,45 @@ mergeSubscriber m getKey = Subscriber

19012095 }

19022096

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

1905−updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)

2098+updateMerge :: (HasSpiderTimeline x, GCompare k) => EventSubscribed x -> Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x

2099+updateMerge subscribed m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)

19062100 where updateMe = do

19072101 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

19092103 liftIO $ writeIORef (_merge_parentsRef m) $! newParents

19102104 return subscriptionsToKill

19112105

19122106{-# INLINE mergeGCheap' #-}

19132107mergeGCheap' :: 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)

1915−mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do

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)

2109+mergeGCheap' getParent getInitialSubscribers updateFunc destroy d = Event $ \sub -> do

19162110 initialParents <- readBehaviorUntracked $ dynamicCurrent d

19172111 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"

19182112 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"

19192113 heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"

19202114 parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"

1921− let m = Merge

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+

2129+ m = Merge

19222130 { _merge_parentsRef = parentsRef

19232131 , _merge_heightBagRef = heightBagRef

19242132 , _merge_heightRef = heightRef

19252133 , _merge_sub = sub

19262134 , _merge_accumRef = accumRef

19272135 }

1928− (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber m

2136+ (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber subscribed m

19292137 let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights

19302138 myHeight = if invalidHeight `elem` heights

19312139 then invalidHeight

@@ -1934,50 +2142,57 @@ mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do

19342142 let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now

19352143 then (if DMap.null dm then Nothing else Just dm, DMap.empty)

19362144 else (Nothing, dm)

1937− unless (DMap.null accum) $ do

1938− scheduleMergeSelf m myHeight

2145+ unless (DMap.null accum) $ scheduleMergeSelf m myHeight

19392146 liftIO $ writeIORef accumRef $! accum

19402147 liftIO $ writeIORef heightRef $! myHeight

19412148 liftIO $ writeIORef heightBagRef $! myHeightBag

1942− changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"

19432149 liftIO $ writeIORef parentsRef $! initialParentState

19442150 defer $ SomeMergeInit $ do

1945− let s = Subscriber

2151+ let changeSubscriber = Subscriber

19462152 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

1947− tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change"

1948− defer $ updateMerge m updateFunc a

2153+ tracePropagate (Proxy :: Proxy x) "SubscriberMerge/Change"

2154+ defer $ updateMerge subscribed m updateFunc a

19492155 , subscriberInvalidateHeight = \_ -> return ()

19502156 , subscriberRecalculateHeight = \_ -> return ()

19512157 }

1952− (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s

1953− forM_ change $ \c -> defer $ updateMerge m updateFunc c

2158+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) changeSubscriber

2159+ forM_ change $ \c -> defer $ updateMerge subscribed m updateFunc c

19542160 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.

19552161 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain

19562162 -- its subscription.

1957− liftIO $ writeIORef changeSubdRef (s, changeSubscription)

2163+ liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)

19582164 let unsubscribeAll = destroy =<< readIORef parentsRef

1959− return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parentsRef, changeSubdRef)

1960− , occ

1961− )

19622165

1963−mergeInt :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)

2166+ return (EventSubscription unsubscribeAll subscribed, occ)

2167+

2168+

2169+mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)

19642170mergeInt = cacheEvent . mergeIntCheap

19652171

19662172{-# 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)

19682174mergeIntCheap d = Event $ \sub -> do

19692175 initialParents <- readBehaviorUntracked $ dynamicCurrent d

19702176 accum <- liftIO $ FastMutableIntMap.newEmpty

19712177 heightRef <- liftIO $ newIORef zeroHeight

19722178 heightBagRef <- liftIO $ newIORef heightBagEmpty

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

19742190 let scheduleSelf = do

19752191 height <- liftIO $ readIORef $ heightRef

19762192 scheduleMerge' height heightRef $ do

19772193 vals <- liftIO $ FastMutableIntMap.getFrozenAndClear accum

19782194 subscriberPropagate sub vals

1979− invalidateMyHeight = do

1980− invalidateMergeHeight' heightRef sub

2195+ invalidateMyHeight = invalidateMergeHeight' heightRef sub

19812196 recalculateMyHeight = do

19822197 currentHeight <- readIORef heightRef

19832198 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

19872202 LT -> return ()

19882203 EQ -> do

19892204 let height = succHeight $ heightBagMax heights

1990− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height

2205+ traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height

19912206 writeIORef heightRef $! height

19922207 subscriberRecalculateHeight sub height

19932208 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"

19942209 mySubscriber k = Subscriber

19952210 { subscriberPropagate = \a -> do

2211+ checkCycle subscribed

2212+

19962213 wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum

19972214 liftIO $ FastMutableIntMap.insert accum k a

19982215 when wasEmpty scheduleSelf

@@ -2026,7 +2243,6 @@ mergeIntCheap d = Event $ \sub -> do

20262243 else liftIO $ Just <$> FastMutableIntMap.getFrozenAndClear accum

20272244 else do when (not isEmpty) scheduleSelf -- We have things accumulated, but we shouldn't have fired them yet

20282245 return Nothing

2029− changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"

20302246 defer $ SomeMergeInit $ do

20312247 let updateMe a = SomeMergeUpdate u invalidateMyHeight recalculateMyHeight

20322248 where

@@ -2040,25 +2256,27 @@ mergeIntCheap d = Event $ \sub -> do

20402256 oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions

20412257 liftIO $ for_ oldParents $ \oldParent -> do

20422258 oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent

2259+

2260+ print ("updateMe", oldParentHeight)

20432261 modifyIORef' heightBagRef $ heightBagRemove oldParentHeight

20442262 return $ IntMap.elems oldParents

2045− let s = Subscriber

2263+ let changeSubscriber = Subscriber

20462264 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

20472265 tracePropagate (Proxy :: Proxy x) $ "SubscriberMergeInt/Change"

20482266 defer $ updateMe a

20492267 , subscriberInvalidateHeight = \_ -> return ()

20502268 , subscriberRecalculateHeight = \_ -> return ()

20512269 }

2052− (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s

2270+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) changeSubscriber

20532271 forM_ change $ \c -> defer $ updateMe c

20542272 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.

20552273 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain

20562274 -- its subscription.

2057− liftIO $ writeIORef changeSubdRef (s, changeSubscription)

2275+ liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)

20582276 let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents

2059− return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parents, changeSubdRef)

2060− , occ

2061− )

2277+

2278+

2279+ return (EventSubscription unsubscribeAll subscribed, occ)

20622280

20632281newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }

20642282newtype 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

21242342-- | Run an event action outside of a frame

21252343runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex

21262344runFrame a = SpiderHost $ do

2127− let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)

2345+ let env = _spiderTimeline_eventEnv $ unSTE (spiderTimeline :: SpiderTimelineEnv x)

21282346 let go = do

21292347 result <- a

21302348 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

21412359 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env

21422360 forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do

21432361 writeIORef vRef v

2144− when debugInvalidate $ putStrLn $ "Invalidating Hold"

2362+ traceInvalidate $ "Invalidating Hold"

21452363 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef

21462364 mergeUpdates <- readIORef $ eventEnvMergeUpdates env

21472365 writeIORef (eventEnvMergeUpdates env) []

2148− when debugPropagate $ putStrLn "Updating merges"

2366+ tracePropagate (Proxy::Proxy x) $ "Updating merges"

21492367 mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates

2150− when debugPropagate $ putStrLn "Updating merges done"

2368+ tracePropagate (Proxy::Proxy x) $ "Updating merges done"

21512369 toReconnect <- readIORef toReconnectRef

21522370 clearEventEnv env

21532371 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do

21542372 oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed

21552373 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed

2156− when debugInvalidate $ putStrLn $ "Finalizing invalidator for Switch" <> showNodeId subscribed

2374+ traceInvalidate $ "Finalizing invalidator for Switch" <> showNodeId subscribed

21572375 finalize wi

21582376 i <- evaluate $ switchSubscribedOwnInvalidator subscribed

21592377 wi' <- mkWeakPtrWithDebug i "wi'"

@@ -2167,7 +2385,7 @@ runFrame a = SpiderHost $ do

21672385 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

21682386 {-

21692387 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

21712389 EventRoot _ -> "EventRoot"

21722390 EventNever -> "EventNever"

21732391 _ -> "something else"

@@ -2182,7 +2400,7 @@ runFrame a = SpiderHost $ do

21822400 myHeight <- readIORef $ switchSubscribedHeight subscribed

21832401 when (parentHeight /= myHeight) $ do

21842402 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight

2185− WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight

2403+ WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight

21862404 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

21872405 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do

21882406 unsubscribe subscription

@@ -2223,7 +2441,7 @@ invalidateCoincidenceHeight subscribed = do

22232441 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed

22242442 when (oldHeight /= invalidHeight) $ do

22252443 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight

2226− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

2444+ WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

22272445

22282446updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()

22292447updateSwitchHeight new subscribed = do

@@ -2231,7 +2449,7 @@ updateSwitchHeight new subscribed = do

22312449 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion

22322450 when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion

22332451 writeIORef (switchSubscribedHeight subscribed) $! new

2234− WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new

2452+ WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new

22352453

22362454recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()

22372455recalculateCoincidenceHeight subscribed = do

@@ -2240,7 +2458,7 @@ recalculateCoincidenceHeight subscribed = do

22402458 height <- calculateCoincidenceHeight subscribed

22412459 when (height /= invalidHeight) $ do

22422460 writeIORef (coincidenceSubscribedHeight subscribed) $! height

2243− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height

2461+ WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height

22442462

22452463calculateSwitchHeight :: SwitchSubscribed x a -> IO Height

22462464calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)

@@ -2302,6 +2520,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Event

23022520 {-# INLINABLE headE #-}

23032521 headE = R.slowHeadE

23042522-- headE (SpiderEvent e) = SpiderEvent <$> Reflex.Spider.Internal.headE e

2523+ {-# INLINABLE now #-}

2524+ now = nowSpiderEventM

23052525

23062526instance Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where

23072527 {-# INLINABLE sample #-}

@@ -2323,6 +2543,9 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide

23232543 {-# INLINABLE headE #-}

23242544 headE = R.slowHeadE

23252545-- headE (SpiderEvent e) = SpiderPushM $ SpiderEvent <$> Reflex.Spider.Internal.headE e

2546+ {-# INLINABLE now #-}

2547+ now = SpiderPushM nowSpiderEventM

2548+

23262549

23272550instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where

23282551 {-# INLINE return #-}

@@ -2331,11 +2554,13 @@ instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x))

23312554 x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x

23322555 {-# INLINE (>>) #-}

23332556 (>>) = (*>)

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

23342558 {-# INLINE fail #-}

23352559 fail _ = error "Dynamic does not support 'fail'"

2560+#endif

23362561

23372562{-# 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)

23392564newJoinDyn d =

23402565 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)

23412566 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

23842609 buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e

23852610 {-# INLINABLE headE #-}

23862611 headE e = runFrame . runSpiderHostFrame $ Reflex.Class.headE e

2612+ {-# INLINABLE now #-}

2613+ now = runFrame . runSpiderHostFrame $ Reflex.Class.now

2614+

23872615

23882616instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where

23892617 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

24002628 {-# INLINABLE headE #-}

24012629 headE = R.slowHeadE

24022630-- headE (SpiderEvent e) = SpiderHostFrame $ SpiderEvent <$> Reflex.Spider.Internal.headE e

2631+ {-# INLINABLE now #-}

2632+ now = SpiderHostFrame Reflex.Class.now

24032633

24042634instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where

24052635 {-# INLINABLE sample #-}

@@ -2420,6 +2650,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Refle

24202650 buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e

24212651 {-# INLINABLE headE #-}

24222652 headE e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.headE e

2653+ {-# INLINABLE now #-}

2654+ now = Reflex.Spider.Internal.ReadPhase Reflex.Class.now

24232655

24242656--------------------------------------------------------------------------------

24252657-- Deprecated items

@@ -2457,13 +2689,13 @@ instance HasSpiderTimeline x => Reflex.Host.Class.MonadReadEvent (SpiderTimeline

24572689 touch h

24582690 return result

24592691

2460−instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where

2692+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where

24612693 newEventWithTrigger = SpiderHost . fmap SpiderEvent . newEventWithTriggerIO

24622694 newFanEventWithTrigger f = SpiderHost $ do

24632695 es <- newFanEventWithTriggerIO f

24642696 return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es

24652697

2466−instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where

2698+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where

24672699 newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO

24682700 newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do

24692701 es <- newFanEventWithTriggerIO f

@@ -2485,7 +2717,7 @@ unsafeNewSpiderTimelineEnv = do

24852717#ifdef DEBUG

24862718 depthRef <- newIORef 0

24872719#endif

2488− return $ SpiderTimelineEnv

2720+ return $ STE $ SpiderTimelineEnv

24892721 { _spiderTimeline_lock = lock

24902722 , _spiderTimeline_eventEnv = env

24912723#ifdef DEBUG

@@ -2501,13 +2733,13 @@ data LocalSpiderTimeline (x :: Type) s

25012733

25022734instance Reifies s (SpiderTimelineEnv x) =>

25032735 HasSpiderTimeline (LocalSpiderTimeline x s) where

2504− spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s)

2736+ spiderTimeline = localSpiderTimeline Proxy $ reflect (Proxy :: Proxy s)

25052737

25062738localSpiderTimeline

2507− :: Proxy s

2739+ :: proxy s

25082740 -> SpiderTimelineEnv x

25092741 -> SpiderTimelineEnv (LocalSpiderTimeline x s)

2510−localSpiderTimeline _ = unsafeCoerce

2742+localSpiderTimeline _ = coerce

25112743

25122744-- | Pass a new timeline to the given function.

25132745withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r

@@ -2525,8 +2757,8 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

25252757 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}

25262758 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }

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

2529− newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }

2760+ newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: DynamicS x (Identity a) } -- deriving (Functor, Applicative, Monad)

2761+ newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: DynamicS x p }

25302762 type PullM (SpiderTimeline x) = SpiderPullM x

25312763 type PushM (SpiderTimeline x) = SpiderPushM x

25322764 {-# INLINABLE never #-}

@@ -2543,7 +2775,7 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

25432775 fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))

25442776 {-# INLINABLE mergeG #-}

25452777 mergeG

2546− :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k

2778+ :: forall k2 (k :: k2 -> *) q (v :: k2 -> *). GCompare k

25472779 => (forall a. q a -> R.Event (SpiderTimeline x) (v a))

25482780 -> DMap k q

25492781 -> R.Event (SpiderTimeline x) (DMap k v)

@@ -2555,7 +2787,7 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

25552787 {-# INLINABLE current #-}

25562788 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic

25572789 {-# INLINABLE updated #-}

2558− updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic

2790+ updated = SpiderEvent #. dynamicUpdated .# fmap coerce . unSpiderDynamic

25592791 {-# INLINABLE unsafeBuildDynamic #-}

25602792 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'

25612793 {-# INLINABLE unsafeBuildIncremental #-}

@@ -2574,9 +2806,10 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

25742806 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'

25752807 eventCoercion Coercion = Coercion

25762808 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

25782811 {-# 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

25802813 {-# INLINABLE fanInt #-}

25812814 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))

25822815

@@ -2610,8 +2843,14 @@ instance Monad (SpiderHost x) where

26102843 SpiderHost x >> SpiderHost y = SpiderHost $ x >> y

26112844 {-# INLINABLE return #-}

26122845 return x = SpiderHost $ return x

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

26132847 {-# INLINABLE fail #-}

2614− fail s = SpiderHost $ fail s

2848+ fail = MonadFail.fail

2849+#endif

2850+

2851+instance MonadFail (SpiderHost x) where

2852+ {-# INLINABLE fail #-}

2853+ fail s = SpiderHost $ MonadFail.fail s

26152854

26162855-- | Run an action affecting the global Spider timeline; this will be guarded by

26172856-- a mutex for that timeline

@@ -2633,19 +2872,21 @@ instance Monad (SpiderHostFrame x) where

26332872 SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y

26342873 {-# INLINABLE return #-}

26352874 return x = SpiderHostFrame $ return x

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

26362876 {-# INLINABLE fail #-}

26372877 fail s = SpiderHostFrame $ fail s

2878+#endif

26382879

26392880instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where

26402881 notReadyUntil _ = pure ()

26412882 notReady = pure ()

26422883

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)

26442885newEventWithTriggerIO f = do

26452886 es <- newFanEventWithTriggerIO $ \Refl -> f

26462887 return $ select es Refl

26472888

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)

26492890newFanEventWithTriggerIO f = do

26502891 occRef <- newIORef DMap.empty

26512892 subscribedRef <- newIORef DMap.empty

@@ -2679,3 +2920,11 @@ instance MonadAtomicRef (SpiderHostFrame x) where

26792920instance PrimMonad (SpiderHostFrame x) where

26802921 type PrimState (SpiderHostFrame x) = PrimState IO

26812922 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

122122 buildDynamic a0 = lift . buildDynamic a0

123123 {-# INLINABLE headE #-}

124124 headE = lift . headE

125+ {-# INLINABLE now #-}

126+ now = lift now

125127

126128instance Adjustable t m => Adjustable t (TriggerEventT t m) where

127129 {-# INLINABLE runWithReplace #-}

src/Reflex/TriggerEvent/Class.hs+6−1

@@ -2,7 +2,6 @@

22-- new 'Event's that can be triggered from 'IO'.

33{-# LANGUAGE FlexibleInstances #-}

44{-# LANGUAGE FunctionalDependencies #-}

5−{-# LANGUAGE MultiParamTypeClasses #-}

65{-# LANGUAGE UndecidableInstances #-}

76module Reflex.TriggerEvent.Class

87 ( TriggerEvent (..)

@@ -13,6 +12,7 @@ import Reflex.Class

1312import Control.Monad.Reader

1413import Control.Monad.State

1514import qualified Control.Monad.State.Strict as Strict

15+import Control.Monad.Trans.Maybe (MaybeT)

1616

1717--TODO: Shouldn't have IO hard-coded

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

4848 newTriggerEvent = lift newTriggerEvent

4949 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

5050 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

51+

52+instance TriggerEvent t m => TriggerEvent t (MaybeT m) where

53+ newTriggerEvent = lift newTriggerEvent

54+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

55+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

src/Reflex/Widget/Basic.hs+1−1

@@ -13,7 +13,7 @@ import Data.Map (Map)

1313

1414import Reflex.Class

1515import Reflex.Adjustable.Class

16−import Reflex.Patch.MapWithMove

16+import Data.Patch.MapWithMove

1717

1818

1919-- | Build sortable content in such a way that re-sorting it can cause minimal

src/Reflex/Workflow.hs+1−1

@@ -34,7 +34,7 @@ workflow w0 = do

3434 rec eResult <- networkHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult

3535 return $ fmap fst eResult

3636

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

3838workflowView :: 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)

3939workflowView w0 = do

4040 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

1818import Data.IORef

1919import Data.Semigroup

2020import Data.These

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

2122

2223import Data.Functor.Misc

23−import Reflex.Patch

24+import Data.Patch

2425

2526import qualified Reflex.Host.Class as Host

2627import qualified Reflex.Spider.Internal as S

@@ -83,7 +84,6 @@ hostPerf ref = S.runSpiderHost $ do

8384 Nothing -> []

8485 Host.fireEventsAndRead followupEventTriggers $ return ()

8586 return ()

86− return ()

8787

8888data Tell a where

8989 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

2424#endif

2525

2626import Reflex

27−import Reflex.Patch.MapWithMove

27+import Data.Patch.MapWithMove

2828import Test.Run

2929

3030newtype MyQuery = MyQuery SelectedCount

test/Reflex/Bench/Focused.hs+12

@@ -130,6 +130,16 @@ mapDynChain = iterM (return . fmap (+1))

130130joinDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

131131joinDynChain = iterM (\d -> return $ join $ fmap (const d) d)

132132

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+

133143combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

134144combineDynChain = iterM (\d -> return $ zipDynWith (+) d d)

135145

@@ -308,6 +318,8 @@ dynamics :: Word -> [(String, TestCase)]

308318dynamics n =

309319 [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d

310320 , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d

321+ , testE "holdDynChain" $ fmap updated $ holdDynChain n =<< d

322+ , testE "buildDynChain" $ fmap updated $ buildDynChain n =<< d

311323 , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d

312324 , testE "dense mergeTree" $ fmap (updated . mergeTreeDyn 8) dense

313325 , testE "sparse mergeTree" $ fmap (updated . mergeTreeDyn 8) sparse

test/Reflex/Plan/Pure.hs+1

@@ -41,6 +41,7 @@ instance MonadHold (Pure Int) PurePlan where

4141 holdIncremental initial = liftPlan . holdIncremental initial

4242 buildDynamic getInitial = liftPlan . buildDynamic getInitial

4343 headE = liftPlan . headE

44+ now = liftPlan now

4445

4546instance MonadSample (Pure Int) PurePlan where

4647 sample = liftPlan . sample

test/Reflex/Test/CrossImpl.hs+18−8

@@ -21,11 +21,12 @@ import Reflex.Dynamic

2121import Reflex.Host.Class

2222import qualified Reflex.Pure as P

2323import qualified Reflex.Spider.Internal as S

24+import qualified Reflex.Profiled as Prof

2425

2526import Control.Arrow (second, (&&&))

2627import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

2728import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

28−import Data.Dependent.Map (DSum (..))

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

2930import Data.Foldable

3031import Data.Map.Strict (Map)

3132import qualified Data.Map.Strict as Map

@@ -35,8 +36,6 @@ import Data.Traversable

3536import System.Exit

3637import System.Mem

3738

38−import System.IO.Unsafe

39−

4039mapToPureBehavior :: Map Int a -> Behavior PureReflexDomain a

4140mapToPureBehavior m = P.Behavior $ \t -> case Map.lookupLE t m of

4241 Nothing -> error $ "mapToPureBehavior: no value for time " <> show t

@@ -73,11 +72,14 @@ instance MapMSignals (Event t a) (Event t' a) t t' where

7372instance (MapMSignals a a' t t', MapMSignals b b' t t') => MapMSignals (a, b) (a', b') t t' where

7473 mapMSignals fb fe (a, b) = liftM2 (,) (mapMSignals fb fe a) (mapMSignals fb fe b)

7574

76−testSpider :: (forall m t. TestCaseConstraint t m => (Behavior t a, Event t b) -> m (Behavior t c, Event t d)) -> (Map Int a, Map Int b) -> (Map Int c, Map Int d)

77−testSpider builder (bMap, eMap) = unsafePerformIO $ S.runSpiderHost $ do

75+testTimeline

76+ :: (forall m t. TestCaseConstraint t m => (Behavior t a, Event t b) -> m (Behavior t c, Event t d))

77+ -> (Map Int a, Map Int b)

78+ -> (forall m t. (MonadReflexHost t m, MonadIO m, MonadRef m, Ref m ~ Ref IO, MonadSample t m) => m (Map Int c, Map Int d))

79+testTimeline builder (bMap, eMap) = do

7880 (re, reTrigger) <- newEventWithTriggerRef

7981 (rb, rbTrigger) <- newEventWithTriggerRef

80− b <- runHostFrame $ hold (error "testSpider: No value for input behavior yet") rb

82+ b <- runHostFrame $ hold (error "testTimeline: No value for input behavior yet") rb

8183 (b', e') <- runHostFrame $ builder (b, re)

8284 e'Handle <- subscribeEvent e' --TODO: This should be unnecessary

8385 let times = relevantTestingTimes (bMap, eMap)

@@ -102,9 +104,11 @@ testAgreement :: (Eq c, Eq d, Show c, Show d) => (forall m t. TestCaseConstraint

102104testAgreement builder inputs = do

103105 let identityResult = testPure builder inputs

104106 tracePerf "---------" $ return ()

105− let spiderResult = testSpider builder inputs

107+ spiderResult <- S.runSpiderHost $ testTimeline builder inputs

108+ tracePerf "---------" $ return ()

109+ profiledResult <- S.runSpiderHost $ Prof.runProfiledM $ testTimeline builder inputs

106110 tracePerf "---------" $ return ()

107− let resultsAgree = identityResult == spiderResult

111+ let resultsAgree = identityResult == spiderResult && identityResult == profiledResult

108112 if resultsAgree

109113 then do --putStrLn "Success:"

110114 --print identityResult

@@ -112,6 +116,7 @@ testAgreement builder inputs = do

112116 else do putStrLn "Failure:"

113117 putStrLn $ "Pure result: " <> show identityResult

114118 putStrLn $ "Spider result: " <> show spiderResult

119+ putStrLn $ "Profiled result: " <> show profiledResult

115120 return resultsAgree

116121

117122type TestCaseConstraint t m = (Reflex t, MonadSample t m, MonadHold t m, MonadFix m, MonadFix (PushM t))

@@ -218,6 +223,11 @@ testCases =

218223 bb <- hold b $ pushAlways (const $ hold "asdf" eo) eo

219224 let b' = pull $ sample =<< sample bb

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

221231 , (,) "joinDyn" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

222232 bb <- hold "b" e

223233 bd <- hold never . fmap (const e) =<< headE e

test/Reflex/Test/Micro.hs+8−2

@@ -322,8 +322,14 @@ testCases =

322322 let e = never <$ switch b

323323 return $ void e

324324 lazyHold

325−

326−

325+ , testE "now-1" $ do

326+ e1 <- events1

327+ switchHoldPromptly never . pushAlways (\a -> fmap (a <$) now) $ e1

328+ , testE "now-2" $ do

329+ e1 <- events1

330+ let e = pushAlways (\a -> if a == "a" then now else return never) e1

331+ x <- accumDyn (<>) never e

332+ return . coincidence $ updated x

327333 ] where

328334

329335 events1, events2, events3 :: TestPlan t m => m (Event t String)

test/RequesterT.hs+63−2

@@ -1,20 +1,36 @@

11{-# LANGUAGE CPP #-}

22{-# LANGUAGE BangPatterns #-}

33{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleInstances #-}

45{-# LANGUAGE GADTs #-}

5−{-# LANGUAGE RankNTypes #-}

6+{-# LANGUAGE LambdaCase #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

68{-# LANGUAGE RecursiveDo #-}

79{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE TemplateHaskell #-}

11+{-# LANGUAGE TypeApplications #-}

12+{-# LANGUAGE TypeFamilies #-}

813module Main where

914

10−import Control.Lens

15+import Control.Lens hiding (has)

1116import Control.Monad

1217import Control.Monad.Fix

18+import Control.Monad.IO.Class (MonadIO)

19+import Data.Constraint.Extras

20+import Data.Constraint.Extras.TH

21+import Data.Constraint.Forall

1322import qualified Data.Dependent.Map as DMap

1423import Data.Dependent.Sum

1524import Data.Functor.Misc

25+import Data.List (words)

26+import Data.Map (Map)

1627import qualified Data.Map as M

28+#if !MIN_VERSION_these(4,11,0)

29+import Data.Semigroup ((<>))

30+#endif

31+import Data.Text (Text)

1732import Data.These

33+import Text.Read (readMaybe)

1834

1935#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))

2036import Data.These.Lens

@@ -49,12 +65,19 @@ main = do

4965 print os5

5066 os6 <- runApp' (unwrapApp delayedPulse) [Just ()]

5167 print os6

68+ os7 <- runApp' testMatchRequestsWithResponses [ Just $ TestRequest_Increment 1 ]

69+ print os7

70+ os8 <- runApp' testMatchRequestsWithResponses [ Just $ TestRequest_Reverse "yoyo" ]

71+ print os8

5272 let ![[Just [1,2,3,4,5,6,7,8,9,10]]] = os1 -- The order is reversed here: see the documentation for 'runRequesterT'

5373 let ![[Just [9,7,5,3,1]],[Nothing,Nothing],[Just [10,8,6,4,2]],[Just [10,8,6,4,2],Nothing]] = os2

5474 let ![[Nothing, Just [2]]] = os3

5575 let ![[Nothing, Just [2]]] = os4

5676 let ![[Nothing, Just [1, 2]]] = os5

5777 -- let ![[Nothing, Nothing]] = os6 -- TODO re-enable this test after issue #233 has been resolved

78+ let !(Just [(1,"2")]) = M.toList <$> head (head os7)

79+ let !(Just [(1,"oyoy")]) = M.toList <$> head (head os8)

80+

5881 return ()

5982

6083unwrapRequest :: DSum tag RequestInt -> Int

@@ -172,3 +195,41 @@ delayedPulse pulse = void $ flip runWithReplace (pure () <$ pulse) $ do

172195 -- This has the effect of delaying pulse' from pulse

173196 (_, pulse') <- runWithReplace (pure ()) $ pure (RequestInt 1) <$ pulse

174197 requestingIdentity pulse'

198+

199+data TestRequest a where

200+ TestRequest_Reverse :: String -> TestRequest String

201+ TestRequest_Increment :: Int -> TestRequest Int

202+

203+testMatchRequestsWithResponses

204+ :: forall m t req a

205+ . ( MonadFix m

206+ , MonadHold t m

207+ , Reflex t

208+ , PerformEvent t m

209+ , MonadIO (Performable m)

210+ , ForallF Show req

211+ , Has Read req

212+ )

213+ => Event t (req a) -> m (Event t (Map Int String))

214+testMatchRequestsWithResponses pulse = mdo

215+ (_, requests) <- runRequesterT (requesting pulse) responses

216+ let rawResponses = M.map (\v ->

217+ case words v of

218+ ["reverse", str] -> reverse str

219+ ["increment", i] -> show $ succ $ (read i :: Int)

220+ ) <$> rawRequestMap

221+ (rawRequestMap, responses) <- matchResponsesWithRequests reqEncoder requests (head . M.toList <$> rawResponses)

222+ pure rawResponses

223+ where

224+ reqEncoder :: forall a. req a -> (String, String -> Maybe a)

225+ reqEncoder r =

226+ ( whichever @Show @req @a $ show r

227+ , \x -> has @Read r $ readMaybe x

228+ )

229+

230+deriveArgDict ''TestRequest

231+

232+instance Show (TestRequest a) where

233+ show = \case

234+ TestRequest_Reverse str -> "reverse " <> str

235+ TestRequest_Increment i -> "increment " <> show i

test/hlint.hs+2−8

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

11module Main where

33import Control.Monad

4−import Language.Haskell.HLint3 (hlint)

4+import Language.Haskell.HLint (hlint)

55import System.Directory

66import System.Exit (exitFailure, exitSuccess)

77import System.FilePath

@@ -22,6 +22,7 @@ main = do

2222 , "--ignore=Use unless"

2323 , "--ignore=Reduce duplication"

2424 , "--cpp-define=USE_TEMPLATE_HASKELL"

25+ , "--cpp-define=DEBUG"

2526 , "--ignore=Use tuple-section"

2627 ]

2728 recurseInto = and <$> sequence

@@ -30,16 +31,9 @@ main = do

3031 ]

3132 matchFile = and <$> sequence

3233 [ extension ==? ".hs"

33− , let notElem' = liftOp notElem

34− in filePath `notElem'` filePathExceptions pwd

3534 ]

3635 files <- find recurseInto matchFile (pwd </> "src") --TODO: Someday fix all hints in tests, etc.

3736 ideas <- fmap concat $ forM files $ \f -> do

3837 putStr $ "linting file " ++ drop (length pwd + 1) f ++ "... "

3938 runHlint f

4039 if null ideas then exitSuccess else exitFailure

41−

42−filePathExceptions :: FilePath -> [FilePath]

43−filePathExceptions pwd = map (pwd </>) $

44− [ "src/Data/AppendMap.hs" -- parse error when hlint runs

45− ]