3c419d9..develop · reflex

git.iko.soy/reflex

73 files changed+2301−2871

unifiedsplit

.github/workflows/haskell.yml+41 .travis.yml−171 ChangeLog.md+98−4 Quickref.md+15−11 README.md+15−17 cabal.haskell-ci+7 cabal.project.freeze−1 dep/reflex-platform/default.nix+7 dep/reflex-platform/github.json+7 hydra.json−29 jobsets.nix−70 reflex-platform.nix−8 reflex.cabal+134−41 release.nix+56−7 src/Control/Monad/ReaderIO.hs+1−1 src/Data/AppendMap.hs+2−2 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/TagMap.hs−39 src/Data/Unique/Tag/Local.hs−11 src/Data/Unique/Tag/Local/Internal.hs−59 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+39−9 src/Reflex/Collection.hs+5−2 src/Reflex/Dynamic.hs+17−3 src/Reflex/DynamicWriter/Base.hs+14−5 src/Reflex/DynamicWriter/Class.hs−1 src/Reflex/EventWriter/Base.hs+16−8 src/Reflex/FanTag.hs−23 src/Reflex/FastWeak.hs+10 src/Reflex/Host/Headless.hs+128 src/Reflex/Network.hs+1−1 src/Reflex/NotReady/Class.hs−5 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−70 src/Reflex/Patch/Map.hs−55 src/Reflex/Patch/MapWithMove.hs−270 src/Reflex/PerformEvent/Base.hs+19−82 src/Reflex/PerformEvent/Class.hs+6−1 src/Reflex/PostBuild/Base.hs+2−1 src/Reflex/PostBuild/Class.hs−1 src/Reflex/Profiled.hs+59−5 src/Reflex/Pure.hs+6−1 src/Reflex/Query/Base.hs+15−4 src/Reflex/Query/Class.hs+44−4 src/Reflex/Requester/Base.hs+599−14 src/Reflex/Requester/Base/Internal.hs−703 src/Reflex/Requester/Class.hs+1−1 src/Reflex/Spider/Internal.hs+501−275 src/Reflex/TriggerEvent/Base.hs+2 src/Reflex/TriggerEvent/Class.hs+6 src/Reflex/Widget/Basic.hs+1−1 src/Reflex/Workflow.hs+1−1 test/Adjustable.hs+62 test/DebugCycles.hs+171 test/EventWriterT.hs+11−15 test/GC.hs+2−2 test/Headless.hs+10 test/QueryT.hs+1−1 test/Reflex/Bench/Focused.hs+1−1 test/Reflex/Plan/Pure.hs+1 test/Reflex/Test/CrossImpl.hs+13−8 test/Reflex/Test/Micro.hs+8−2 test/RequesterT.hs+89−33 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−171

@@ -1,171 +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.20190814

8−#

9−language: c

10−dist: xenial

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":["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/ghcjs;

44− curl -s https://deb.nodesource.com/gpgkey/nodesource.gpg.key | sudo apt-key add -

45− sudo apt-add-repository 'https://deb.nodesource.com/node_8.x xenial main'

46− sudo apt-get update;

47− sudo apt-get install $CC cabal-install-3.0 nodejs;

48− fi

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

50− - WITHCOMPILER="-w $HC"

51− - |

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

53− GHCJS=true

54− HC=${HC}js

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

56− else

57− GHCJS=false;

58− fi

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

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

61− - HCPKG="$HC-pkg"

62− - unset CC

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

64− - CABALHOME=$HOME/.cabal

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

66− - TOP=$(pwd)

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

68− - echo $HCNUMVER

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

70− - set -o pipefail

71− - |

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

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

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

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

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

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

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

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

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

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

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

83− - cat .colorful.awk

84− - |

85− color_cabal_output () {

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

87− }

88− - echo text | color_cabal_output

89−install:

90− - ${CABAL} --version

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

92− - node --version

93− - echo $GHCJS

94− - TEST=--enable-tests

95− - BENCH=--enable-benchmarks

96− - BENCH=--disable-benchmarks

97− - HEADHACKAGE=false

98− - rm -f $CABALHOME/config

99− - |

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

115− - cat $CABALHOME/config

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

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

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

119− # Generate cabal.project

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

121− - touch cabal.project

122− - |

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

124− - |

125− - cat cabal.project || true

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

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

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

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

130− - rm cabal.project.freeze

131−script:

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

133− # Packaging...

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

135− # Unpacking...

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

137− - cd ${DISTDIR} || false

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

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

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

141− # Generate cabal.project

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

143− - touch cabal.project

144− - |

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

146− - |

147− - cat cabal.project || true

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

149− # Building...

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

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

152− # Building with tests and benchmarks...

153− # build & run tests, build benchmarks

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

155− # Testing...

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

157− # cabal check...

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

159− # haddock...

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

161− # Constraint sets

162− - rm -rf cabal.project.local

163− # Constraint set no-th

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

165− # Constraint set old-these

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

167− # Constraint set old-witherable

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

169−

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

171−# EOF

ChangeLog.md+98−4

@@ -1,5 +1,87 @@

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+

385## 0.6.2.4

486

587* Update to monoidal-containers 0.6

@@ -11,7 +93,9 @@

1193## 0.6.2.2

1294

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

96+

1497* Update version bounds to fix some CI failures

98+

1599* Add travis CI configuration

16100

17101## 0.6.2.1

@@ -26,32 +110,42 @@

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

27111

28112* Generalize merging functions:

29− `merge` to `mergeG`,

30− `mergeIncremental` to `mergeIncrementalG`,

31− `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`.

113+ `merge` to `mergeG`,

114+ `mergeIncremental` to `mergeIncrementalG`,

115+ `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`.

32116

33117* Generalize distribute function:

34118 `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`,

35119

36120## 0.6.2.0

37121

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

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

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

124+

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

126+

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

42128

43129## 0.6.1.0

44130

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

132+

46133* Fix `QueryT` and `RequesterT` tests

47134

48135## 0.6.0.0 -- 2019-03-20

49136

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

138+

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

140+

52141* Remove many deprecated functions.

142+

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

144+

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

146+

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

148+

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

150+

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

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

1010 constraints: reflex -use-template-haskell

1111

1212constraint-set old-these

13+ ghc: <8.8

1314 constraints: these <1

1415

1516constraint-set old-witherable

1617 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

cabal.project.freezedeleted−1

@@ -1 +0,0 @@

1−constraints: any.text < 1.2.4.0

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+134−41

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

11Name: reflex

2−Version: 0.6.2.4

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,45 +51,57 @@ 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,

60− dlist == 0.8.*,

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

6182 exception-transformers == 0.4.*,

62− profunctors >= 5.3 && < 5.5,

6383 lens >= 4.7 && < 5,

84+ mmorph >= 1.0 && < 1.2,

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

6586 mtl >= 2.1 && < 2.3,

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

87+ patch >= 0.0.1 && < 0.1,

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

6789 primitive >= 0.5 && < 0.8,

68− profunctors,

90+ profunctors >= 5.3 && < 5.7,

6991 random == 1.1.*,

7092 ref-tf == 0.4.*,

7193 reflection == 2.1.*,

7294 semigroupoids >= 4.0 && < 6,

7395 stm >= 2.4 && < 2.6,

7496 syb >= 0.5 && < 0.8,

75− time >= 1.4 && < 1.9,

97+ time >= 1.4 && < 1.10,

7698 transformers >= 0.5.6.0 && < 0.6,

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

78− witherable >= 0.3 && < 0.3.2

100+ witherable >= 0.3 && < 0.5

79101

80102 if flag(split-these)

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

82− semialign >=1 && <1.1,

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

104+ semialign >=1 && <1.2,

83105 monoidal-containers >= 0.6 && < 0.7

84106 else

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

@@ -90,17 +112,13 @@ library

90112 Data.AppendMap,

91113 Data.FastMutableIntMap,

92114 Data.FastWeakBag,

93− Data.Functor.Misc,

94115 Data.Map.Misc,

95− Data.TagMap,

96− Data.Unique.Tag.Local,

97− Data.Unique.Tag.Local.Internal,

98116 Data.WeakBag,

99117 Reflex,

118+ Reflex.Class,

100119 Reflex.Adjustable.Class,

101120 Reflex.BehaviorWriter.Base,

102121 Reflex.BehaviorWriter.Class,

103− Reflex.Class,

104122 Reflex.Collection,

105123 Reflex.Dynamic,

106124 Reflex.Dynamic.Uniq,

@@ -110,19 +128,12 @@ library

110128 Reflex.EventWriter,

111129 Reflex.EventWriter.Base,

112130 Reflex.EventWriter.Class,

113− Reflex.FanTag,

114131 Reflex.FastWeak,

115132 Reflex.FunctorMaybe,

116133 Reflex.Host.Class,

134+ Reflex.Host.Headless,

117135 Reflex.Network,

118136 Reflex.NotReady.Class,

119− Reflex.Patch,

120− Reflex.Patch.Class,

121− Reflex.Patch.DMap,

122− Reflex.Patch.DMapWithMove,

123− Reflex.Patch.IntMap,

124− Reflex.Patch.Map,

125− Reflex.Patch.MapWithMove,

126137 Reflex.PerformEvent.Base,

127138 Reflex.PerformEvent.Class,

128139 Reflex.PostBuild.Base,

@@ -132,7 +143,6 @@ library

132143 Reflex.Query.Base,

133144 Reflex.Query.Class,

134145 Reflex.Requester.Base,

135− Reflex.Requester.Base.Internal,

136146 Reflex.Requester.Class,

137147 Reflex.Spider,

138148 Reflex.Spider.Internal,

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

142152 Reflex.Widget.Basic,

143153 Reflex.Workflow

144154

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+

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

146166

147167 if flag(debug-trace-events)

148168 cpp-options: -DDEBUG_TRACE_EVENTS

149− build-depends: bytestring

169+ build-depends:

170+ bytestring >= 0.10.8 && < 0.11

150171

151172 if flag(use-reflex-optimizer)

152173 cpp-options: -DUSE_REFLEX_OPTIMIZER

153174 build-depends: ghc

154175 exposed-modules: Reflex.Optimizer

155176

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+

156183 if flag(use-template-haskell)

157184 cpp-options: -DUSE_TEMPLATE_HASKELL

158185 build-depends:

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

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

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

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

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

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

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

163190 exposed-modules:

164191 Reflex.Dynamic.TH

165192 other-extensions: TemplateHaskell

166193 else

167194 build-depends:

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

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

169196

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

171198 cpp-options: -DGHCJS_FAST_WEAK

172199

173200 if impl(ghcjs)

174− build-depends: ghcjs-base

201+ build-depends:

202+ ghcjs-base == 0.2.*

175203

176204test-suite semantics

205+ default-language: Haskell2010

177206 type: exitcode-stdio-1.0

178207 main-is: semantics.hs

179208 hs-source-dirs: test

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

199228 Reflex.TestPlan

200229

201230test-suite CrossImpl

231+ default-language: Haskell2010

202232 type: exitcode-stdio-1.0

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

204234 hs-source-dirs: test

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

220250 Reflex.Plan.Pure

221251

222252test-suite hlint

253+ default-language: Haskell2010

223254 type: exitcode-stdio-1.0

224255 main-is: hlint.hs

225256 hs-source-dirs: test

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

227258 , directory

228259 , filepath

229260 , filemanip

230− , hlint < 2.1 || >= 2.2.2

261+ if impl(ghc >= 8.8)

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

263+ else

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

231265 if impl(ghcjs)

232266 buildable: False

233267

234268test-suite EventWriterT

269+ default-language: Haskell2010

235270 type: exitcode-stdio-1.0

236271 main-is: EventWriterT.hs

237272 hs-source-dirs: test

@@ -251,27 +286,55 @@ test-suite EventWriterT

251286 build-depends: these-lens

252287

253288 other-modules:

254− Reflex.Test

255− Reflex.TestPlan

256− Reflex.Plan.Reflex

257− Reflex.Plan.Pure

289+ Test.Run

290+

291+

292+test-suite DebugCycles

293+ default-language: Haskell2010

294+ type: exitcode-stdio-1.0

295+ main-is: DebugCycles.hs

296+ hs-source-dirs: test

297+ ghc-options: -threaded

298+ build-depends: base

299+ , containers

300+ , deepseq

301+ , dependent-map

302+ , dependent-sum

303+ , hspec

304+ , lens

305+ , mtl

306+ , these

307+ , transformers

308+ , reflex

309+ , ref-tf

310+ , witherable

311+ , proctest

312+

313+

314+ if flag(split-these)

315+ build-depends: these-lens, semialign

316+

317+ other-modules:

258318 Test.Run

259319

260320

261321test-suite RequesterT

322+ default-language: Haskell2010

262323 type: exitcode-stdio-1.0

263324 main-is: RequesterT.hs

264325 hs-source-dirs: test

265326 build-depends: base

327+ , constraints

328+ , constraints-extras

266329 , containers

267330 , deepseq

268331 , dependent-map

269332 , dependent-sum

270333 , lens

271334 , mtl

272− , primitive

273335 , ref-tf

274336 , reflex

337+ , text

275338 , these

276339 , transformers

277340

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

283346 Reflex.Plan.Pure

284347 Test.Run

285348

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+

286372test-suite QueryT

373+ default-language: Haskell2010

287374 type: exitcode-stdio-1.0

288375 main-is: QueryT.hs

289376 hs-source-dirs: test

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

295382 , lens

296383 , monoidal-containers

297384 , mtl

385+ , patch

298386 , ref-tf

299387 , reflex

300388 , these

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

310398 Reflex.Plan.Pure

311399

312400test-suite GC-Semantics

401+ default-language: Haskell2010

313402 type: exitcode-stdio-1.0

314403 main-is: GC.hs

315404 hs-source-dirs: test

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

319408 , dependent-map

320409 , deepseq

321410 , mtl

411+ , patch

322412 , these

323413 , transformers

324414 , reflex

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

334424 Test.Run

335425

336426test-suite rootCleanup

427+ default-language: Haskell2010

337428 type: exitcode-stdio-1.0

338429 main-is: rootCleanup.hs

339430 hs-source-dirs: test

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

351442 Test.Run

352443

353444benchmark spider-bench

445+ default-language: Haskell2010

354446 type: exitcode-stdio-1.0

355447 hs-source-dirs: bench test

356448 main-is: Main.hs

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

375467 Reflex.Bench.Focused

376468

377469benchmark saulzar-bench

470+ default-language: Haskell2010

378471 type: exitcode-stdio-1.0

379472 hs-source-dirs: bench test

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

release.nix+56−7

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

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

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

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

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

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

3737#if MIN_VERSION_base(4,10,0)

3838 liftA2 = liftM2

3939 {-# INLINE liftA2 #-}

40−#endif

40+#endif

4141 (*>) = (>>)

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

4343

src/Data/AppendMap.hs+2−2

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

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

7171 then Nothing

7272 else Just bs

7373

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

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

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

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

7777showTree = 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/TagMap.hsdeleted−39

@@ -1,39 +0,0 @@

1−{-# LANGUAGE PolyKinds #-}

2−{-# LANGUAGE ScopedTypeVariables #-}

3−module Data.TagMap

4− ( TagMap

5− , unTagMap

6− , fromDMap

7− , toDMap

8− , fromList

9− , insert

10− , size

11− ) where

12−

13−import Data.IntMap (IntMap)

14−import qualified Data.IntMap as IntMap

15−import Data.Dependent.Map (DMap)

16−import qualified Data.Dependent.Map as DMap

17−import Data.Dependent.Sum (DSum (..))

18−import Data.Unique.Tag.Local

19−

20−import GHC.Exts (Any)

21−import Unsafe.Coerce

22−

23−-- | Like DMap, but with 'Data.Unique.Tag.Tag' as the keys. Implemented using 'Data.IntMap.IntMap' under the hood.

24−newtype TagMap x (v :: k -> *) = TagMap { unTagMap :: IntMap Any }

25−

26−fromDMap :: forall k x (v :: k -> *). DMap (Tag x) v -> TagMap x v

27−fromDMap = TagMap . IntMap.fromDistinctAscList . fmap (\((k :: Tag x (a :: k)) :=> v) -> (tagId k, (unsafeCoerce :: v a -> Any) v)) . DMap.toAscList

28−

29−toDMap :: forall x v. TagMap x v -> DMap (Tag x) v

30−toDMap = DMap.fromDistinctAscList . fmap (\(k, v) -> (unsafeTagFromId k :=> (unsafeCoerce :: Any -> v a) v)) . IntMap.toAscList . unTagMap

31−

32−insert :: forall x a v. Tag x a -> v a -> TagMap x v -> TagMap x v

33−insert k v = TagMap . IntMap.insert (tagId k) ((unsafeCoerce :: v a -> Any) v) . unTagMap

34−

35−fromList :: [DSum (Tag x) v] -> TagMap x v

36−fromList = TagMap . IntMap.fromList . fmap (\(t :=> v) -> (tagId t, (unsafeCoerce :: v a -> Any) v))

37−

38−size :: TagMap x v -> Int

39−size = IntMap.size . unTagMap

src/Data/Unique/Tag/Local.hsdeleted−11

@@ -1,11 +0,0 @@

1−module Data.Unique.Tag.Local

2− ( Tag

3− , TagGen (..)

4− , tagId

5− , unsafeTagFromId

6− , newTag

7− , newTagGen

8− , withTagGen

9− ) where

10−

11−import Data.Unique.Tag.Local.Internal

src/Data/Unique/Tag/Local/Internal.hsdeleted−59

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

1−-- | The type-safety of this module depends on two assumptions:

2−-- 1. If the `s` parameters on two `TagGen`s can unify, then they contain the same MutVar

3−-- 2. Two Tag values made from the same TagGen never contain the same Int

4−

5−{-# LANGUAGE EmptyDataDecls #-}

6−{-# LANGUAGE DeriveFunctor #-}

7−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8−{-# LANGUAGE TypeFamilies #-}

9−{-# LANGUAGE PolyKinds #-}

10−{-# LANGUAGE RankNTypes #-}

11−{-# LANGUAGE ScopedTypeVariables #-}

12−{-# LANGUAGE MagicHash #-}

13−module Data.Unique.Tag.Local.Internal where

14−

15−import Control.Monad.Exception

16−import Control.Monad.Primitive

17−import Control.Monad.Reader

18−import Data.Primitive.MutVar

19−import Data.GADT.Compare

20−import Data.Some

21−import GHC.Exts (Int (..), Int#, MutVar#, unsafeCoerce#)

22−

23−import Unsafe.Coerce

24−

25−newtype Tag x a = Tag Int

26−

27−tagId :: Tag x a -> Int

28−tagId (Tag n) = n

29−

30−-- | WARNING: If you construct a tag with the wrong type, it will result in

31−-- incorrect unsafeCoerce applications, which can segfault or cause arbitrary

32−-- other damage to your program

33−unsafeTagFromId :: Int -> Tag x a

34−unsafeTagFromId n = Tag n

35−

36−-- We use Int because it is supported by e.g. IntMap

37−newtype TagGen ps s = TagGen { unTagGen :: MutVar ps Int }

38−

39−instance Show (TagGen ps s) where

40− show (TagGen (MutVar m)) = show $ I# ((unsafeCoerce# :: MutVar# ps Int -> Int#) m)

41−

42−instance GEq (TagGen ps) where

43− TagGen a `geq` TagGen b =

44− if a == b

45− then Just $ unsafeCoerce Refl

46− else Nothing

47−

48−newTag :: PrimMonad m => TagGen (PrimState m) s -> m (Tag s a)

49−newTag (TagGen r) = do

50− n <- atomicModifyMutVar' r $ \x -> (succ x, x)

51− pure $ Tag n

52−

53−newTagGen :: PrimMonad m => m (Some (TagGen (PrimState m)))

54−newTagGen = Some . TagGen <$> newMutVar minBound

55−

56−withTagGen :: PrimMonad m => (forall s. TagGen (PrimState m) s -> m a) -> m a

57−withTagGen f = do

58− g <- newTagGen

59− withSome g f

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

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

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

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

173173 , slowHeadE

174174 ) where

175175

176−#if defined(MIN_VERSION_semialign)

176+#ifdef MIN_VERSION_semialign

177177import Prelude hiding (zip, zipWith)

178178

179179#if MIN_VERSION_these(0,8,0)

180180import Data.These.Combinators (justThese)

181181#endif

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

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

184+#endif

182185#endif

183186

184187import Control.Applicative

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

193196import Data.Bifunctor

194197import Data.Coerce

195198import Data.Default

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

199+import Data.Dependent.Map (DMap)

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

197201import qualified Data.Dependent.Map as DMap

198202import Data.Functor.Compose

199203import Data.Functor.Product

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

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

201205import Data.FastMutableIntMap (PatchIntMap)

202206import Data.Foldable

203207import Data.Functor.Bind

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

207211import qualified Data.IntMap.Strict as IntMap

208212import Data.List.NonEmpty (NonEmpty (..))

209213import Data.Map (Map)

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

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

211215import Data.Some (Some(Some))

212216import Data.String

213217import Data.These

214218import Data.Type.Coercion

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

215220import Data.Witherable (Filterable(..))

216221import qualified Data.Witherable as W

217222import Reflex.FunctorMaybe (FunctorMaybe)

218223import qualified Reflex.FunctorMaybe

219−import Reflex.Patch

220−import qualified Reflex.Patch.MapWithMove as PatchMapWithMove

224+import Data.Patch

225+import qualified Data.Patch.MapWithMove as PatchMapWithMove

221226

222227import Debug.Trace (trace)

223228

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

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

284289 -- 'Event' occurs

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

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

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

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

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

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

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

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

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

416422 -- the supplied 'Event'.

417423 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

418431

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

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

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

560573 holdIncremental a0 = lift . holdIncremental a0

561574 buildDynamic a0 = lift . buildDynamic a0

562575 headE = lift . headE

576+ now = lift now

563577

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

565579 sample = lift . sample

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

570584 holdIncremental a0 = lift . holdIncremental a0

571585 buildDynamic a0 = lift . buildDynamic a0

572586 headE = lift . headE

587+ now = lift now

573588

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

575590 sample = lift . sample

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

580595 holdIncremental a0 = lift . holdIncremental a0

581596 buildDynamic a0 = lift . buildDynamic a0

582597 headE = lift . headE

598+ now = lift now

583599

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

585601 sample = lift . sample

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

590606 holdIncremental a0 = lift . holdIncremental a0

591607 buildDynamic a0 = lift . buildDynamic a0

592608 headE = lift . headE

609+ now = lift now

593610

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

595612 sample = lift . sample

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

600617 holdIncremental a0 = lift . holdIncremental a0

601618 buildDynamic a0 = lift . buildDynamic a0

602619 headE = lift . headE

620+ now = lift now

603621

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

605623 sample = lift . sample

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

610628 holdIncremental a0 = lift . holdIncremental a0

611629 buildDynamic a0 = lift . buildDynamic a0

612630 headE = lift . headE

631+ now = lift now

613632

614633--------------------------------------------------------------------------------

615634-- Convenience functions

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

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

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

661680 return = constant

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

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

683+#endif

663684

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

665686 mempty = constant mempty

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

10771098#endif

10781099 align = alignEventWithMaybe Just

10791100

1080−#if defined(MIN_VERSION_semialign)

1101+#ifdef MIN_VERSION_semialign

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

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

1104+#endif

10811105 zip x y = mapMaybe justThese $ align x y

10821106#endif

10831107

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

10841114

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

10861116-- 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−3

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

@@ -191,7 +196,6 @@ switchPromptlyDyn de =

191196 let eLag = switch $ current de

192197 eCoincidences = coincidence $ updated de

193198 in leftmost [eCoincidences, eLag]

194−--TODO: switchPromptlyDyn should get the `only` treatment like switchHoldPromptOnly

195199

196200-- | Split a 'Dynamic' pair into a pair of 'Dynamic's

197201splitDynPure :: Reflex t => Dynamic t (a, b) -> (Dynamic t a, Dynamic t b)

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

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

203207distributeMapOverDynPure = fmap dmapToMap . distributeDMapOverDynPure . mapWithFunctorToDMap

204208

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+

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

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

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

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

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

215224joinDynThroughMap = (distributeMapOverDynPure =<<)

216225

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+

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

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

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

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

334348--

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

336350--

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

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

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

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

340354 , 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−1

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

2626

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

2828 tellDyn = lift . tellDyn

29−

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

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

@@ -200,9 +211,6 @@ sequenceIntMapWithAdjustEventWriterTWith base mergePatchIncremental coincidenceP

200211 h : t -> Just $ sconcat $ h :| t

201212 return (result0, result')

202213

203−switchHoldPromptOnlyIntMapIncremental :: (Reflex t, MonadHold t m) => IntMap (Event t a) -> Event t (PatchIntMap (Event t a)) -> m (Event t (IntMap a))

204−switchHoldPromptOnlyIntMapIncremental = switchHoldPromptOnlyIncremental mergeIntIncremental coincidencePatchIntMap

205−

206214-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.

207215sequenceDMapWithAdjustEventWriterTWith

208216 :: forall t m p p' w k v v'

src/Reflex/FanTag.hsdeleted−23

@@ -1,23 +0,0 @@

1−{-# LANGUAGE PolyKinds #-}

2−{-# LANGUAGE ScopedTypeVariables #-}

3−module Reflex.FanTag

4− ( EventSelectorTag

5− , unEventSelectorTag

6− , fanTag

7− , selectTag

8− ) where

9−

10−import Data.Unique.Tag.Local

11−import Data.TagMap

12−import Reflex.Class

13−

14−import GHC.Exts (Any)

15−import Unsafe.Coerce

16−

17−newtype EventSelectorTag t x (v :: k -> *) = EventSelectorTag { unEventSelectorTag :: EventSelectorInt t Any }

18−

19−fanTag :: Reflex t => Event t (TagMap x v) -> EventSelectorTag t x v

20−fanTag = EventSelectorTag . fanInt . fmapCheap unTagMap

21−

22−selectTag :: forall t x v a. Reflex t => EventSelectorTag t x v -> Tag x a -> Event t (v a)

23−selectTag (EventSelectorTag s) = fmapCheap (unsafeCoerce :: Any -> v a) . selectInt s . tagId

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/NotReady/Class.hs−5

@@ -25,7 +25,6 @@ import Reflex.PerformEvent.Base (PerformEventT (..))

2525import Reflex.PostBuild.Base (PostBuildT)

2626import Reflex.Query.Base (QueryT)

2727import Reflex.Requester.Base (RequesterT)

28−import Reflex.Requester.Base.Internal (RequesterInternalT)

2928import Reflex.TriggerEvent.Base (TriggerEventT)

3029

3130class Monad m => NotReady t m | m -> t where

@@ -73,10 +72,6 @@ instance NotReady t m => NotReady t (RequesterT t request response m) where

7372 notReadyUntil = lift . notReadyUntil

7473 notReady = lift notReady

7574

76−instance NotReady t m => NotReady t (RequesterInternalT s t request response m) where

77− notReadyUntil = lift . notReadyUntil

78− notReady = lift notReady

79−

8075instance NotReady t m => NotReady t (TriggerEventT t m) where

8176 notReadyUntil = lift . notReadyUntil

8277 notReady = lift notReady

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

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

1−{-# LANGUAGE DeriveFoldable #-}

2−{-# LANGUAGE DeriveFunctor #-}

3−{-# LANGUAGE DeriveTraversable #-}

4−{-# LANGUAGE FlexibleInstances #-}

5−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

7−{-# LANGUAGE TemplateHaskell #-}

8−{-# LANGUAGE TypeFamilies #-}

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

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

11−module Reflex.Patch.IntMap where

12−

13−import Control.Lens

14−import Data.IntMap.Strict (IntMap)

15−import qualified Data.IntMap.Strict as IntMap

16−import Data.Maybe

17−import Data.Semigroup

18−import Reflex.Patch.Class

19−

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

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

22−-- and @Nothing@ means delete.

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

24−

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

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

27−-- precedence.

28−instance Semigroup (PatchIntMap v) where

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

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

31− stimes = stimesIdempotentMonoid

32−

33−makeWrapped ''PatchIntMap

34−

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

36−instance Patch (PatchIntMap a) where

37− type PatchTarget (PatchIntMap a) = IntMap a

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

39− let removes = IntMap.filter isNothing p

40− adds = IntMap.mapMaybe id p

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

42−

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

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

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

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

47−

48−instance FunctorWithIndex Int PatchIntMap

49−instance FoldableWithIndex Int PatchIntMap

50−instance TraversableWithIndex Int PatchIntMap where

51− itraversed = _Wrapped . itraversed . traversed

52−

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

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

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

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

57−

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

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

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

61−

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

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

64−patchIntMapNewElementsMap :: PatchIntMap a -> IntMap a

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

66−

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

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

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

70−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+19−82

@@ -28,10 +28,8 @@ import Reflex.Class

2828import Reflex.Adjustable.Class

2929import Reflex.Host.Class

3030import Reflex.PerformEvent.Class

31−import Reflex.Requester.Base.Internal

31+import Reflex.Requester.Base

3232import Reflex.Requester.Class

33−import Reflex.EventWriter.Class

34−import Reflex.EventWriter.Base

3533

3634import Control.Lens

3735import Control.Monad.Exception

@@ -39,21 +37,13 @@ import Control.Monad.Identity

3937import Control.Monad.Primitive

4038import Control.Monad.Reader

4139import Control.Monad.Ref

40+import Data.Coerce

4241import Data.Dependent.Map (DMap)

4342import qualified Data.Dependent.Map as DMap

4443import Data.Dependent.Sum

45−import Data.Foldable

46−import Data.Functor.Compose

47−import Data.Functor.Misc

4844import Data.IntMap.Strict (IntMap)

4945import qualified Data.IntMap.Strict as IntMap

5046import qualified Data.Semigroup as S

51−import Data.Unique.Tag.Local

52−import Data.Sequence (Seq)

53−import Data.Tuple

54−import qualified Data.TagMap as TagMap

55−

56−import Debug.Trace

5747

5848-- | A function that fires events for the given 'EventTrigger's and then runs

5949-- any followup actions provided via 'PerformEvent'. The given 'ReadPhase'

@@ -78,7 +68,7 @@ instance (PrimMonad (HostFrame t), ReflexHost t) => PrimMonad (PerformEventT t m

7868 type PrimState (PerformEventT t m) = PrimState (HostFrame t)

7969 primitive = PerformEventT . lift . primitive

8070

81−instance (ReflexHost t, Ref m ~ Ref IO, PrimMonad (HostFrame t)) => PerformEvent t (PerformEventT t m) where

71+instance (ReflexHost t, Ref m ~ Ref IO) => PerformEvent t (PerformEventT t m) where

8272 type Performable (PerformEventT t m) = HostFrame t

8373 {-# INLINABLE performEvent_ #-}

8474 performEvent_ = PerformEventT . requesting_

@@ -86,60 +76,15 @@ instance (ReflexHost t, Ref m ~ Ref IO, PrimMonad (HostFrame t)) => PerformEvent

8676 performEvent = PerformEventT . requestingIdentity

8777

8878instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT t m) where

89− runWithReplace a0 a' = PerformEventT $ RequesterT $ do

90− env@(_, _ :: TagGen (PrimState (HostFrame t)) s) <- RequesterInternalT ask

91− let runA :: forall a. PerformEventT t m a -> HostFrame t (a, Event t (Seq (RequestEnvelope s (HostFrame t))))

92− runA (PerformEventT (RequesterT a)) = runEventWriterT $ runReaderT (unRequesterInternalT a) env

93− (result0, requests0) <- lift $ runA a0

94− newA <- requestingIdentity $ traceEventWith (const "running new widget") $ runA <$> a'

95− requests <- switchHoldPromptOnly requests0 $ traceEventWith (const "updating runWithReplace") $ fmapCheap snd newA

96− --TODO: promptly *prevent* events, then sign up the new ones; this is a serious breaking change to PerformEvent

97− RequesterInternalT $ tellEvent requests

98− pure (result0, fmapCheap fst newA)

99− traverseIntMapWithKeyWithAdjust f a0 a' = PerformEventT $ RequesterT $ do

100− env@(_, _ :: TagGen (PrimState (HostFrame t)) s) <- RequesterInternalT ask

101− let runA :: forall a. PerformEventT t m a -> HostFrame t (a, Event t (Seq (RequestEnvelope s (HostFrame t))))

102− runA (PerformEventT (RequesterT a)) = runEventWriterT $ runReaderT (unRequesterInternalT a) env

103− children' <- requestingIdentity $ itraverse (\k -> runA . f k) <$> a'

104− children0 <- lift $ itraverse (\k -> runA . f k) a0

105− let results0 = fmap fst children0

106− requests0 = fmap snd children0

107− results' = fmap fst <$> children'

108− requests' = fmap snd `fmapCheap` children'

109− requests <- switchHoldPromptOnlyIncremental mergeIntIncremental coincidencePatchIntMap requests0 $ requests'

110− --TODO: promptly *prevent* events, then sign up the new ones; this is a serious breaking change to PerformEvent

111− RequesterInternalT $ tellEvent $ fforMaybeCheap requests $ \m -> if null m then Nothing else Just $ fold m

112− pure (results0, results')

113− traverseDMapWithKeyWithAdjust (f :: forall a. k a -> v a -> PerformEventT t m (v' a)) (a0 :: DMap k v) a' = PerformEventT $ RequesterT $ do

114− env@(_, _ :: TagGen (PrimState (HostFrame t)) s) <- RequesterInternalT ask

115− let runA :: forall a. k a -> v a -> HostFrame t (Compose ((,) (Event t (Seq (RequestEnvelope s (HostFrame t))))) v' a)

116− runA k v = fmap (Compose . swap) $ runEventWriterT $ runReaderT (unRequesterInternalT a) env

117− where (PerformEventT (RequesterT a)) = f k v

118− children' <- requestingIdentity $ traversePatchDMapWithKey runA <$> a'

119− children0 <- lift $ DMap.traverseWithKey runA a0

120− let results0 = DMap.map (snd . getCompose) children0

121− requests0 = weakenDMapWith (fst . getCompose) children0

122− results' = mapPatchDMap (snd . getCompose) <$> children'

123− requests' = weakenPatchDMapWith (fst . getCompose) `fmapCheap` children'

124− requests <- switchHoldPromptOnlyIncremental mergeMapIncremental coincidencePatchMap requests0 $ requests'

125− --TODO: promptly *prevent* events, then sign up the new ones; this is a serious breaking change to PerformEvent

126− RequesterInternalT $ tellEvent $ fforMaybeCheap requests $ \m -> if null m then Nothing else Just $ fold m

127− pure (results0, results')

128− traverseDMapWithKeyWithAdjustWithMove (f :: forall a. k a -> v a -> PerformEventT t m (v' a)) (a0 :: DMap k v) a' = PerformEventT $ RequesterT $ do

129− env@(_, _ :: TagGen (PrimState (HostFrame t)) s) <- RequesterInternalT ask

130− let runA :: forall a. k a -> v a -> HostFrame t (Compose ((,) (Event t (Seq (RequestEnvelope s (HostFrame t))))) v' a)

131− runA k v = fmap (Compose . swap) $ runEventWriterT $ runReaderT (unRequesterInternalT a) env

132− where (PerformEventT (RequesterT a)) = f k v

133− children' <- requestingIdentity $ traversePatchDMapWithMoveWithKey runA <$> a'

134− children0 <- lift $ DMap.traverseWithKey runA a0

135− let results0 = DMap.map (snd . getCompose) children0

136− requests0 = weakenDMapWith (fst . getCompose) children0

137− results' = mapPatchDMapWithMove (snd . getCompose) <$> children'

138− requests' = weakenPatchDMapWithMoveWith (fst . getCompose) `fmapCheap` children'

139− requests <- switchHoldPromptOnlyIncremental mergeMapIncrementalWithMove coincidencePatchMapWithMove requests0 $ requests'

140− --TODO: promptly *prevent* events, then sign up the new ones; this is a serious breaking change to PerformEvent

141− RequesterInternalT $ tellEvent $ fforMaybeCheap requests $ \m -> if null m then Nothing else Just $ fold m

142− pure (results0, results')

79+ runWithReplace outerA0 outerA' = PerformEventT $ runWithReplaceRequesterTWith f (coerce outerA0) (coerceEvent outerA')

80+ where f :: HostFrame t a -> Event t (HostFrame t b) -> RequesterT t (HostFrame t) Identity (HostFrame t) (a, Event t b)

81+ f a0 a' = do

82+ result0 <- lift a0

83+ result' <- requestingIdentity a'

84+ return (result0, result')

85+ traverseIntMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseIntMapWithKeyWithAdjustRequesterTWith (defaultAdjustIntBase traverseIntMapPatchWithKey) patchIntMapNewElementsMap mergeIntIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')

86+ traverseDMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithKey) mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')

87+ traverseDMapWithKeyWithAdjustWithMove f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithMoveWithKey) mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')

14388

14489defaultAdjustBase :: forall t v v2 k' p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t)

14590 => ((forall a. k' a -> v a -> HostFrame t (v2 a)) -> p k' v -> HostFrame t (p k' v2))

@@ -179,14 +124,13 @@ hostPerformEventT :: forall t m a.

179124 , MonadReflexHost t m

180125 , MonadRef m

181126 , Ref m ~ Ref IO

182− , PrimMonad (HostFrame t)

183127 )

184128 => PerformEventT t m a

185129 -> m (a, FireCommand t m)

186130hostPerformEventT a = do

187131 (response, responseTrigger) <- newEventWithTriggerRef

188− (result, eventToPerform) <- runHostFrame $ runRequesterT (unPerformEventT a) $ traceEventWith (const "response") response

189− eventToPerformHandle <- subscribeEvent $ traceEventWith (const "eventToPerform") eventToPerform

132+ (result, eventToPerform) <- runHostFrame $ runRequesterT (unPerformEventT a) response

133+ eventToPerformHandle <- subscribeEvent eventToPerform

190134 return $ (,) result $ FireCommand $ \triggers (readPhase :: ReadPhase m a') -> do

191135 let go :: [DSum (EventTrigger t) Identity] -> m [a']

192136 go ts = do

@@ -197,20 +141,11 @@ hostPerformEventT a = do

197141 case mToPerform of

198142 Nothing -> return [result']

199143 Just toPerform -> do

200− traceM $ "toPerform: " <> case toPerform of

201− RequestData _ reqs -> show (length reqs)

202− responses <- runHostFrame $ traverseRequesterData (Identity <$>) toPerform

203− let responseLength = case responses of

204− ResponseData _ m -> TagMap.size m

205− traceM $ "responses: " <> show responseLength

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

206145 mrt <- readRef responseTrigger

207146 let followupEventTriggers = case mrt of

208− Just rt -> do

209− traceM "a"

210− [rt :=> Identity responses]

211− Nothing -> do

212− traceM "b"

213− []

147+ Just rt -> [rt :=> Identity responses]

148+ Nothing -> []

214149 (result':) <$> go followupEventTriggers

215150 go triggers

216151

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

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

230165 {-# INLINABLE headE #-}

231166 headE = PerformEventT . lift . headE

167+ {-# INLINABLE now #-}

168+ now = PerformEventT . lift $ now

232169

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

234171 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+59−5

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

2626import Control.Monad.Reader

2727import Control.Monad.Ref

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

29+import Data.Bifunctor

2930import Data.Coerce

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

31+import Data.Dependent.Map (DMap)

32+import Data.GADT.Compare (GCompare)

3133import Data.FastMutableIntMap

3234import Data.IORef

3335import Data.List

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

4244import GHC.Foreign

4345import GHC.IO.Encoding

4446import GHC.Stack

47+import Reflex.Adjustable.Class

48+import Reflex.BehaviorWriter.Class

4549import Reflex.Class

50+import Reflex.DynamicWriter.Class

51+import Reflex.EventWriter.Class

4652import Reflex.Host.Class

53+import Reflex.NotReady.Class

4754import Reflex.PerformEvent.Class

55+import Reflex.PostBuild.Class

56+import Reflex.Query.Class

57+import Reflex.Requester.Class

58+import Reflex.TriggerEvent.Class

4859

4960import System.IO.Unsafe

50−import Unsafe.Coerce

5161

5262data ProfiledTimeline t

5363

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

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

138148 pull = Behavior_Profiled . pull . coerce

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

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

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

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

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

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

@@ -147,8 +157,8 @@ instance Reflex t => Reflex (ProfiledTimeline t) where

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

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

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

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

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

152162 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i

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

154164 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i

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

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

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

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

187+ now = ProfiledM $ Event_Profiled <$> now

177188

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

179190 sample (Behavior_Profiled b) = ProfiledM $ sample b

180191

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+

181202instance MonadTrans ProfiledM where

182203 lift = ProfiledM

183204

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

189210 performEvent_ = lift . performEvent_ . coerce

190211 performEvent = lift . fmap coerce . performEvent . coerce

191212

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+

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

193247 type Ref (ProfiledM m) = Ref m

194248 newRef = lift . newRef

src/Reflex/Pure.hs+6−1

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

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

210211 Just x -> fromMaybe lastValue $ apply x lastValue

211212

212213 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+599−14

@@ -1,22 +1,607 @@

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

22-- 'Requester'.

3+{-# LANGUAGE AllowAmbiguousTypes #-}

4+{-# LANGUAGE ApplicativeDo #-}

5+{-# LANGUAGE CPP #-}

6+{-# LANGUAGE EmptyDataDecls #-}

7+{-# LANGUAGE ExistentialQuantification #-}

8+{-# LANGUAGE FlexibleInstances #-}

9+{-# LANGUAGE GADTs #-}

10+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

11+{-# LANGUAGE MultiParamTypeClasses #-}

12+{-# LANGUAGE Rank2Types #-}

13+{-# LANGUAGE RecursiveDo #-}

14+{-# LANGUAGE ScopedTypeVariables #-}

15+{-# LANGUAGE StandaloneDeriving #-}

16+{-# LANGUAGE TypeFamilies #-}

17+{-# LANGUAGE TypeOperators #-}

18+{-# LANGUAGE UndecidableInstances #-}

19+#ifdef USE_REFLEX_OPTIMIZER

20+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

21+#endif

322module Reflex.Requester.Base

423 ( RequesterT (..)

5− , RequestData (..)

6− , ResponseData (..)

7− , RequestEnvelope (..)

824 , runRequesterT

9−-- , withRequesterT

10−-- , RequesterData

11−-- , RequesterDataKey

25+ , withRequesterT

26+ , runWithReplaceRequesterTWith

27+ , traverseIntMapWithKeyWithAdjustRequesterTWith

28+ , traverseDMapWithKeyWithAdjustRequesterTWith

29+ , RequesterData

30+ , RequesterDataKey

1231 , traverseRequesterData

13−-- , forRequesterData

14−-- , requesterDataToList

15−-- , singletonRequesterData

16−-- , matchResponsesWithRequests

17−-- , multiEntry

18−-- , unMultiEntry

19−-- , requesting'

32+ , forRequesterData

33+ , requesterDataToList

34+ , singletonRequesterData

35+ , matchResponsesWithRequests

36+ , matchResponseMapWithRequests

37+ , multiEntry

38+ , unMultiEntry

39+ , requesting'

2040 ) where

2141

22−import Reflex.Requester.Base.Internal

42+import Reflex.Class

43+import Reflex.Adjustable.Class

44+import Reflex.Dynamic

45+import Reflex.Host.Class

46+import Reflex.PerformEvent.Class

47+import Reflex.PostBuild.Class

48+import Reflex.Requester.Class

49+import Reflex.TriggerEvent.Class

50+

51+import Control.Applicative (liftA2)

52+import Control.Monad.Exception

53+import Control.Monad.Identity

54+import Control.Monad.Morph

55+import Control.Monad.Primitive

56+import Control.Monad.Reader

57+import Control.Monad.Ref

58+import Control.Monad.State.Strict

59+import Data.Bits

60+import Data.Coerce

61+import Data.Constraint

62+import Data.Dependent.Map (DMap)

63+import qualified Data.Dependent.Map as DMap

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

65+import Data.Functor.Compose

66+import Data.Functor.Misc

67+import Data.IntMap.Strict (IntMap)

68+import qualified Data.IntMap.Strict as IntMap

69+import Data.Map (Map)

70+import qualified Data.Map as Map

71+import Data.Monoid ((<>))

72+import Data.Proxy

73+import qualified Data.Semigroup as S

74+import Data.Some (Some(Some))

75+import Data.Type.Equality

76+import Data.Unique.Tag

77+

78+import GHC.Exts (Any)

79+import Unsafe.Coerce

80+

81+--TODO: Make this module type-safe

82+

83+newtype TagMap (f :: * -> *) = TagMap (IntMap Any)

84+

85+newtype RequesterData f = RequesterData (TagMap (Entry f))

86+

87+emptyRequesterData :: RequesterData f

88+emptyRequesterData = RequesterData $ TagMap IntMap.empty

89+

90+data RequesterDataKey a where

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

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

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

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

95+

96+singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f

97+singletonRequesterData rdk v = case rdk of

98+ RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v

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

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

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

102+ , _multi2Contents_dict = Dict

103+ }

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

105+

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

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

108+

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

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

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

112+ where

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

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

115+ MyTagType_Single -> a

116+ MyTagType_Multi -> IntMap.unionWith mergeRequesterData a b

117+ MyTagType_Multi2 -> case _multi2Contents_dict a of

118+ Dict -> Multi2Contents

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

120+ , _multi2Contents_dict = Dict

121+ }

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

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

124+ g' f rawKey a b =

125+ let k = MyTag rawKey :: MyTag a

126+ fromAny :: Any -> Entry f a

127+ fromAny = unsafeCoerce

128+ toAny :: Entry f a -> Any

129+ toAny = unsafeCoerce

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

131+

132+requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]

133+requesterDataToList (RequesterData m) = do

134+ k :=> Entry e <- tagMapToList m

135+ case myKeyType k of

136+ MyTagType_Single -> return $ RequesterDataKey_Single k :=> e

137+ MyTagType_Multi -> do

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

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

140+ return $ RequesterDataKey_Multi 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'''

147+ MyTagType_Multi3 -> do

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

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

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

151+ return $ RequesterDataKey_Multi3 k k' k'' k''' :=> e'''

152+

153+singletonTagMap :: forall f a. MyTag a -> f a -> TagMap f

154+singletonTagMap (MyTag k) v = TagMap $ IntMap.singleton k $ (unsafeCoerce :: f a -> Any) v

155+

156+tagMapToList :: forall f. TagMap f -> [DSum MyTag f]

157+tagMapToList (TagMap m) = f <$> IntMap.toList m

158+ where f :: (Int, Any) -> DSum MyTag f

159+ f (k, v) = MyTag k :=> (unsafeCoerce :: Any -> f a) v

160+

161+traverseTagMapWithKey :: forall t f g. Applicative t => (forall a. MyTag a -> f a -> t (g a)) -> TagMap f -> t (TagMap g)

162+traverseTagMapWithKey f (TagMap m) = TagMap <$> IntMap.traverseWithKey g m

163+ where

164+ g :: Int -> Any -> t Any

165+ g k v = (unsafeCoerce :: g a -> Any) <$> f (MyTag k) ((unsafeCoerce :: Any -> f a) v)

166+

167+-- | Runs in reverse to accommodate for the fact that we accumulate it in reverse

168+traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequesterData request -> m (RequesterData response)

169+traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWithKey go m --TODO: reverse this, since our tags are in reverse order

170+ where go :: forall x. MyTag x -> Entry request x -> m (Entry response x)

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

172+ MyTagType_Single -> f request

173+ MyTagType_Multi -> traverse (traverseRequesterData f) request

174+ MyTagType_Multi2 -> case request of

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

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

177+ pure $ Multi2Contents

178+ { _multi2Contents_values = v

179+ , _multi2Contents_dict = Dict

180+ }

181+ MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request

182+

183+-- | 'traverseRequesterData' with its arguments flipped

184+forRequesterData :: forall request response m. Applicative m => RequesterData request -> (forall a. request a -> m (response a)) -> m (RequesterData response)

185+forRequesterData r f = traverseRequesterData f r

186+

187+data MyTagType :: * -> * where

188+ MyTagType_Single :: MyTagType (Single a)

189+ MyTagType_Multi :: MyTagType Multi

190+ MyTagType_Multi2 :: MyTagType (Multi2 k)

191+ MyTagType_Multi3 :: MyTagType Multi3

192+

193+myKeyType :: MyTag x -> MyTagType x

194+myKeyType (MyTag k) = case k .&. 0x3 of

195+ 0x0 -> unsafeCoerce MyTagType_Single

196+ 0x1 -> unsafeCoerce MyTagType_Multi

197+ 0x2 -> unsafeCoerce MyTagType_Multi2

198+ 0x3 -> unsafeCoerce MyTagType_Multi3

199+ t -> error $ "Reflex.Requester.Base.myKeyType: no such key type" <> show t

200+

201+data Single a

202+data Multi

203+data Multi2 (k :: * -> *)

204+data Multi3

205+

206+class MyTagTypeOffset x where

207+ myTagTypeOffset :: proxy x -> Int

208+

209+instance MyTagTypeOffset (Single a) where

210+ myTagTypeOffset _ = 0x0

211+

212+instance MyTagTypeOffset Multi where

213+ myTagTypeOffset _ = 0x1

214+

215+instance MyTagTypeOffset (Multi2 k) where

216+ myTagTypeOffset _ = 0x2

217+

218+instance MyTagTypeOffset Multi3 where

219+ myTagTypeOffset _ = 0x3

220+

221+type family EntryContents request a where

222+ EntryContents request (Single a) = request a

223+ EntryContents request Multi = IntMap (RequesterData request)

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

225+ EntryContents request Multi3 = IntMap (IntMap (RequesterData request))

226+

227+data Multi2Contents k request = Multi2Contents

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

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

230+ }

231+

232+newtype Entry request x = Entry { unEntry :: EntryContents request x }

233+

234+{-# INLINE singleEntry #-}

235+singleEntry :: f a -> Entry f (Single a)

236+singleEntry = Entry

237+

238+{-# INLINE multiEntry #-}

239+multiEntry :: IntMap (RequesterData f) -> Entry f Multi

240+multiEntry = Entry

241+

242+{-# INLINE unMultiEntry #-}

243+unMultiEntry :: Entry f Multi -> IntMap (RequesterData f)

244+unMultiEntry = unEntry

245+

246+-- | We use a hack here to pretend we have x ~ request a; we don't want to use a GADT, because GADTs (even with zero-size existential contexts) can't be newtypes

247+-- WARNING: This type should never be exposed. In particular, this is extremely unsound if a MyTag from one run of runRequesterT is ever compared against a MyTag from another

248+newtype MyTag x = MyTag Int deriving (Show, Eq, Ord, Enum)

249+

250+newtype MyTagWrap (f :: * -> *) x = MyTagWrap Int deriving (Show, Eq, Ord, Enum)

251+

252+{-# INLINE castMyTagWrap #-}

253+castMyTagWrap :: MyTagWrap f (Entry f x) -> MyTagWrap g (Entry g x)

254+castMyTagWrap = coerce

255+

256+instance GEq MyTag where

257+ (MyTag a) `geq` (MyTag b) =

258+ if a == b

259+ then Just $ unsafeCoerce Refl

260+ else Nothing

261+

262+instance GCompare MyTag where

263+ (MyTag a) `gcompare` (MyTag b) =

264+ case a `compare` b of

265+ LT -> GLT

266+ EQ -> unsafeCoerce GEQ

267+ GT -> GGT

268+

269+instance GEq (MyTagWrap f) where

270+ (MyTagWrap a) `geq` (MyTagWrap b) =

271+ if a == b

272+ then Just $ unsafeCoerce Refl

273+ else Nothing

274+

275+instance GCompare (MyTagWrap f) where

276+ (MyTagWrap a) `gcompare` (MyTagWrap b) =

277+ case a `compare` b of

278+ LT -> GLT

279+ EQ -> unsafeCoerce GEQ

280+ GT -> GGT

281+

282+data RequesterState t (request :: * -> *) = RequesterState

283+ { _requesterState_nextMyTag :: {-# UNPACK #-} !Int -- Starts at -4 and goes down by 4 each time, to accommodate two 'type' bits at the bottom

284+ , _requesterState_requests :: ![(Int, Event t Any)]

285+ }

286+

287+-- | A basic implementation of 'Requester'.

288+newtype RequesterT t request (response :: * -> *) m a = RequesterT { unRequesterT :: StateT (RequesterState t request) (ReaderT (EventSelectorInt t Any) m) a }

289+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException

290+-- MonadAsyncException can't be derived on ghc-8.0.1; we use base-4.9.1 as a proxy for ghc-8.0.2

291+#if MIN_VERSION_base(4,9,1)

292+ , MonadAsyncException

293+#endif

294+ )

295+

296+deriving instance MonadSample t m => MonadSample t (RequesterT t request response m)

297+deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)

298+deriving instance PostBuild t m => PostBuild t (RequesterT t request response m)

299+deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)

300+

301+instance PrimMonad m => PrimMonad (RequesterT t request response m) where

302+ type PrimState (RequesterT t request response m) = PrimState m

303+ primitive = lift . primitive

304+

305+-- TODO: Monoid and Semigroup can likely be derived once StateT has them.

306+instance (Monoid a, Monad m) => Monoid (RequesterT t request response m a) where

307+ mempty = pure mempty

308+ mappend = liftA2 mappend

309+

310+instance (S.Semigroup a, Monad m) => S.Semigroup (RequesterT t request response m a) where

311+ (<>) = liftA2 (S.<>)

312+

313+

314+-- | Run a 'RequesterT' action. The resulting 'Event' will fire whenever

315+-- requests are made, and responses should be provided in the input 'Event'.

316+-- The 'Tag' keys will be used to return the responses to the same place the

317+-- requests were issued.

318+runRequesterT :: (Reflex t, Monad m)

319+ => RequesterT t request response m a

320+ -> Event t (RequesterData response) --TODO: This DMap will be in reverse order, so we need to make sure the caller traverses it in reverse

321+ -> m (a, Event t (RequesterData request)) --TODO: we need to hide these 'MyTag's here, because they're unsafe to mix in the wild

322+runRequesterT (RequesterT a) responses = do

323+ (result, s) <- runReaderT (runStateT a $ RequesterState (-4) []) $ fanInt $

324+ coerceEvent responses

325+ return (result, fmapCheap (RequesterData . TagMap) $ mergeInt $ IntMap.fromDistinctAscList $ _requesterState_requests s)

326+

327+-- | Map a function over the request and response of a 'RequesterT'

328+withRequesterT

329+ :: (Reflex t, MonadFix m)

330+ => (forall x. req x -> req' x) -- ^ The function to map over the request

331+ -> (forall x. rsp' x -> rsp x) -- ^ The function to map over the response

332+ -> RequesterT t req rsp m a -- ^ The internal 'RequesterT' whose input and output will be transformed

333+ -> RequesterT t req' rsp' m a -- ^ The resulting 'RequesterT'

334+withRequesterT freq frsp child = do

335+ rec let rsp = fmap (runIdentity . traverseRequesterData (Identity . frsp)) rsp'

336+ (a, req) <- lift $ runRequesterT child rsp

337+ rsp' <- fmap (flip selectInt 0 . fanInt . fmapCheap unMultiEntry) $ requesting' $

338+ fmapCheap (multiEntry . IntMap.singleton 0) $ fmap (runIdentity . traverseRequesterData (Identity . freq)) req

339+ return a

340+

341+instance (Reflex t, Monad m) => Requester t (RequesterT t request response m) where

342+ type Request (RequesterT t request response m) = request

343+ type Response (RequesterT t request response m) = response

344+ requesting = fmap coerceEvent . responseFromTag . castMyTagWrap <=< tagRequest . (coerceEvent :: Event t (request a) -> Event t (Entry request (Single a)))

345+ requesting_ = void . tagRequest . fmapCheap singleEntry

346+

347+{-# INLINE tagRequest #-}

348+tagRequest :: forall m x t request response. (Monad m, MyTagTypeOffset x) => Event t (Entry request x) -> RequesterT t request response m (MyTagWrap request (Entry request x))

349+tagRequest req = do

350+ old <- RequesterT get

351+ let n = _requesterState_nextMyTag old .|. myTagTypeOffset (Proxy :: Proxy x)

352+ t = MyTagWrap n

353+ RequesterT $ put $ RequesterState

354+ { _requesterState_nextMyTag = _requesterState_nextMyTag old - 0x4

355+ , _requesterState_requests = (n, (unsafeCoerce :: Event t (Entry request x) -> Event t Any) req) : _requesterState_requests old

356+ }

357+ return t

358+

359+{-# INLINE responseFromTag #-}

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

361+responseFromTag (MyTagWrap t) = do

362+ responses :: EventSelectorInt t Any <- RequesterT ask

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

364+

365+instance MonadTrans (RequesterT t request response) where

366+ lift = RequesterT . lift . lift

367+

368+instance MFunctor (RequesterT t request response) where

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

370+

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

372+ type Performable (RequesterT t request response m) = Performable m

373+ performEvent_ = lift . performEvent_

374+ performEvent = lift . performEvent

375+

376+instance MonadRef m => MonadRef (RequesterT t request response m) where

377+ type Ref (RequesterT t request response m) = Ref m

378+ newRef = lift . newRef

379+ readRef = lift . readRef

380+ writeRef r = lift . writeRef r

381+

382+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where

383+ newEventWithTrigger = lift . newEventWithTrigger

384+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

385+

386+instance MonadReader r m => MonadReader r (RequesterT t request response m) where

387+ ask = lift ask

388+ local f (RequesterT a) = RequesterT $ mapStateT (mapReaderT $ local f) a

389+ reader = lift . reader

390+

391+instance (Reflex t, Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (RequesterT t request response m) where

392+ runWithReplace = runWithReplaceRequesterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'

393+ traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElementsMap mergeIntIncremental

394+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

395+ traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental

396+ traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove

397+

398+requesting' :: (MyTagTypeOffset x, Monad m) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x))

399+requesting' = responseFromTag . castMyTagWrap <=< tagRequest

400+

401+{-# INLINABLE runWithReplaceRequesterTWith #-}

402+runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m

403+ , MonadFix m

404+ )

405+ => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))

406+ -> RequesterT t request response m a

407+ -> Event t (RequesterT t request response m b)

408+ -> RequesterT t request response m (a, Event t b)

409+runWithReplaceRequesterTWith f a0 a' = do

410+ rec na' <- numberOccurrencesFrom 1 a'

411+ responses <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here

412+ let responses' = fanInt responses

413+ ((result0, requests0), v') <- f (runRequesterT a0 (selectInt responses' 0)) $ fmapCheap (\(n, a) -> fmap ((,) n) $ runRequesterT a $ selectInt responses' n) na'

414+ requests <- holdDyn (fmapCheap (IntMap.singleton 0) requests0) $ fmapCheap (\(n, (_, reqs)) -> fmapCheap (IntMap.singleton n) reqs) v'

415+ return (result0, fmapCheap (fst . snd) v')

416+

417+{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}

418+traverseIntMapWithKeyWithAdjustRequesterTWith :: forall t request response m v v' p.

419+ ( Reflex t

420+ , MonadHold t m

421+ , PatchTarget (p (Event t (IntMap (RequesterData request)))) ~ IntMap (Event t (IntMap (RequesterData request)))

422+ , Patch (p (Event t (IntMap (RequesterData request))))

423+ , Functor p

424+ , MonadFix m

425+ )

426+ => ( (IntMap.Key -> (IntMap.Key, v) -> m (Event t (IntMap (RequesterData request)), v'))

427+ -> IntMap (IntMap.Key, v)

428+ -> Event t (p (IntMap.Key, v))

429+ -> RequesterT t request response m (IntMap (Event t (IntMap (RequesterData request)), v'), Event t (p (Event t (IntMap (RequesterData request)), v')))

430+ )

431+ -> (p (Event t (IntMap (RequesterData request))) -> IntMap (Event t (IntMap (RequesterData request))))

432+ -> (Incremental t (p (Event t (IntMap (RequesterData request)))) -> Event t (IntMap (IntMap (RequesterData request))))

433+ -> (IntMap.Key -> v -> RequesterT t request response m v')

434+ -> IntMap v

435+ -> Event t (p v)

436+ -> RequesterT t request response m (IntMap v', Event t (p v'))

437+traverseIntMapWithKeyWithAdjustRequesterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do

438+ rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here

439+ let responses :: EventSelectorInt t (IntMap (RequesterData response))

440+ responses = fanInt $ fmapCheap unpack response

441+ unpack :: Entry response Multi3 -> IntMap (IntMap (RequesterData response))

442+ unpack = unEntry

443+ pack :: IntMap (IntMap (RequesterData request)) -> Entry request Multi3

444+ pack = Entry

445+ f' :: IntMap.Key -> (Int, v) -> m (Event t (IntMap (RequesterData request)), v')

446+ f' k (n, v) = do

447+ (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ selectInt responses k --TODO: Instead of doing mapMaybeCheap, can we share a fanInt across all instances of a given key, or at least the ones that are adjacent in time?

448+ return (fmapCheap (IntMap.singleton n) myRequests, result)

449+ ndm' <- numberOccurrencesFrom 1 dm'

450+ (children0, children') <- base f' (fmap ((,) 0) dm0) $ fmap (\(n, dm) -> fmap ((,) n) dm) ndm' --TODO: Avoid this somehow, probably by adding some sort of per-cohort information passing to Adjustable

451+ let result0 = fmap snd children0

452+ result' = fforCheap children' $ fmap snd

453+ requests0 :: IntMap (Event t (IntMap (RequesterData request)))

454+ requests0 = fmap fst children0

455+ requests' :: Event t (p (Event t (IntMap (RequesterData request))))

456+ requests' = fforCheap children' $ fmap fst

457+ promptRequests :: Event t (IntMap (IntMap (RequesterData request)))

458+ promptRequests = coincidence $ fmapCheap (mergeInt . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'

459+ requests <- holdIncremental requests0 requests'

460+ return (result0, result')

461+

462+{-# INLINE traverseDMapWithKeyWithAdjustRequesterTWith #-}

463+traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v' p p'.

464+ ( GCompare k

465+ , Reflex t

466+ , MonadHold t m

467+ , PatchTarget (p' (Some k) (Event t (IntMap (RequesterData request)))) ~ Map (Some k) (Event t (IntMap (RequesterData request)))

468+ , Patch (p' (Some k) (Event t (IntMap (RequesterData request))))

469+ , MonadFix m

470+ )

471+ => (forall k' v1 v2. GCompare k'

472+ => (forall a. k' a -> v1 a -> m (v2 a))

473+ -> DMap k' v1

474+ -> Event t (p k' v1)

475+ -> RequesterT t request response m (DMap k' v2, Event t (p k' v2))

476+ )

477+ -> (forall v1 v2. (forall a. v1 a -> v2 a) -> p k v1 -> p k v2)

478+ -> (forall v1 v2. (forall a. v1 a -> v2) -> p k v1 -> p' (Some k) v2)

479+ -> (forall v2. p' (Some k) v2 -> Map (Some k) v2)

480+ -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a))

481+ -> (forall a. k a -> v a -> RequesterT t request response m (v' a))

482+ -> DMap k v

483+ -> Event t (p k v)

484+ -> RequesterT t request response m (DMap k v', Event t (p k v'))

485+traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do

486+ rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here

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

488+ responses = fanMap $ fmapCheap unpack response

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

490+ unpack = _multi2Contents_values . unEntry

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

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

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

494+ f' k (Compose (n, v)) = do

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

496+ return $ Compose (fmapCheap (IntMap.singleton n) myRequests, result)

497+ ndm' <- numberOccurrencesFrom 1 dm'

498+ (children0, children') <- base f' (DMap.map (\v -> Compose (0, v)) dm0) $ fmap (\(n, dm) -> mapPatch (\v -> Compose (n, v)) dm) ndm'

499+ let result0 = DMap.map (snd . getCompose) children0

500+ result' = fforCheap children' $ mapPatch $ snd . getCompose

501+ requests0 :: Map (Some k) (Event t (IntMap (RequesterData request)))

502+ requests0 = weakenDMapWith (fst . getCompose) children0

503+ requests' :: Event t (p' (Some k) (Event t (IntMap (RequesterData request))))

504+ requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose

505+ promptRequests :: Event t (Map (Some k) (IntMap (RequesterData request)))

506+ promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'

507+ requests <- holdIncremental requests0 requests'

508+ return (result0, result')

509+

510+data Decoder rawResponse response =

511+ forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)

512+

513+matchResponsesWithRequests

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

515+ ( MonadFix m

516+ , MonadHold t m

517+ , Reflex t

518+ )

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

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

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

522+ -> Event t (RequesterData request)

523+ -- ^ The outgoing requests

524+ -> Event t (Int, rawResponse)

525+ -- ^ The incoming responses, tagged by an identifying key

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

527+ , Event t (RequesterData response)

528+ )

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

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

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

532+

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

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

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

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

557+ holdIncremental mempty $ leftmost

558+ [ fmap (\(_, outstanding, _) -> outstanding) outgoing

559+ , snd <$> incoming

560+ ]

561+ let outgoing = processOutgoing nextId send

562+ incoming = processIncoming waitingFor recv

563+ return (fmap (\(_, _, rawReqs) -> rawReqs) outgoing, fst <$> incoming)

564+ where

565+ -- Tags each outgoing request with an identifying integer key

566+ -- and returns the next available key, a map of response decoders

567+ -- for requests for which there are outstanding responses, and the

568+ -- raw requests to be sent out.

569+ processOutgoing

570+ :: Behavior t Int

571+ -- The next available key

572+ -> Event t (RequesterData request)

573+ -- The outgoing request

574+ -> Event t ( Int

575+ , PatchMap Int (Decoder rawResponse response)

576+ , Map Int rawRequest )

577+ -- The new next-available-key, a map of requests expecting responses, and the tagged raw requests

578+ processOutgoing nextId out = flip pushAlways out $ \dm -> do

579+ oldNextId <- sample nextId

580+ let (result, newNextId) = flip runState oldNextId $ forM (requesterDataToList dm) $ \(k :=> v) -> do

581+ n <- get

582+ put $ succ n

583+ let (rawReq, rspF) = f v

584+ return (n, rawReq, Decoder k rspF)

585+ patchWaitingFor = PatchMap $ Map.fromList $

586+ (\(n, _, dec) -> (n, Just dec)) <$> result

587+ toSend = Map.fromList $ (\(n, rawReq, _) -> (n, rawReq)) <$> result

588+ return (newNextId, patchWaitingFor, toSend)

589+ -- Looks up the each incoming raw response in a map of response

590+ -- decoders and returns the decoded response and a patch that can

591+ -- be used to clear the ID of the consumed response out of the queue

592+ -- of expected responses.

593+ processIncoming

594+ :: Incremental t (PatchMap Int (Decoder rawResponse response))

595+ -- A map of outstanding expected responses

596+ -> Event t (Map Int rawResponse)

597+ -- A incoming response paired with its identifying key

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

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

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

601+ wf <- sample $ currentIncremental waitingFor

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/Requester/Base/Internal.hsdeleted−703

@@ -1,703 +0,0 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE CPP #-}

3−{-# LANGUAGE EmptyDataDecls #-}

4−{-# LANGUAGE ExistentialQuantification #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE GADTs #-}

7−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8−{-# LANGUAGE MultiParamTypeClasses #-}

9−{-# LANGUAGE Rank2Types #-}

10−{-# LANGUAGE RecursiveDo #-}

11−{-# LANGUAGE ScopedTypeVariables #-}

12−{-# LANGUAGE StandaloneDeriving #-}

13−{-# LANGUAGE TypeFamilies #-}

14−{-# LANGUAGE TypeOperators #-}

15−{-# LANGUAGE UndecidableInstances #-}

16−{-# LANGUAGE InstanceSigs #-}

17−#ifdef USE_REFLEX_OPTIMIZER

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

19−#endif

20−module Reflex.Requester.Base.Internal where

21−

22−import Reflex.Class

23−import Reflex.Adjustable.Class

24−import Reflex.Dynamic

25−import Reflex.Host.Class

26−import Reflex.PerformEvent.Class

27−import Reflex.PostBuild.Class

28−import Reflex.Requester.Class

29−import Reflex.TriggerEvent.Class

30−import Reflex.EventWriter.Base

31−import Reflex.EventWriter.Class

32−

33−import Control.Applicative (liftA2)

34−import Control.Monad.Exception

35−import Control.Monad.Identity

36−import Control.Monad.Primitive

37−import Control.Monad.Reader

38−import Control.Monad.Ref

39−import Control.Monad.State.Strict

40−import Data.Bits

41−import Data.Coerce

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

43−import qualified Data.Dependent.Map as DMap

44−import Data.Functor.Compose

45−import Data.Functor.Misc

46−import Data.IntMap.Strict (IntMap)

47−import qualified Data.IntMap.Strict as IntMap

48−import Data.Map (Map)

49−import qualified Data.Map as Map

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

51−import Data.Proxy

52−import qualified Data.Semigroup as S

53−import Data.Some (Some(Some))

54−import Data.Type.Equality

55−import Data.Sequence (Seq)

56−import qualified Data.Sequence as Seq

57−import Data.TagMap (TagMap)

58−import qualified Data.TagMap as TagMap

59−import Reflex.FanTag

60−import Data.Unique.Tag.Local

61−import qualified Data.Unique.Tag as Global

62−import Data.GADT.Compare

63−import Data.Witherable

64−import Data.Foldable

65−

66−import Debug.Trace

67−

68−--TODO: The use of Seq in this module could probably be replaced with something

69−--even cheaper. We do need O(1) append, but we don't need associativity until

70−--the very end, when we're smashing everything together. This could be

71−--implemented as a binary tree whose representation isn't associative, but which

72−--doesn't allow any external party to observe the lack of associativity.

73−

74−data RequestData ps request = forall s. RequestData !(TagGen ps s) !(Seq (RequestEnvelope s request))

75−data ResponseData ps response = forall s. ResponseData !(TagGen ps s) !(TagMap s response)

76−

77−traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequestData (PrimState m) request -> m (ResponseData (PrimState m) response)

78−traverseRequesterData f (RequestData tg es) = ResponseData tg . TagMap.fromList <$> wither g (toList es)

79− where g (RequestEnvelope mt req) = case mt of

80− Just t -> Just . (t :=>) <$> f req

81− Nothing -> Nothing <$ f req

82−

83−runRequesterT :: forall t request response m a

84− . ( Reflex t

85− , PrimMonad m

86− , MonadFix m

87− )

88− => RequesterT t request response m a

89− -> Event t (ResponseData (PrimState m) response)

90− -> m (a, Event t (RequestData (PrimState m) request))

91−runRequesterT (RequesterT a) wrappedResponses = withRequesterInternalT $ \(requests :: Event t (Seq (RequestEnvelope s request))) -> do

92− (_, tg) <- RequesterInternalT ask

93− result <- a

94− let responses = fforMaybe wrappedResponses $ \(ResponseData tg' m) -> case tg `geq` tg' of

95− Nothing -> trace ("runRequesterT: bad TagGen: expected " <> show tg <> " but got " <> show tg') Nothing --TODO: Warn somehow

96− Just Refl -> trace "runRequesterT: good TagGen" $ Just m

97− pure (responses, (result, fmapCheap (RequestData tg) requests))

98−

99−instance MonadTrans (RequesterInternalT s t request response) where

100− lift = RequesterInternalT . lift . lift

101−

102−instance MonadTrans (RequesterT t request response) where

103− lift a = RequesterT $ RequesterInternalT $ lift $ lift a

104−

105−-- | Run a 'RequesterT' action. The resulting 'Event' will fire whenever

106−-- requests are made, and responses should be provided in the input 'Event'.

107−-- The 'Tag' keys will be used to return the responses to the same place the

108−-- requests were issued.

109−withRequesterInternalT

110− :: ( Reflex t

111− , PrimMonad m

112− , MonadFix m

113− )

114− => (forall s. Event t (Seq (RequestEnvelope s request)) -> RequesterInternalT s t request response m (Event t (TagMap s response), a))

115− -> m a

116−withRequesterInternalT f = withTagGen $ \tg -> do

117− rec let RequesterInternalT a = f requests

118− ((responses, result), requests) <- runEventWriterT $ runReaderT a (fanTag responses, tg)

119− pure result

120−

121−data RequestEnvelope s request = forall a. RequestEnvelope {-# UNPACK #-} !(Maybe (Tag s a)) !(request a)

122−

123−newtype RequesterT t (request :: * -> *) (response :: * -> *) m a = RequesterT { unRequesterT :: forall s. RequesterInternalT s t request response m a }

124−

125−instance Functor m => Functor (RequesterT t request response m) where

126− fmap f (RequesterT x) = RequesterT $ fmap f x

127−

128−instance Monad m => Applicative (RequesterT t request response m) where

129− pure x = RequesterT $ pure x

130− RequesterT f <*> RequesterT x = RequesterT $ f <*> x

131− liftA2 f (RequesterT a) (RequesterT b) = RequesterT $ liftA2 f a b

132− RequesterT f <* RequesterT x = RequesterT $ f <* x

133− RequesterT f *> RequesterT x = RequesterT $ f *> x

134−

135−instance Monad m => Monad (RequesterT t request response m) where

136− return = pure

137− RequesterT mx >>= f = RequesterT $ mx >>= \x -> case f x of

138− RequesterT y -> y

139−

140−instance MonadFix m => MonadFix (RequesterT t request response m) where

141− mfix f = RequesterT $ mfix $ \x -> case f x of

142− RequesterT a -> a

143−

144−instance MonadIO m => MonadIO (RequesterT t request respnose m) where

145− liftIO a = RequesterT $ liftIO a

146−

147−instance MonadException m => MonadException (RequesterT t request respnose m) where

148− throw e = RequesterT $ throw e

149−

150−newtype RequesterInternalT s t request response m a = RequesterInternalT { unRequesterInternalT :: ReaderT (EventSelectorTag t s response, TagGen (PrimState m) s) (EventWriterT t (Seq (RequestEnvelope s request)) m) a }

151− deriving

152− ( Functor, Applicative, Monad, MonadFix, MonadIO, MonadException

153−#if MIN_VERSION_base(4,9,1)

154− , MonadAsyncException

155−#endif

156− )

157−

158−-- I don't think this can actually be supported without an unsafeCoerce

159−-- #if MIN_VERSION_base(4,9,1)

160−-- instance MonadAsyncException m => MonadAsyncException (RequesterT t request response m) where

161−-- mask f = RequesterT $ mask $ \unmask -> unRequesterT $ f $ \x -> RequesterT $ unmask $ unRequesterT x

162−-- #endif

163−

164−instance MonadSample t m => MonadSample t (RequesterT t request response m)

165−instance MonadHold t m => MonadHold t (RequesterT t request response m)

166−instance PostBuild t m => PostBuild t (RequesterT t request response m)

167−instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)

168−

169−instance MonadSample t m => MonadSample t (RequesterInternalT s t request response m)

170−instance MonadHold t m => MonadHold t (RequesterInternalT s t request response m)

171−instance PostBuild t m => PostBuild t (RequesterInternalT s t request response m)

172−instance TriggerEvent t m => TriggerEvent t (RequesterInternalT s t request response m)

173−

174−instance PrimMonad m => PrimMonad (RequesterT t request response m) where

175− type PrimState (RequesterT t request response m) = PrimState m

176− primitive = lift . primitive

177−

178−-- TODO: Monoid and Semigroup can likely be derived once StateT has them.

179−instance (Monoid a, Monad m) => Monoid (RequesterT t request response m a) where

180− mempty = pure mempty

181− mappend = liftA2 mappend

182−

183−instance (S.Semigroup a, Monad m) => S.Semigroup (RequesterT t request response m a) where

184− (<>) = liftA2 (S.<>)

185−

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

187− type Performable (RequesterT t request response m) = Performable m

188− performEvent_ = lift . performEvent_

189− performEvent = lift . performEvent

190−

191−instance MonadRef m => MonadRef (RequesterT t request response m) where

192− type Ref (RequesterT t request response m) = Ref m

193− newRef = lift . newRef

194− readRef = lift . readRef

195− writeRef r = lift . writeRef r

196−

197−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where

198− newEventWithTrigger = lift . newEventWithTrigger

199− newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

200−

201−instance MonadReader r m => MonadReader r (RequesterT t request response m) where

202− ask = lift ask

203− local f (RequesterT a) = RequesterT $ RequesterInternalT $ mapReaderT (mapEventWriterT $ local f) $ unRequesterInternalT a

204− reader = lift . reader

205−

206−instance (Reflex t, PrimMonad m) => Requester t (RequesterT t request response m) where

207− type Request (RequesterT t request response m) = request

208− type Response (RequesterT t request response m) = response

209− requesting e = RequesterT $ requesting e

210− requesting_ e = RequesterT $ requesting_ e

211−

212−instance (Reflex t, PrimMonad m) => Requester t (RequesterInternalT s t request response m) where

213− type Request (RequesterInternalT s t request response m) = request

214− type Response (RequesterInternalT s t request response m) = response

215− requesting e = RequesterInternalT $ do

216− (s, tg) <- ask

217− t <- lift $ lift $ newTag tg

218− tellEvent $ fmapCheap (Seq.singleton . RequestEnvelope (Just t)) e

219− pure $ selectTag s t

220− requesting_ e = RequesterInternalT $ do

221− tellEvent $ fmapCheap (Seq.singleton . RequestEnvelope Nothing) e

222−

223−instance (Adjustable t m, MonadHold t m) => Adjustable t (RequesterInternalT s t request response m) where

224− {-# INLINABLE runWithReplace #-}

225− runWithReplace (RequesterInternalT a0) a' = RequesterInternalT $ runWithReplace a0 (coerceEvent a')

226− {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}

227− traverseIntMapWithKeyWithAdjust f dm0 dm' = RequesterInternalT $ traverseIntMapWithKeyWithAdjust (coerce . f) dm0 dm'

228− {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

229− traverseDMapWithKeyWithAdjust f dm0 dm' = RequesterInternalT $ traverseDMapWithKeyWithAdjust (coerce . f) dm0 dm'

230− {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}

231− traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = RequesterInternalT $ traverseDMapWithKeyWithAdjustWithMove (coerce . f) dm0 dm'

232−

233−instance (Adjustable t m, MonadHold t m) => Adjustable t (RequesterT t request response m) where

234− {-# INLINABLE runWithReplace #-}

235− runWithReplace (RequesterT a0) a' = RequesterT $ runWithReplace a0 (fmapCheap unRequesterT a')

236− {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}

237− traverseIntMapWithKeyWithAdjust f dm0 dm' = RequesterT $ traverseIntMapWithKeyWithAdjust (\k v -> unRequesterT $ f k v) dm0 dm'

238− {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

239− traverseDMapWithKeyWithAdjust f dm0 dm' = RequesterT $ traverseDMapWithKeyWithAdjust (\k v -> unRequesterT $ f k v) dm0 dm'

240− {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}

241− traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = RequesterT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unRequesterT $ f k v) dm0 dm'

242−

243−{-# INLINABLE runWithReplaceRequesterTWith #-}

244−runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m

245− , MonadFix m

246− )

247− => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))

248− -> RequesterT t request response m a

249− -> Event t (RequesterT t request response m b)

250− -> RequesterT t request response m (a, Event t b)

251−runWithReplaceRequesterTWith f (RequesterT a0) a' = RequesterT $ do

252− pure undefined

253−

254−{-

255−import GHC.Exts (Any)

256−import Unsafe.Coerce

257−

258−--TODO: Make this module type-safe

259−

260−newtype TagMap (f :: * -> *) = TagMap (IntMap Any)

261−

262−newtype RequesterData f = RequesterData (TagMap (Entry f))

263−

264−data RequesterDataKey a where

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

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

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

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

269−

270−singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f

271−singletonRequesterData rdk v = case rdk of

272− RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v

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

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

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

276−

277−requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]

278−requesterDataToList (RequesterData m) = do

279− k :=> Entry e <- tagMapToList m

280− case myKeyType k of

281− MyTagType_Single -> return $ RequesterDataKey_Single k :=> e

282− MyTagType_Multi -> do

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

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

285− return $ RequesterDataKey_Multi k k' k'' :=> e''

286− MyTagType_Multi2 -> do

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

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

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

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

291− MyTagType_Multi3 -> do

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

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

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

295− return $ RequesterDataKey_Multi3 k k' k'' k''' :=> e'''

296−

297−singletonTagMap :: forall f a. MyTag a -> f a -> TagMap f

298−singletonTagMap (MyTag k) v = TagMap $ IntMap.singleton k $ (unsafeCoerce :: f a -> Any) v

299−

300−tagMapToList :: forall f. TagMap f -> [DSum MyTag f]

301−tagMapToList (TagMap m) = f <$> IntMap.toList m

302− where f :: (Int, Any) -> DSum MyTag f

303− f (k, v) = MyTag k :=> (unsafeCoerce :: Any -> f a) v

304−

305−traverseTagMapWithKey :: forall t f g. Applicative t => (forall a. MyTag a -> f a -> t (g a)) -> TagMap f -> t (TagMap g)

306−traverseTagMapWithKey f (TagMap m) = TagMap <$> IntMap.traverseWithKey g m

307− where

308− g :: Int -> Any -> t Any

309− g k v = (unsafeCoerce :: g a -> Any) <$> f (MyTag k) ((unsafeCoerce :: Any -> f a) v)

310−

311−-- | Runs in reverse to accommodate for the fact that we accumulate it in reverse

312−traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequesterData request -> m (RequesterData response)

313−traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWithKey go m --TODO: reverse this, since our tags are in reverse order

314− where go :: forall x. MyTag x -> Entry request x -> m (Entry response x)

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

316− MyTagType_Single -> f request

317− MyTagType_Multi -> traverse (traverseRequesterData f) request

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

319− MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request

320−

321−-- | 'traverseRequesterData' with its arguments flipped

322−forRequesterData :: forall request response m. Applicative m => RequesterData request -> (forall a. request a -> m (response a)) -> m (RequesterData response)

323−forRequesterData r f = traverseRequesterData f r

324−

325−data MyTagType :: * -> * where

326− MyTagType_Single :: MyTagType (Single a)

327− MyTagType_Multi :: MyTagType Multi

328− MyTagType_Multi2 :: MyTagType (Multi2 k)

329− MyTagType_Multi3 :: MyTagType Multi3

330−

331−myKeyType :: MyTag x -> MyTagType x

332−myKeyType (MyTag k) = case k .&. 0x3 of

333− 0x0 -> unsafeCoerce MyTagType_Single

334− 0x1 -> unsafeCoerce MyTagType_Multi

335− 0x2 -> unsafeCoerce MyTagType_Multi2

336− 0x3 -> unsafeCoerce MyTagType_Multi3

337− t -> error $ "Reflex.Requester.Base.myKeyType: no such key type" <> show t

338−

339−data Single a

340−data Multi

341−data Multi2 (k :: * -> *)

342−data Multi3

343−

344−class MyTagTypeOffset x where

345− myTagTypeOffset :: proxy x -> Int

346−

347−instance MyTagTypeOffset (Single a) where

348− myTagTypeOffset _ = 0x0

349−

350−instance MyTagTypeOffset Multi where

351− myTagTypeOffset _ = 0x1

352−

353−instance MyTagTypeOffset (Multi2 k) where

354− myTagTypeOffset _ = 0x2

355−

356−instance MyTagTypeOffset Multi3 where

357− myTagTypeOffset _ = 0x3

358−

359−type family EntryContents request a where

360− EntryContents request (Single a) = request a

361− EntryContents request Multi = IntMap (RequesterData request)

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

363− EntryContents request Multi3 = IntMap (IntMap (RequesterData request))

364−

365−newtype Entry request x = Entry { unEntry :: EntryContents request x }

366−

367−{-# INLINE singleEntry #-}

368−singleEntry :: f a -> Entry f (Single a)

369−singleEntry = Entry

370−

371−{-# INLINE multiEntry #-}

372−multiEntry :: IntMap (RequesterData f) -> Entry f Multi

373−multiEntry = Entry

374−

375−{-# INLINE unMultiEntry #-}

376−unMultiEntry :: Entry f Multi -> IntMap (RequesterData f)

377−unMultiEntry = unEntry

378−

379−-- | We use a hack here to pretend we have x ~ request a; we don't want to use a GADT, because GADTs (even with zero-size existential contexts) can't be newtypes

380−-- WARNING: This type should never be exposed. In particular, this is extremely unsound if a MyTag from one run of runRequesterT is ever compared against a MyTag from another

381−newtype MyTag x = MyTag Int deriving (Show, Eq, Ord, Enum)

382−

383−newtype MyTagWrap (f :: * -> *) x = MyTagWrap Int deriving (Show, Eq, Ord, Enum)

384−

385−{-# INLINE castMyTagWrap #-}

386−castMyTagWrap :: MyTagWrap f (Entry f x) -> MyTagWrap g (Entry g x)

387−castMyTagWrap = coerce

388−

389−instance GEq MyTag where

390− (MyTag a) `geq` (MyTag b) =

391− if a == b

392− then Just $ unsafeCoerce Refl

393− else Nothing

394−

395−instance GCompare MyTag where

396− (MyTag a) `gcompare` (MyTag b) =

397− case a `compare` b of

398− LT -> GLT

399− EQ -> unsafeCoerce GEQ

400− GT -> GGT

401−

402−instance GEq (MyTagWrap f) where

403− (MyTagWrap a) `geq` (MyTagWrap b) =

404− if a == b

405− then Just $ unsafeCoerce Refl

406− else Nothing

407−

408−instance GCompare (MyTagWrap f) where

409− (MyTagWrap a) `gcompare` (MyTagWrap b) =

410− case a `compare` b of

411− LT -> GLT

412− EQ -> unsafeCoerce GEQ

413− GT -> GGT

414−

415−data RequesterState t (request :: * -> *) = RequesterState

416− { _requesterState_nextMyTag :: {-# UNPACK #-} !Int -- Starts at -4 and goes down by 4 each time, to accommodate two 'type' bits at the bottom

417− , _requesterState_requests :: ![(Int, Event t Any)]

418− }

419−

420−-- | A basic implementation of 'Requester'.

421−newtype RequesterT t request (response :: * -> *) m a = RequesterT { unRequesterT :: StateT (RequesterState t request) (ReaderT (EventSelectorInt t Any) m) a }

422− deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException

423−-- MonadAsyncException can't be derived on ghc-8.0.1; we use base-4.9.1 as a proxy for ghc-8.0.2

424−#if MIN_VERSION_base(4,9,1)

425− , MonadAsyncException

426−#endif

427− )

428−

429−

430−-- | Run a 'RequesterT' action. The resulting 'Event' will fire whenever

431−-- requests are made, and responses should be provided in the input 'Event'.

432−-- The 'Tag' keys will be used to return the responses to the same place the

433−-- requests were issued.

434−runRequesterT :: (Reflex t, Monad m)

435− => RequesterT t request response m a

436− -> Event t (RequesterData response) --TODO: This DMap will be in reverse order, so we need to make sure the caller traverses it in reverse

437− -> m (a, Event t (RequesterData request)) --TODO: we need to hide these 'MyTag's here, because they're unsafe to mix in the wild

438−runRequesterT (RequesterT a) responses = do

439− (result, s) <- runReaderT (runStateT a $ RequesterState (-4) []) $ fanInt $

440− coerceEvent responses

441− return (result, fmapCheap (RequesterData . TagMap) $ mergeInt $ IntMap.fromDistinctAscList $ _requesterState_requests s)

442−

443−-- | Map a function over the request and response of a 'RequesterT'

444−withRequesterT

445− :: (Reflex t, MonadFix m)

446− => (forall x. req x -> req' x) -- ^ The function to map over the request

447− -> (forall x. rsp' x -> rsp x) -- ^ The function to map over the response

448− -> RequesterT t req rsp m a -- ^ The internal 'RequesterT' whose input and output will be transformed

449− -> RequesterT t req' rsp' m a -- ^ The resulting 'RequesterT'

450−withRequesterT freq frsp child = do

451− rec let rsp = fmap (runIdentity . traverseRequesterData (Identity . frsp)) rsp'

452− (a, req) <- lift $ runRequesterT child rsp

453− rsp' <- fmap (flip selectInt 0 . fanInt . fmapCheap unMultiEntry) $ requesting' $

454− fmapCheap (multiEntry . IntMap.singleton 0) $ fmap (runIdentity . traverseRequesterData (Identity . freq)) req

455− return a

456−

457−instance (Reflex t, Monad m) => Requester t (RequesterT t request response m) where

458− type Request (RequesterT t request response m) = request

459− type Response (RequesterT t request response m) = response

460− requesting = fmap coerceEvent . responseFromTag . castMyTagWrap <=< tagRequest . (coerceEvent :: Event t (request a) -> Event t (Entry request (Single a)))

461− requesting_ = void . tagRequest . fmapCheap singleEntry

462−

463−{-# INLINE tagRequest #-}

464−tagRequest :: forall m x t request response. (Monad m, MyTagTypeOffset x) => Event t (Entry request x) -> RequesterT t request response m (MyTagWrap request (Entry request x))

465−tagRequest req = do

466− old <- RequesterT get

467− let n = _requesterState_nextMyTag old .|. myTagTypeOffset (Proxy :: Proxy x)

468− t = MyTagWrap n

469− RequesterT $ put $ RequesterState

470− { _requesterState_nextMyTag = _requesterState_nextMyTag old - 0x4

471− , _requesterState_requests = (n, (unsafeCoerce :: Event t (Entry request x) -> Event t Any) req) : _requesterState_requests old

472− }

473− return t

474−

475−{-# INLINE responseFromTag #-}

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

477−responseFromTag (MyTagWrap t) = do

478− responses :: EventSelectorInt t Any <- RequesterT ask

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

480−

481−instance MonadTrans (RequesterT t request response) where

482− lift = RequesterT . lift . lift

483−

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

485− type Performable (RequesterT t request response m) = Performable m

486− performEvent_ = lift . performEvent_

487− performEvent = lift . performEvent

488−

489−instance MonadRef m => MonadRef (RequesterT t request response m) where

490− type Ref (RequesterT t request response m) = Ref m

491− newRef = lift . newRef

492− readRef = lift . readRef

493− writeRef r = lift . writeRef r

494−

495−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where

496− newEventWithTrigger = lift . newEventWithTrigger

497− newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

498−

499−instance MonadReader r m => MonadReader r (RequesterT t request response m) where

500− ask = lift ask

501− local f (RequesterT a) = RequesterT $ mapStateT (mapReaderT $ local f) a

502− reader = lift . reader

503−

504−instance (Reflex t, Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (RequesterT t request response m) where

505− runWithReplace = runWithReplaceRequesterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'

506− traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElementsMap mergeIntIncremental

507− {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

508− traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental

509− traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove

510−

511−requesting' :: (MyTagTypeOffset x, Monad m) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x))

512−requesting' = responseFromTag . castMyTagWrap <=< tagRequest

513−

514−{-# INLINABLE runWithReplaceRequesterTWith #-}

515−runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m

516− , MonadFix m

517− )

518− => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))

519− -> RequesterT t request response m a

520− -> Event t (RequesterT t request response m b)

521− -> RequesterT t request response m (a, Event t b)

522−runWithReplaceRequesterTWith f a0 a' = do

523− rec na' <- numberOccurrencesFrom 1 a'

524− responses <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here

525− let responses' = fanInt responses

526− ((result0, requests0), v') <- f (runRequesterT a0 (selectInt responses' 0)) $ fmapCheap (\(n, a) -> fmap ((,) n) $ runRequesterT a $ selectInt responses' n) na'

527− requests <- holdDyn (fmapCheap (IntMap.singleton 0) requests0) $ fmapCheap (\(n, (_, reqs)) -> fmapCheap (IntMap.singleton n) reqs) v'

528− return (result0, fmapCheap (fst . snd) v')

529−

530−{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}

531−traverseIntMapWithKeyWithAdjustRequesterTWith :: forall t request response m v v' p.

532− ( Reflex t

533− , MonadHold t m

534− , PatchTarget (p (Event t (IntMap (RequesterData request)))) ~ IntMap (Event t (IntMap (RequesterData request)))

535− , Patch (p (Event t (IntMap (RequesterData request))))

536− , Functor p

537− , MonadFix m

538− )

539− => ( (IntMap.Key -> (IntMap.Key, v) -> m (Event t (IntMap (RequesterData request)), v'))

540− -> IntMap (IntMap.Key, v)

541− -> Event t (p (IntMap.Key, v))

542− -> RequesterT t request response m (IntMap (Event t (IntMap (RequesterData request)), v'), Event t (p (Event t (IntMap (RequesterData request)), v')))

543− )

544− -> (p (Event t (IntMap (RequesterData request))) -> IntMap (Event t (IntMap (RequesterData request))))

545− -> (Incremental t (p (Event t (IntMap (RequesterData request)))) -> Event t (IntMap (IntMap (RequesterData request))))

546− -> (IntMap.Key -> v -> RequesterT t request response m v')

547− -> IntMap v

548− -> Event t (p v)

549− -> RequesterT t request response m (IntMap v', Event t (p v'))

550−traverseIntMapWithKeyWithAdjustRequesterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do

551− rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here

552− let responses :: EventSelectorInt t (IntMap (RequesterData response))

553− responses = fanInt $ fmapCheap unpack response

554− unpack :: Entry response Multi3 -> IntMap (IntMap (RequesterData response))

555− unpack = unEntry

556− pack :: IntMap (IntMap (RequesterData request)) -> Entry request Multi3

557− pack = Entry

558− f' :: IntMap.Key -> (Int, v) -> m (Event t (IntMap (RequesterData request)), v')

559− f' k (n, v) = do

560− (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ selectInt responses k --TODO: Instead of doing mapMaybeCheap, can we share a fanInt across all instances of a given key, or at least the ones that are adjacent in time?

561− return (fmapCheap (IntMap.singleton n) myRequests, result)

562− ndm' <- numberOccurrencesFrom 1 dm'

563− (children0, children') <- base f' (fmap ((,) 0) dm0) $ fmap (\(n, dm) -> fmap ((,) n) dm) ndm' --TODO: Avoid this somehow, probably by adding some sort of per-cohort information passing to Adjustable

564− let result0 = fmap snd children0

565− result' = fforCheap children' $ fmap snd

566− requests0 :: IntMap (Event t (IntMap (RequesterData request)))

567− requests0 = fmap fst children0

568− requests' :: Event t (p (Event t (IntMap (RequesterData request))))

569− requests' = fforCheap children' $ fmap fst

570− promptRequests :: Event t (IntMap (IntMap (RequesterData request)))

571− promptRequests = coincidence $ fmapCheap (mergeInt . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'

572− requests <- holdIncremental requests0 requests'

573− return (result0, result')

574−

575−{-# INLINE traverseDMapWithKeyWithAdjustRequesterTWith #-}

576−traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v' p p'.

577− ( GCompare k

578− , Reflex t

579− , MonadHold t m

580− , PatchTarget (p' (Some k) (Event t (IntMap (RequesterData request)))) ~ Map (Some k) (Event t (IntMap (RequesterData request)))

581− , Patch (p' (Some k) (Event t (IntMap (RequesterData request))))

582− , MonadFix m

583− )

584− => (forall k' v1 v2. GCompare k'

585− => (forall a. k' a -> v1 a -> m (v2 a))

586− -> DMap k' v1

587− -> Event t (p k' v1)

588− -> RequesterT t request response m (DMap k' v2, Event t (p k' v2))

589− )

590− -> (forall v1 v2. (forall a. v1 a -> v2 a) -> p k v1 -> p k v2)

591− -> (forall v1 v2. (forall a. v1 a -> v2) -> p k v1 -> p' (Some k) v2)

592− -> (forall v2. p' (Some k) v2 -> Map (Some k) v2)

593− -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a))

594− -> (forall a. k a -> v a -> RequesterT t request response m (v' a))

595− -> DMap k v

596− -> Event t (p k v)

597− -> RequesterT t request response m (DMap k v', Event t (p k v'))

598−traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do

599− rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here

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

601− responses = fanMap $ fmapCheap unpack response

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

603− unpack = unEntry

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

605− pack = Entry

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

607− f' k (Compose (n, v)) = do

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

609− return $ Compose (fmapCheap (IntMap.singleton n) myRequests, result)

610− ndm' <- numberOccurrencesFrom 1 dm'

611− (children0, children') <- base f' (DMap.map (\v -> Compose (0, v)) dm0) $ fmap (\(n, dm) -> mapPatch (\v -> Compose (n, v)) dm) ndm'

612− let result0 = DMap.map (snd . getCompose) children0

613− result' = fforCheap children' $ mapPatch $ snd . getCompose

614− requests0 :: Map (Some k) (Event t (IntMap (RequesterData request)))

615− requests0 = weakenDMapWith (fst . getCompose) children0

616− requests' :: Event t (p' (Some k) (Event t (IntMap (RequesterData request))))

617− requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose

618− promptRequests :: Event t (Map (Some k) (IntMap (RequesterData request)))

619− promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'

620− requests <- holdIncremental requests0 requests'

621− return (result0, result')

622−

623−data Decoder rawResponse response =

624− forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)

625−

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

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

628−-- incoming responses.

629−matchResponsesWithRequests

630− :: forall t rawRequest rawResponse request response m.

631− ( MonadFix m

632− , MonadHold t m

633− , Reflex t

634− )

635− => (forall a. request a -> (rawRequest, rawResponse -> response a))

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

637− -- request and a function used to process the associated response

638− -> Event t (RequesterData request)

639− -- ^ The outgoing requests

640− -> Event t (Int, rawResponse)

641− -- ^ The incoming responses, tagged by an identifying key

642− -> m ( Event t (Map Int rawRequest)

643− , Event t (RequesterData response)

644− )

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

646− -- by the 'RequesterData' key of the associated outgoing request

647−matchResponsesWithRequests f send recv = do

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

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

650− holdIncremental mempty $ leftmost

651− [ fmap (\(_, outstanding, _) -> outstanding) outgoing

652− , snd <$> incoming

653− ]

654− let outgoing = processOutgoing nextId send

655− incoming = processIncoming waitingFor recv

656− return (fmap (\(_, _, rawReqs) -> rawReqs) outgoing, fst <$> incoming)

657− where

658− -- Tags each outgoing request with an identifying integer key

659− -- and returns the next available key, a map of response decoders

660− -- for requests for which there are outstanding responses, and the

661− -- raw requests to be sent out.

662− processOutgoing

663− :: Behavior t Int

664− -- The next available key

665− -> Event t (RequesterData request)

666− -- The outgoing request

667− -> Event t ( Int

668− , PatchMap Int (Decoder rawResponse response)

669− , Map Int rawRequest )

670− -- The new next-available-key, a map of requests expecting responses, and the tagged raw requests

671− processOutgoing nextId out = flip pushAlways out $ \dm -> do

672− oldNextId <- sample nextId

673− let (result, newNextId) = flip runState oldNextId $ forM (requesterDataToList dm) $ \(k :=> v) -> do

674− n <- get

675− put $ succ n

676− let (rawReq, rspF) = f v

677− return (n, rawReq, Decoder k rspF)

678− patchWaitingFor = PatchMap $ Map.fromList $

679− (\(n, _, dec) -> (n, Just dec)) <$> result

680− toSend = Map.fromList $ (\(n, rawReq, _) -> (n, rawReq)) <$> result

681− return (newNextId, patchWaitingFor, toSend)

682− -- Looks up the each incoming raw response in a map of response

683− -- decoders and returns the decoded response and a patch that can

684− -- be used to clear the ID of the consumed response out of the queue

685− -- of expected responses.

686− processIncoming

687− :: Incremental t (PatchMap Int (Decoder rawResponse response))

688− -- A map of outstanding expected responses

689− -> Event t (Int, rawResponse)

690− -- A incoming response paired with its identifying key

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

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

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

694− wf <- sample $ currentIncremental waitingFor

695− case Map.lookup n wf of

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

697− Just (Decoder k rspF) -> do

698− let rsp = rspF rawRsp

699− return $ Just

700− ( singletonRequesterData k rsp

701− , PatchMap $ Map.singleton n Nothing

702− )

703−-}

src/Reflex/Requester/Class.hs+1−1

@@ -40,7 +40,7 @@ class (Reflex t, Monad m) => Requester t m | m -> t where

4040 requesting :: Event t (Request m a) -> m (Event t (Response m a))

4141 -- | Emit a request whenever the given 'Event' fires, and ignore all responses.

4242 requesting_ :: Event t (Request m a) -> m ()

43−--TODO: Make Requester polykinded, where Request m and Response m both take an argument of the same kind

43+

4444

4545instance Requester t m => Requester t (ReaderT r m) where

4646 type Request (ReaderT r m) = Request m

src/Reflex/Spider/Internal.hs+501−275

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

@@ -20,6 +19,7 @@

2019{-# LANGUAGE DeriveFunctor #-}

2120{-# LANGUAGE StandaloneDeriving #-}

2221{-# LANGUAGE InstanceSigs #-}

22+{-# LANGUAGE MultiWayIf #-}

2323

2424#ifdef USE_REFLEX_OPTIMIZER

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

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

3838import Control.Monad.Exception

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

4040import Control.Monad.Primitive

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

4241import Control.Monad.Reader.Class

4342import Control.Monad.IO.Class

4443import Control.Monad.ReaderIO

4544import Control.Monad.Ref

45+import Control.Monad.Fail (MonadFail)

46+import qualified Control.Monad.Fail as MonadFail

4647import Data.Align

4748import Data.Coerce

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

49+import Data.Dependent.Map (DMap)

4950import qualified Data.Dependent.Map as DMap

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

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

5153import qualified Data.FastMutableIntMap as FastMutableIntMap

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

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

5961import Data.IORef

6062import Data.Kind (Type)

6163import Data.Maybe hiding (mapMaybe)

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

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

6365import Data.Proxy

6466import Data.These

6567import Data.Traversable

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

6669import Data.Witherable (Filterable, mapMaybe)

67−import GHC.Exts

70+import GHC.Exts hiding (toList)

6871import GHC.IORef (IORef (..))

6972import GHC.Stack

7073import Reflex.FastWeak

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

7275import System.Mem.Weak

7376import Unsafe.Coerce

7477

75−#if defined(MIN_VERSION_semialign)

78+#ifdef MIN_VERSION_semialign

7679#if MIN_VERSION_these(0,8,0)

7780import Data.These.Combinators (justThese)

7881#endif

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

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

84+#endif

7985#endif

8086

8187#ifdef DEBUG_CYCLES

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

89+#endif

90+

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

8492import qualified Data.List.NonEmpty as NonEmpty

85−import Data.Monoid (mempty)

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

87−#endif

94+import Data.List (isPrefixOf)

8895

89−import Data.FastWeakBag (FastWeakBag)

96+import Data.FastWeakBag (FastWeakBag, FastWeakBagTicket)

9097import qualified Data.FastWeakBag as FastWeakBag

98+

9199import Data.Reflection

92100import Data.Some (Some(Some))

93101import Data.Type.Coercion

@@ -98,22 +106,26 @@ import qualified Reflex.Class

98106import qualified Reflex.Class as R

99107import qualified Reflex.Host.Class

100108import Reflex.NotReady.Class

101−import Reflex.Patch

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

103112

104113#ifdef DEBUG_TRACE_EVENTS

105114import qualified Data.ByteString.Char8 as BS8

106115import System.IO (stderr)

116+import Data.List (isPrefixOf)

107117#endif

108118

109−import Debug.Trace

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

120+debugStrLn :: String -> IO ()

121+debugStrLn = putStrLn

110122

111123#ifdef DEBUG_TRACE_EVENTS

112−

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

114125withStackOneLine expr = unsafePerformIO $ do

115126 stack <- currentCallStack

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

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

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

117129

118130#endif

119131

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

124136debugInvalidate :: Bool

125137

126138#ifdef DEBUG

127−

128139#define DEBUG_NODEIDS

129140

141+#ifdef DEBUG_TRACE_PROPAGATION

130142debugPropagate = True

143+#else

144+debugPropagate = False

145+#endif

131146

147+#ifdef DEBUG_TRACE_HEIGHT

148+debugInvalidateHeight = True

149+#else

132150debugInvalidateHeight = False

151+#endif

133152

153+#ifdef DEBUG_TRACE_INVALIDATION

134154debugInvalidate = True

155+#else

156+debugInvalidate = False

157+#endif

135158

136159class HasNodeId a where

137160 getNodeId :: a -> Int

138161

139−instance HasNodeId (Hold x p a) where

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

141167

142−instance HasNodeId (PushSubscribed x a b) where

143− getNodeId = pushSubscribedNodeId

168+instance HasNodeId (Hold x p) where

169+ getNodeId = holdNodeId

144170

145171instance HasNodeId (SwitchSubscribed x a) where

146172 getNodeId = switchSubscribedNodeId

147173

148−instance HasNodeId (FanSubscribed x a) where

174+instance HasNodeId (FanSubscribed x v a) where

149175 getNodeId = fanSubscribedNodeId

150176

151177instance HasNodeId (CoincidenceSubscribed x a) where

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

159185

160186{-# INLINE showNodeId #-}

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

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

163−

164−showSubscriberType :: Subscriber x a -> String

165−showSubscriberType = \case

166− SubscriberPush _ _ -> "SubscriberPush"

167− SubscriberMerge _ _ -> "SubscriberMerge"

168− SubscriberFan _ -> "SubscriberFan"

169− SubscriberMergeChange _ -> "SubscriberMergeChange"

170− SubscriberHold _ -> "SubscriberHold"

171− SubscriberHoldIdentity _ -> "SubscriberHoldIdentity"

172− SubscriberSwitch _ -> "SubscriberSwitch"

173− SubscriberCoincidenceOuter _ -> "SubscriberCoincidenceOuter"

174− SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"

175− SubscriberHandle -> "SubscriberHandle"

176−

177−showEventType :: Event x a -> String

178−showEventType = \case

179− EventRoot _ _ -> "EventRoot"

180− EventNever -> "EventNever"

181− EventPush _ -> "EventPush"

182− EventMerge _ -> "EventMerge"

183− EventFan _ _ -> "EventFan"

184− EventSwitch _ -> "EventSwitch"

185− EventCoincidence _ -> "EventCoincidence"

186− EventHold _ -> "EventHold"

187− EventDyn _ -> "EventDyn"

188− EventHoldIdentity _ -> "EventHoldIdentity"

189− EventDynIdentity _ -> "EventDynIdentity"

188+showNodeId = showNodeId' . getNodeId

189+

190+showNodeId' :: Int -> String

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

192+

190193

191194#else

192195

193196debugPropagate = False

194−

195197debugInvalidateHeight = False

196−

197198debugInvalidate = False

198199

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

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

201202showNodeId :: a -> String

202203showNodeId _ = ""

203204

205+{-# INLINE showNodeId' #-}

206+showNodeId' :: Int -> String

207+showNodeId' _ = ""

208+

204209#endif

205210

206211#ifdef DEBUG_NODEIDS

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

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

247252-- efficient than 'push'

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

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

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

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

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

252257 { subscriberPropagate = \a -> do

253258 mb <- f a

254259 mapM_ (subscriberPropagate sub) mb

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

267272

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

269274{-# INLINE subscribeAndReadHead #-}

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

271276subscribeAndReadHead e sub = do

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

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

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

274279 { subscriberPropagate = \a -> do

275280 liftIO $ unsubscribe =<< readIORef subscriptionRef

276281 subscriberPropagate sub a

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

281286 return (subscription, occ)

282287

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

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

285290headE originalE = do

286291 parent <- liftIO $ newIORef $ Just originalE

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

288293 let clearParent = liftIO $ writeIORef parent Nothing

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

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

290295 when (isJust occ) clearParent

291− return $ Event $ \sub -> do

296+ return $ Event $ \sub ->

292297 liftIO (readIORef parent) >>= \case

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

298+ Nothing -> subscribeAndReadNever

294299 Just e -> subscribeAndReadHead e sub

295300

296301data CacheSubscribed x a

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

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

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

305+#ifdef DEBUG_NODEIDS

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

307+#endif

300308 }

301309

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+

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

303326-- repeatedly

304327--

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

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

324347 Just subscribedTicket -> return subscribedTicket

325348 Nothing -> do

349+#ifdef DEBUG_NODEIDS

350+ nodeId <- liftIO newNodeId

351+#endif

326352 subscribers <- liftIO FastWeakBag.empty

327353 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

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

329− { subscriberPropagate = \a -> do

330− liftIO $ writeIORef occRef $ Just a

331− scheduleClear occRef

332− propagateFast a subscribers

333− , subscriberInvalidateHeight = \old -> do

334− FastWeakBag.traverse subscribers $ invalidateSubscriberHeight old

335− , subscriberRecalculateHeight = \new -> do

336− FastWeakBag.traverse subscribers $ recalculateSubscriberHeight new

337− }

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

338366 when (isJust occ) $ do

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

340368 scheduleClear occRef

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

342370 { _cacheSubscribed_subscribers = subscribers

343371 , _cacheSubscribed_parent = parentSub

344372 , _cacheSubscribed_occurrence = occRef

373+#ifdef DEBUG_NODEIDS

374+ , _cacheSubscribed_nodeId = nodeId

375+#endif

345376 }

346377 subscribedTicket <- liftIO $ mkFastWeakTicket subscribed

347378 liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket

348379 return subscribedTicket

349− liftIO $ do

350− subscribed <- getFastWeakTicketValue subscribedTicket

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

352− occ <- readIORef $ _cacheSubscribed_occurrence subscribed

353− let es = EventSubscription

354− { _eventSubscription_unsubscribe = do

355− FastWeakBag.remove ticket

356− isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed

357− when isEmpty $ do

358− writeIORef mSubscribedRef emptyFastWeak

359− unsubscribe $ _cacheSubscribed_parent subscribed

360− touch ticket

361− touch subscribedTicket

362− , _eventSubscription_subscribed = EventSubscribed

363− { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed

364− , eventSubscribedRetained = toAny subscribedTicket

365− }

366− }

367− 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+

368412

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

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

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

376420 let es = tag subd

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

378422

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

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

381425

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

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

428+

382429eventNever :: Event x a

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

430+eventNever = Event $ const subscribeAndReadNever

384431

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

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

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

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

418465 }

419466

420−--TODO: Move this comment to WeakBag

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

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

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

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

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

426−--

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

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

429−

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

431468newSubscriberHold h = return $ Subscriber

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

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

435472 }

436473

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

438−newSubscriberFan subscribed = return $ Subscriber

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

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

440477 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed

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

442479 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a

443480 scheduleClear $ fanSubscribedOccurrence subscribed

444481 let f _ (Pair v subsubs) = do

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

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

448485 return ()

449486 , subscriberInvalidateHeight = \old -> do

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

451487 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

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

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

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

454489 , subscriberRecalculateHeight = \new -> do

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

456490 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

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

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

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

459492 }

460493

461494newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)

462−newSubscriberSwitch subscribed = return $ Subscriber

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

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

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

465497 liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a

466498 scheduleClear $ switchSubscribedOccurrence subscribed

467499 propagate a $ switchSubscribedSubscribers subscribed

468500 , subscriberInvalidateHeight = \_ -> do

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

470501 oldHeight <- readIORef $ switchSubscribedHeight subscribed

471502 when (oldHeight /= invalidHeight) $ do

472503 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight

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

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

475− , subscriberRecalculateHeight = \new -> do

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

477− updateSwitchHeight new subscribed

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

479− }

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

505+ , subscriberRecalculateHeight = (`updateSwitchHeight` subscribed)

506+ }

480507

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

482−newSubscriberCoincidenceOuter subscribed = return $ Subscriber

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

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

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

485511 outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed

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

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

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

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

516+

490517 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd

491518 scheduleClear $ coincidenceSubscribedInnerParent subscribed

492519 case occ of

493− Nothing -> do

520+ Nothing ->

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

495522 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight

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

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

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

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

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

499526 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ

500527 scheduleClear $ coincidenceSubscribedOccurrence subscribed

501528 propagate o $ coincidenceSubscribedSubscribers subscribed

502− , subscriberInvalidateHeight = \_ -> do

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

504− invalidateCoincidenceHeight subscribed

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

506− , subscriberRecalculateHeight = \_ -> do

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

508− recalculateCoincidenceHeight subscribed

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

529+ , subscriberInvalidateHeight = \_ -> invalidateCoincidenceHeight subscribed

530+ , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed

510531 }

511532

512533newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)

513−newSubscriberCoincidenceInner subscribed = return $ Subscriber

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

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

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

516536 occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed

517537 case occ of

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

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

520540 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a

521541 scheduleClear $ coincidenceSubscribedOccurrence subscribed

522542 propagate a $ coincidenceSubscribedSubscribers subscribed

523− , subscriberInvalidateHeight = \_ -> do

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

525− invalidateCoincidenceHeight subscribed

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

527− , subscriberRecalculateHeight = \_ -> do

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

529− recalculateCoincidenceHeight subscribed

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

543+ , subscriberInvalidateHeight = \_ -> invalidateCoincidenceHeight subscribed

544+ , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed

531545 }

532546

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

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

537551recalculateSubscriberHeight = flip subscriberRecalculateHeight

538552

539553-- | Propagate everything at the current height

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

541−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) $

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

543557 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work

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

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

545559

546560-- | Propagate everything at the current height

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

548−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) $

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

550564 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work

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

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

552566

553567--------------------------------------------------------------------------------

554568-- EventSubscribed

@@ -566,7 +580,7 @@ data EventSubscribed x = EventSubscribed

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

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

568582#ifdef DEBUG_CYCLES

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

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

570584 , eventSubscribedHasOwnHeightRef :: !Bool

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

572586#endif

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

593607 , eventSubscribedWhoCreated = return ["never"]

594608#endif

595609 }

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

596620

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

598622eventSubscribedFan !subscribed = EventSubscribed

599623 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed

600624 , eventSubscribedRetained = toAny subscribed

601625#ifdef DEBUG_CYCLES

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

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

603627 , eventSubscribedHasOwnHeightRef = False

604628 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed

605629#endif

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

612636#ifdef DEBUG_CYCLES

613637 , eventSubscribedGetParents = do

614638 s <- readIORef $ switchSubscribedCurrentParent subscribed

615− return [Some $ _eventSubscription_subscribed s]

639+ return [_eventSubscription_subscribed s]

616640 , eventSubscribedHasOwnHeightRef = True

617641 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed

618642#endif

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

625649#ifdef DEBUG_CYCLES

626650 , eventSubscribedGetParents = do

627651 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed

628− let outerParent = Some $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed

629− innerParents = maybeToList $ fmap Some innerSubscription

652+ let outerParent = _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed

653+ innerParents = maybeToList $ innerSubscription

630654 return $ outerParent : innerParents

631655 , eventSubscribedHasOwnHeightRef = True

632656 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed

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

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

641665whoCreatedEventSubscribed = eventSubscribedWhoCreated

642666

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

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

644668walkInvalidHeightParents s0 = do

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

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

646670 h <- liftIO $ readIORef $ eventSubscribedHeightRef s

647671 when (h == invalidHeight) $ do

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

649− modify (Some s :)

673+ modify (s :)

650674 mapM_ loop =<< liftIO (eventSubscribedGetParents s)

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

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

652676 return subscribers

653677#endif

654678

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

970994 BehaviorM x >> BehaviorM y = BehaviorM $ x >> y

971995 {-# INLINE return #-}

972996 return x = BehaviorM $ return x

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

973998 {-# INLINE fail #-}

974999 fail s = BehaviorM $ fail s

1000+#endif

9751001

9761002data BehaviorSubscribed x a

9771003 = forall p. BehaviorSubscribedHold (Hold x p)

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

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

10321058

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

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

10351061

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

10371063

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

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

10571083

10581084heightBagAdd :: Height -> HeightBag -> HeightBag

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

10601087

10611088heightBagRemove :: Height -> HeightBag -> HeightBag

10621089heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of

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

10651092 0 -> IntMap.delete h c

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

10671094

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+

10681102heightBagMax :: HeightBag -> Height

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

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

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

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

11661200 DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]

11671201

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

11691206 zip x y = mapMaybe justThese $ align x y

11701207#endif

11711208

@@ -1309,55 +1346,110 @@ mkWeakPtrWithDebug x debugNote = do

13091346 x' <- evaluate x

13101347 mkWeakPtr x' $

13111348 if debugFinalize

1312− then Just $ putStrLn $ "finalizing: " ++ debugNote

1349+ then Just $ debugStrLn $ "finalizing: " ++ debugNote

13131350 else Nothing

13141351

13151352type WeakList a = [Weak a]

13161353

1317−{-# INLINE withIncreasedDepth #-}

1354+type CanTrace x m = (HasSpiderTimeline x, MonadIO m)

1355+

1356+

1357+

1358+

13181359#ifdef DEBUG

1319−withIncreasedDepth :: CanTrace x m => m a -> m a

1320−withIncreasedDepth a = do

1321− spiderTimeline <- askSpiderTimelineEnv

1322− liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE 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

13231385 result <- a

1324− liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) pred

1386+ liftIO $ modifyIORef' (_spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)) pred

13251387 return result

1326−#else

1327−withIncreasedDepth :: m a -> m a

1328−withIncreasedDepth = id

1329−#endif

1330−

1331−type CanTrace x m = (HasSpiderTimeline x, MonadIO m)

13321388

13331389{-# INLINE tracePropagate #-}

13341390tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()

1335−tracePropagate p = traceWhen p debugPropagate

1391+tracePropagate p = when debugPropagate . trace p

13361392

13371393{-# INLINE traceInvalidate #-}

13381394traceInvalidate :: String -> IO ()

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

13401400

1341−{-# INLINE traceWhen #-}

1342−traceWhen :: (CanTrace x m) => proxy x -> Bool -> String -> m ()

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

13441404

1345−{-# INLINE traceMWhen #-}

1346−traceMWhen :: (CanTrace x m) => proxy x -> Bool -> m String -> m ()

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

13481408 message <- getMessage

1349−#ifdef DEBUG

1350− spiderTimeline <- askSpiderTimelineEnv

1351− d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE spiderTimeline

1409+ d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)

1410+ liftIO $ debugStrLn $ replicate d ' ' <> message

1411+

13521412#else

1353− 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+

13541448#endif

1355− liftIO $ putStrLn $ replicate d ' ' <> message

13561449

13571450whoCreatedIORef :: IORef a -> IO [String]

13581451whoCreatedIORef (IORef a) = whoCreated $! a

13591452

1360−#ifdef DEBUG_CYCLES

13611453groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]

13621454groupByHead = \case

13631455 [] -> []

@@ -1368,20 +1460,54 @@ groupByHead = \case

13681460 | otherwise -> (x, xs :| []) : l

13691461

13701462listsToForest :: Eq a => [[a]] -> Forest a

1371−listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l

1463+listsToForest lists = buildForest <$> groupByHead (mapMaybe nonEmpty lists)

1464+ where buildForest (a, lists') = Node a $ listsToForest $ toList lists'

1465+

1466+showStacks :: [[String]] -> String

1467+showStacks = drawForest . listsToForest . fmap (filterStack "Reflex.Spider.Internal")

1468+

1469+filterStack :: String -> [String] -> [String]

1470+#ifdef DEBUG_HIDE_INTERNALS

1471+filterStack prefix = filter (not . (prefix `isPrefixOf`))

1472+#else

1473+filterStack prefix = id

1474+#endif

1475+

1476+#ifdef DEBUG_CYCLES

1477+

1478+data EventLoopException = EventLoopException [[String]]

1479+instance Exception EventLoopException

1480+

1481+instance Show EventLoopException where

1482+ show (EventLoopException stacks) = "causality loop detected:\n" <> if null stacks

1483+ then "no location information, compile with profiling enabled for stack tree"

1484+ else showStacks stacks

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+

13721495#endif

13731496

1497+

13741498{-# INLINE propagateSubscriberHold #-}

13751499propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()

13761500propagateSubscriberHold h a = do

1377− {-# SCC "trace" #-} traceMWhen (Proxy :: Proxy x) debugPropagate $ liftIO $ do

1501+ {-# SCC "trace" #-} when debugPropagate $ traceM (Proxy :: Proxy x) $ liftIO $ do

13781502 invalidators <- liftIO $ readIORef $ holdInvalidators h

13791503 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)

1504+

13801505 v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h

13811506 case {-# SCC "apply" #-} apply a v of

13821507 Nothing -> return ()

13831508 Just v' -> do

1384− {-# 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)

13851511 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h

13861512 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h

13871513 defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'

@@ -1435,7 +1561,7 @@ getDynHold d = do

14351561zeroRef :: IORef Height

14361562zeroRef = unsafePerformIO $ newIORef zeroHeight

14371563

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

14391565getRootSubscribed k r sub = do

14401566 mSubscribed <- readIORef $ rootSubscribed r

14411567 let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r

@@ -1449,7 +1575,9 @@ getRootSubscribed k r sub = do

14491575 let !cached = rootSubscribed r

14501576 uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"

14511577 (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed

1452− when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"

1578+

1579+ tracePropagate (Proxy::Proxy x) $ "getRootSubscribed: calling rootInit"

1580+

14531581 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)

14541582 writeIORef uninitRef $! uninit

14551583#ifdef DEBUG_NODEIDS

@@ -1499,6 +1627,9 @@ data FanInt x a = FanInt

14991627 { _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

15001628 , _fanInt_subscriptionRef :: {-# UNPACK #-} !(IORef (EventSubscription x)) -- This should have a valid subscription iff subscribers is non-empty

15011629 , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a))

1630+#ifdef DEBUG_NODEIDS

1631+ , _fanInt_nodeId :: {-# UNPACK #-} !Int

1632+#endif

15021633 }

15031634

15041635newFanInt :: IO (FanInt x a)

@@ -1506,33 +1637,39 @@ newFanInt = do

15061637 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

15071638 subscriptionRef <- newIORef $ error "fanInt: no subscription"

15081639 occRef <- newIORef $ error "fanInt: no occurrence"

1640+#ifdef DEBUG_NODEIDS

1641+ nodeId <- newNodeId

1642+#endif

15091643 return $ FanInt

15101644 { _fanInt_subscribers = subscribers

15111645 , _fanInt_subscriptionRef = subscriptionRef

15121646 , _fanInt_occRef = occRef

1647+#ifdef DEBUG_NODEIDS

1648+ , _fanInt_nodeId = nodeId

1649+#endif

15131650 }

15141651

15151652fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a

15161653fanInt p = unsafePerformIO $ do

15171654 self <- newFanInt

1518− pure $ EventSelectorInt $ \k -> trace ("select " <> show k) $ Event $ \sub -> do

1655+ pure $ EventSelectorInt $ \k -> Event $ \sub -> do

15191656 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)

15201657 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input

1521− (subscription, parentOcc) <- subscribeAndRead p $ Subscriber

1658+ let desc = "fanInt" <> showNodeId self <> ", k = " <> show k

1659+ (subscription, parentOcc) <- subscribeAndRead p $ debugSubscriber' desc $ Subscriber

15221660 { subscriberPropagate = \m -> do

15231661 liftIO $ writeIORef (_fanInt_occRef self) m

15241662 scheduleIntClear $ _fanInt_occRef self

1525− liftIO $ putStrLn $ "Pushing " <> show (IntMap.size m) <> " occurrences"

1526− FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> do --TODO: Do we need to know that no subscribers are being added as we traverse?

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

15281665 subscriberPropagate s v

1529− , subscriberInvalidateHeight = \old -> do

1530− FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do

1531− FastWeakBag.traverse b $ \s -> do

1666+ , subscriberInvalidateHeight = \old ->

1667+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->

1668+ FastWeakBag.traverse_ b $ \s ->

15321669 subscriberInvalidateHeight s old

1533− , subscriberRecalculateHeight = \new -> do

1534− FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do

1535− FastWeakBag.traverse b $ \s -> do

1670+ , subscriberRecalculateHeight = \new ->

1671+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->

1672+ FastWeakBag.traverse_ b $ \s ->

15361673 subscriberRecalculateHeight s new

15371674 }

15381675 liftIO $ do

@@ -1546,10 +1683,25 @@ fanInt p = unsafePerformIO $ do

15461683 FastMutableIntMap.insert (_fanInt_subscribers self) k b

15471684 return b

15481685 Just b -> return b

1549− t <- liftIO $ FastWeakBag.insert sub b

1686+ ticket <- liftIO $ FastWeakBag.insert sub b

15501687 currentOcc <- readIORef (_fanInt_occRef self)

1551− (EventSubscription _ (EventSubscribed !heightRef _)) <- readIORef (_fanInt_subscriptionRef self)

1552− 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+

15531705

15541706{-# INLINABLE getFanSubscribed #-}

15551707getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k v -> Subscriber x (v a) -> EventM x (WeakBagTicket, FanSubscribed x k v, Maybe (v a))

@@ -1747,7 +1899,7 @@ mergeCheap

17471899 => (forall a. q a -> Event x (v a))

17481900 -> DynamicS x (PatchDMap k q)

17491901 -> Event x (DMap k v)

1750−mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy

1902+mergeCheap nt = mergeGCheap' unMergeSubscribedParent getInitialSubscribers updateMe destroy

17511903 where

17521904 updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)

17531905 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do

@@ -1762,7 +1914,9 @@ mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy

17621914 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight

17631915 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps

17641916 forM_ mOldSubd $ \oldSubd -> do

1765− oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd

1917+ oldHeight <- liftIO $ getEventSubscribedHeight $

1918+ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd

1919+

17661920 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

17671921 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)

17681922 foldM f ([], oldParents) $ DMap.toList p

@@ -1787,7 +1941,7 @@ mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)

17871941 => (forall a. q a -> Event x (v a))

17881942 -> DynamicS x (PatchDMapWithMove k q)

17891943 -> Event x (DMap k v)

1790−mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy

1944+mergeCheapWithMove nt = mergeGCheap' _mergeSubscribedParentWithMove_subscription getInitialSubscribers updateMe destroy

17911945 where

17921946 updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)

17931947 updateMe subscriber heightBagRef oldParents p = do

@@ -1806,13 +1960,17 @@ mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy

18061960 let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a

18071961 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of

18081962 Nothing -> do

1809− oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent

1963+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $

1964+ _mergeSubscribedParentWithMove_subscription parent

1965+

18101966 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

18111967 return $ Just $ _mergeSubscribedParentWithMove_subscription parent

18121968 Just toKey -> do

18131969 liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey

18141970 return Nothing

1815− 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+

18161974 return (toDelete, applyAlways p' oldParents)

18171975 getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)

18181976 getInitialSubscribers initialParents subscriber = do

@@ -1837,6 +1995,8 @@ type MergeUpdateFunc k v x p s

18371995 -> p

18381996 -> EventM x ([EventSubscription x], DMap k s)

18391997

1998+type MergeGetSubscription x s = forall a. s a -> EventSubscription x

1999+

18402000type MergeInitFunc k v q x s

18412001 = DMap k q

18422002 -> (forall a. EventM x (k a) -> Subscriber x (v a))

@@ -1860,14 +2020,17 @@ invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_su

18602020invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()

18612021invalidateMergeHeight' heightRef sub = do

18622022 oldHeight <- readIORef heightRef

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

18642025 writeIORef heightRef $! invalidHeight

18652026 subscriberInvalidateHeight sub oldHeight

18662027

18672028revalidateMergeHeight :: Merge x k v s -> IO ()

18682029revalidateMergeHeight m = do

18692030 currentHeight <- readIORef $ _merge_heightRef m

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

18712034 heights <- readIORef $ _merge_heightBagRef m

18722035 parents <- readIORef $ _merge_parentsRef m

18732036 -- When the number of heights in the bag reaches the number of parents, we should have a valid height

@@ -1875,7 +2038,7 @@ revalidateMergeHeight m = do

18752038 LT -> return ()

18762039 EQ -> do

18772040 let height = succHeight $ heightBagMax heights

1878− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height

2041+ traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height

18792042 writeIORef (_merge_heightRef m) $! height

18802043 subscriberRecalculateHeight (_merge_sub m) height

18812044 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"

@@ -1883,36 +2046,45 @@ revalidateMergeHeight m = do

18832046scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()

18842047scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do

18852048 vals <- liftIO $ readIORef $ _merge_accumRef m

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

18872052 --TODO: Assert that m is not empty

18882053 subscriberPropagate (_merge_sub m) vals

18892054

1890−mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => Merge x k v s -> EventM x (k a) -> Subscriber x (v a)

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

18922078 { subscriberPropagate = \a -> do

18932079 oldM <- liftIO $ readIORef $ _merge_accumRef m

18942080 k <- getKey

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

18962082 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)

18972083 liftIO $ writeIORef (_merge_accumRef m) $! newM

18982084 when (DMap.null oldM) $ do -- Only schedule the firing once

18992085 height <- liftIO $ readIORef $ _merge_heightRef m

1900− --TODO: assertions about height

1901− currentHeight <- getCurrentHeight

1902− when (height <= currentHeight) $ do

1903− if height /= invalidHeight

1904− then do

1905− myStack <- liftIO $ whoCreatedIORef undefined --TODO

1906− error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)

1907− else liftIO $ do

1908−#ifdef DEBUG_CYCLES

1909− nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed

1910− stacks <- forM nodesInvolvedInCycle $ \(Some es) -> whoCreatedEventSubscribed es

1911− let cycleInfo = ":\n" <> drawForest (listsToForest stacks)

1912−#else

1913− let cycleInfo = ""

1914−#endif

1915− error $ "Causality loop found" <> cycleInfo

2086+ checkCycle subscribed

2087+

19162088 scheduleMergeSelf m height

19172089 , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating

19182090 modifyIORef' (_merge_heightBagRef m) $ heightBagRemove old

@@ -1923,31 +2095,45 @@ mergeSubscriber m getKey = Subscriber

19232095 }

19242096

19252097--TODO: Be able to run as much of this as possible promptly

1926−updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x

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

19282100 where updateMe = do

19292101 oldParents <- liftIO $ readIORef $ _merge_parentsRef m

1930− (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber m) (_merge_heightBagRef m) oldParents p

2102+ (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber subscribed m) (_merge_heightBagRef m) oldParents p

19312103 liftIO $ writeIORef (_merge_parentsRef m) $! newParents

19322104 return subscriptionsToKill

19332105

19342106{-# INLINE mergeGCheap' #-}

19352107mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)

1936− => MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> DynamicS x p -> Event x (DMap k v)

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

19382110 initialParents <- readBehaviorUntracked $ dynamicCurrent d

19392111 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"

19402112 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"

19412113 heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"

19422114 parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"

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

19442130 { _merge_parentsRef = parentsRef

19452131 , _merge_heightBagRef = heightBagRef

19462132 , _merge_heightRef = heightRef

19472133 , _merge_sub = sub

19482134 , _merge_accumRef = accumRef

19492135 }

1950− (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber m

2136+ (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber subscribed m

19512137 let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights

19522138 myHeight = if invalidHeight `elem` heights

19532139 then invalidHeight

@@ -1956,31 +2142,29 @@ mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do

19562142 let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now

19572143 then (if DMap.null dm then Nothing else Just dm, DMap.empty)

19582144 else (Nothing, dm)

1959− unless (DMap.null accum) $ do

1960− scheduleMergeSelf m myHeight

2145+ unless (DMap.null accum) $ scheduleMergeSelf m myHeight

19612146 liftIO $ writeIORef accumRef $! accum

19622147 liftIO $ writeIORef heightRef $! myHeight

19632148 liftIO $ writeIORef heightBagRef $! myHeightBag

1964− changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"

19652149 liftIO $ writeIORef parentsRef $! initialParentState

19662150 defer $ SomeMergeInit $ do

1967− let s = Subscriber

2151+ let changeSubscriber = Subscriber

19682152 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

1969− tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change"

1970− defer $ updateMerge m updateFunc a

2153+ tracePropagate (Proxy :: Proxy x) "SubscriberMerge/Change"

2154+ defer $ updateMerge subscribed m updateFunc a

19712155 , subscriberInvalidateHeight = \_ -> return ()

19722156 , subscriberRecalculateHeight = \_ -> return ()

19732157 }

1974− (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s

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

19762160 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.

19772161 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain

19782162 -- its subscription.

1979− liftIO $ writeIORef changeSubdRef (s, changeSubscription)

2163+ liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)

19802164 let unsubscribeAll = destroy =<< readIORef parentsRef

1981− return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parentsRef, changeSubdRef)

1982− , occ

1983− )

2165+

2166+ return (EventSubscription unsubscribeAll subscribed, occ)

2167+

19842168

19852169mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)

19862170mergeInt = cacheEvent . mergeIntCheap

@@ -1993,13 +2177,22 @@ mergeIntCheap d = Event $ \sub -> do

19932177 heightRef <- liftIO $ newIORef zeroHeight

19942178 heightBagRef <- liftIO $ newIORef heightBagEmpty

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

19962190 let scheduleSelf = do

19972191 height <- liftIO $ readIORef $ heightRef

19982192 scheduleMerge' height heightRef $ do

19992193 vals <- liftIO $ FastMutableIntMap.getFrozenAndClear accum

20002194 subscriberPropagate sub vals

2001− invalidateMyHeight = do

2002− invalidateMergeHeight' heightRef sub

2195+ invalidateMyHeight = invalidateMergeHeight' heightRef sub

20032196 recalculateMyHeight = do

20042197 currentHeight <- readIORef heightRef

20052198 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?

@@ -2009,12 +2202,14 @@ mergeIntCheap d = Event $ \sub -> do

20092202 LT -> return ()

20102203 EQ -> do

20112204 let height = succHeight $ heightBagMax heights

2012− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height

2205+ traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height

20132206 writeIORef heightRef $! height

20142207 subscriberRecalculateHeight sub height

20152208 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"

20162209 mySubscriber k = Subscriber

20172210 { subscriberPropagate = \a -> do

2211+ checkCycle subscribed

2212+

20182213 wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum

20192214 liftIO $ FastMutableIntMap.insert accum k a

20202215 when wasEmpty scheduleSelf

@@ -2048,7 +2243,6 @@ mergeIntCheap d = Event $ \sub -> do

20482243 else liftIO $ Just <$> FastMutableIntMap.getFrozenAndClear accum

20492244 else do when (not isEmpty) scheduleSelf -- We have things accumulated, but we shouldn't have fired them yet

20502245 return Nothing

2051− changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"

20522246 defer $ SomeMergeInit $ do

20532247 let updateMe a = SomeMergeUpdate u invalidateMyHeight recalculateMyHeight

20542248 where

@@ -2062,25 +2256,27 @@ mergeIntCheap d = Event $ \sub -> do

20622256 oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions

20632257 liftIO $ for_ oldParents $ \oldParent -> do

20642258 oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent

2259+

2260+ print ("updateMe", oldParentHeight)

20652261 modifyIORef' heightBagRef $ heightBagRemove oldParentHeight

20662262 return $ IntMap.elems oldParents

2067− let s = Subscriber

2263+ let changeSubscriber = Subscriber

20682264 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

20692265 tracePropagate (Proxy :: Proxy x) $ "SubscriberMergeInt/Change"

20702266 defer $ updateMe a

20712267 , subscriberInvalidateHeight = \_ -> return ()

20722268 , subscriberRecalculateHeight = \_ -> return ()

20732269 }

2074− (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s

2270+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) changeSubscriber

20752271 forM_ change $ \c -> defer $ updateMe c

20762272 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.

20772273 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain

20782274 -- its subscription.

2079− liftIO $ writeIORef changeSubdRef (s, changeSubscription)

2275+ liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)

20802276 let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents

2081− return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parents, changeSubdRef)

2082− , occ

2083− )

2277+

2278+

2279+ return (EventSubscription unsubscribeAll subscribed, occ)

20842280

20852281newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }

20862282newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) }

@@ -2163,19 +2359,19 @@ runFrame a = SpiderHost $ do

21632359 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env

21642360 forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do

21652361 writeIORef vRef v

2166− when debugInvalidate $ putStrLn $ "Invalidating Hold"

2362+ traceInvalidate $ "Invalidating Hold"

21672363 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef

21682364 mergeUpdates <- readIORef $ eventEnvMergeUpdates env

21692365 writeIORef (eventEnvMergeUpdates env) []

2170− when debugPropagate $ putStrLn "Updating merges"

2366+ tracePropagate (Proxy::Proxy x) $ "Updating merges"

21712367 mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates

2172− when debugPropagate $ putStrLn "Updating merges done"

2368+ tracePropagate (Proxy::Proxy x) $ "Updating merges done"

21732369 toReconnect <- readIORef toReconnectRef

21742370 clearEventEnv env

21752371 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do

21762372 oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed

21772373 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed

2178− when debugInvalidate $ putStrLn $ "Finalizing invalidator for Switch" <> showNodeId subscribed

2374+ traceInvalidate $ "Finalizing invalidator for Switch" <> showNodeId subscribed

21792375 finalize wi

21802376 i <- evaluate $ switchSubscribedOwnInvalidator subscribed

21812377 wi' <- mkWeakPtrWithDebug i "wi'"

@@ -2189,7 +2385,7 @@ runFrame a = SpiderHost $ do

21892385 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

21902386 {-

21912387 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)

2192− liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of

2388+ liftIO $ debugStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of

21932389 EventRoot _ -> "EventRoot"

21942390 EventNever -> "EventNever"

21952391 _ -> "something else"

@@ -2204,7 +2400,7 @@ runFrame a = SpiderHost $ do

22042400 myHeight <- readIORef $ switchSubscribedHeight subscribed

22052401 when (parentHeight /= myHeight) $ do

22062402 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight

2207− WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight

2403+ WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight

22082404 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

22092405 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do

22102406 unsubscribe subscription

@@ -2245,7 +2441,7 @@ invalidateCoincidenceHeight subscribed = do

22452441 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed

22462442 when (oldHeight /= invalidHeight) $ do

22472443 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight

2248− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

2444+ WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

22492445

22502446updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()

22512447updateSwitchHeight new subscribed = do

@@ -2253,7 +2449,7 @@ updateSwitchHeight new subscribed = do

22532449 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion

22542450 when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion

22552451 writeIORef (switchSubscribedHeight subscribed) $! new

2256− WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new

2452+ WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new

22572453

22582454recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()

22592455recalculateCoincidenceHeight subscribed = do

@@ -2262,7 +2458,7 @@ recalculateCoincidenceHeight subscribed = do

22622458 height <- calculateCoincidenceHeight subscribed

22632459 when (height /= invalidHeight) $ do

22642460 writeIORef (coincidenceSubscribedHeight subscribed) $! height

2265− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height

2461+ WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height

22662462

22672463calculateSwitchHeight :: SwitchSubscribed x a -> IO Height

22682464calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)

@@ -2324,6 +2520,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Event

23242520 {-# INLINABLE headE #-}

23252521 headE = R.slowHeadE

23262522-- headE (SpiderEvent e) = SpiderEvent <$> Reflex.Spider.Internal.headE e

2523+ {-# INLINABLE now #-}

2524+ now = nowSpiderEventM

23272525

23282526instance Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where

23292527 {-# INLINABLE sample #-}

@@ -2345,6 +2543,9 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide

23452543 {-# INLINABLE headE #-}

23462544 headE = R.slowHeadE

23472545-- headE (SpiderEvent e) = SpiderPushM $ SpiderEvent <$> Reflex.Spider.Internal.headE e

2546+ {-# INLINABLE now #-}

2547+ now = SpiderPushM nowSpiderEventM

2548+

23482549

23492550instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where

23502551 {-# INLINE return #-}

@@ -2353,8 +2554,10 @@ instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x))

23532554 x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x

23542555 {-# INLINE (>>) #-}

23552556 (>>) = (*>)

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

23562558 {-# INLINE fail #-}

23572559 fail _ = error "Dynamic does not support 'fail'"

2560+#endif

23582561

23592562{-# INLINABLE newJoinDyn #-}

23602563newJoinDyn :: HasSpiderTimeline x => DynamicS x (Identity (DynamicS x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)

@@ -2406,6 +2609,9 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide

24062609 buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e

24072610 {-# INLINABLE headE #-}

24082611 headE e = runFrame . runSpiderHostFrame $ Reflex.Class.headE e

2612+ {-# INLINABLE now #-}

2613+ now = runFrame . runSpiderHostFrame $ Reflex.Class.now

2614+

24092615

24102616instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where

24112617 sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can

@@ -2422,6 +2628,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide

24222628 {-# INLINABLE headE #-}

24232629 headE = R.slowHeadE

24242630-- headE (SpiderEvent e) = SpiderHostFrame $ SpiderEvent <$> Reflex.Spider.Internal.headE e

2631+ {-# INLINABLE now #-}

2632+ now = SpiderHostFrame Reflex.Class.now

24252633

24262634instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where

24272635 {-# INLINABLE sample #-}

@@ -2442,6 +2650,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Refle

24422650 buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e

24432651 {-# INLINABLE headE #-}

24442652 headE e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.headE e

2653+ {-# INLINABLE now #-}

2654+ now = Reflex.Spider.Internal.ReadPhase Reflex.Class.now

24452655

24462656--------------------------------------------------------------------------------

24472657-- Deprecated items

@@ -2479,13 +2689,13 @@ instance HasSpiderTimeline x => Reflex.Host.Class.MonadReadEvent (SpiderTimeline

24792689 touch h

24802690 return result

24812691

2482−instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where

2692+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where

24832693 newEventWithTrigger = SpiderHost . fmap SpiderEvent . newEventWithTriggerIO

24842694 newFanEventWithTrigger f = SpiderHost $ do

24852695 es <- newFanEventWithTriggerIO f

24862696 return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es

24872697

2488−instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where

2698+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where

24892699 newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO

24902700 newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do

24912701 es <- newFanEventWithTriggerIO f

@@ -2565,7 +2775,7 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

25652775 fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))

25662776 {-# INLINABLE mergeG #-}

25672777 mergeG

2568− :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k

2778+ :: forall k2 (k :: k2 -> *) q (v :: k2 -> *). GCompare k

25692779 => (forall a. q a -> R.Event (SpiderTimeline x) (v a))

25702780 -> DMap k q

25712781 -> R.Event (SpiderTimeline x) (DMap k v)

@@ -2633,8 +2843,14 @@ instance Monad (SpiderHost x) where

26332843 SpiderHost x >> SpiderHost y = SpiderHost $ x >> y

26342844 {-# INLINABLE return #-}

26352845 return x = SpiderHost $ return x

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

26362847 {-# INLINABLE fail #-}

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

26382854

26392855-- | Run an action affecting the global Spider timeline; this will be guarded by

26402856-- a mutex for that timeline

@@ -2656,19 +2872,21 @@ instance Monad (SpiderHostFrame x) where

26562872 SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y

26572873 {-# INLINABLE return #-}

26582874 return x = SpiderHostFrame $ return x

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

26592876 {-# INLINABLE fail #-}

26602877 fail s = SpiderHostFrame $ fail s

2878+#endif

26612879

26622880instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where

26632881 notReadyUntil _ = pure ()

26642882 notReady = pure ()

26652883

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

26672885newEventWithTriggerIO f = do

26682886 es <- newFanEventWithTriggerIO $ \Refl -> f

26692887 return $ select es Refl

26702888

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

26722890newFanEventWithTriggerIO f = do

26732891 occRef <- newIORef DMap.empty

26742892 subscribedRef <- newIORef DMap.empty

@@ -2702,3 +2920,11 @@ instance MonadAtomicRef (SpiderHostFrame x) where

27022920instance PrimMonad (SpiderHostFrame x) where

27032921 type PrimState (SpiderHostFrame x) = PrimState IO

27042922 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

@@ -12,6 +12,7 @@ import Reflex.Class

1212import Control.Monad.Reader

1313import Control.Monad.State

1414import qualified Control.Monad.State.Strict as Strict

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

1516

1617--TODO: Shouldn't have IO hard-coded

1718-- | 'TriggerEvent' represents actions that can create 'Event's that can be

@@ -47,3 +48,8 @@ instance TriggerEvent t m => TriggerEvent t (Strict.StateT s m) where

4748 newTriggerEvent = lift newTriggerEvent

4849 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

4950 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/EventWriterT.hs+11−15

@@ -24,30 +24,26 @@ import Test.Run

2424

2525main :: IO ()

2626main = do

27− os1 <- runApp' (unwrapApp testOrdering) $

27+ os1@[[Just [10,9,8,7,6,5,4,3,2,1]]] <- runApp' (unwrapApp testOrdering) $

2828 [ Just ()

2929 ]

3030 print os1

31− os2 <- runApp' (unwrapApp testSimultaneous) $ map Just $

32− [ This ()

33− , That ()

34− , This ()

35− , These () ()

36− ]

31+ os2@[[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]]

32+ <- runApp' (unwrapApp testSimultaneous) $ map Just $

33+ [ This ()

34+ , That ()

35+ , This ()

36+ , These () ()

37+ ]

3738 print os2

38− os3 <- runApp' (unwrapApp testMoribundTellEvent) [Just ()]

39+ os3@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEvent) [Just ()]

3940 print os3

40− os4 <- runApp' (unwrapApp testMoribundTellEventDMap) [Just ()]

41+ os4@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEventDMap) [Just ()]

4142 print os4

42− os5 <- runApp' (unwrapApp testLiveTellEventDMap) [Just ()]

43+ os5@[[Nothing, Just [1, 2]]] <- runApp' (unwrapApp testLiveTellEventDMap) [Just ()]

4344 print os5

4445 os6 <- runApp' (unwrapApp delayedPulse) [Just ()]

4546 print os6

46− let ![[Just [10,9,8,7,6,5,4,3,2,1]]] = os1

47− let ![[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]] = os2

48− let ![[Nothing, Just [2]]] = os3

49− let ![[Nothing, Just [2]]] = os4

50− let ![[Nothing, Just [1, 2]]] = os5

5147 let ![[Nothing, Nothing]] = os6

5248 return ()

5349

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+1−1

@@ -134,7 +134,7 @@ holdDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynami

134134holdDynChain = iterM (\d -> sample (current d) >>= flip holdDyn (updated d))

135135

136136buildDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

137−buildDynChain = iterM (\d -> do

137+buildDynChain = iterM (\d -> do

138138 let b = fmap (+1) (current d)

139139 e = fmap (*2) (updated d)

140140 buildDynamic (sample b) e)

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+13−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))

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+89−33

@@ -1,22 +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

13−import Control.Monad.Primitive

18+import Control.Monad.IO.Class (MonadIO)

19+import Data.Constraint.Extras

20+import Data.Constraint.Extras.TH

21+import Data.Constraint.Forall

1422import qualified Data.Dependent.Map as DMap

1523import Data.Dependent.Sum

1624import Data.Functor.Misc

25+import Data.List (words)

26+import Data.Map (Map)

1727import qualified Data.Map as M

28+#if !MIN_VERSION_these(4,11,0)

29+import Data.Semigroup ((<>))

30+#endif

31+import Data.Text (Text)

1832import Data.These

19−import Data.Foldable

33+import Text.Read (readMaybe)

2034

2135#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))

2236import Data.These.Lens

@@ -32,46 +46,50 @@ data RequestInt a where

3246

3347main :: IO ()

3448main = do

35−-- os1 <- runApp' (unwrapApp testOrdering) $

36−-- [ Just ()

37−-- ]

38−-- print os1

39−-- os2 <- runApp' (unwrapApp testSimultaneous) $ map Just $

40−-- [ This ()

41−-- , That ()

42−-- , This ()

43−-- , These () ()

44−-- ]

45−-- print os2

46−-- os3 <- runApp' (unwrapApp testMoribundRequest) [Just ()]

47−-- print os3

49+ os1 <- runApp' (unwrapApp testOrdering) $

50+ [ Just ()

51+ ]

52+ print os1

53+ os2 <- runApp' (unwrapApp testSimultaneous) $ map Just $

54+ [ This ()

55+ , That ()

56+ , This ()

57+ , These () ()

58+ ]

59+ print os2

60+ os3 <- runApp' (unwrapApp testMoribundRequest) [Just ()]

61+ print os3

4862 os4 <- runApp' (unwrapApp testMoribundRequestDMap) [Just ()]

4963 print os4

50−-- os5 <- runApp' (unwrapApp testLiveRequestDMap) [Just ()]

51−-- print os5

52−-- os6 <- runApp' (unwrapApp delayedPulse) [Just ()]

53−-- print os6

54−-- let ![[Just [10,9,8,7,6,5,4,3,2,1]]] = os1

55−-- let ![[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]] = os2

56−-- let ![[Nothing, Just [2]]] = os3

64+ os5 <- runApp' (unwrapApp testLiveRequestDMap) [Just ()]

65+ print os5

66+ os6 <- runApp' (unwrapApp delayedPulse) [Just ()]

67+ print os6

68+ os7 <- runApp' testMatchRequestsWithResponses [ Just $ TestRequest_Increment 1 ]

69+ print os7

70+ os8 <- runApp' testMatchRequestsWithResponses [ Just $ TestRequest_Reverse "yoyo" ]

71+ print os8

72+ let ![[Just [1,2,3,4,5,6,7,8,9,10]]] = os1 -- The order is reversed here: see the documentation for 'runRequesterT'

73+ let ![[Just [9,7,5,3,1]],[Nothing,Nothing],[Just [10,8,6,4,2]],[Just [10,8,6,4,2],Nothing]] = os2

74+ let ![[Nothing, Just [2]]] = os3

5775 let ![[Nothing, Just [2]]] = os4

58−-- let ![[Nothing, Just [1, 2]]] = os5

76+ let ![[Nothing, Just [1, 2]]] = os5

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

6081 return ()

6182

62−unwrapApp :: forall t m a.

63− ( Reflex t

64− , MonadFix m

65− , PrimMonad m

66− )

83+unwrapRequest :: DSum tag RequestInt -> Int

84+unwrapRequest (_ :=> RequestInt i) = i

85+

86+unwrapApp :: ( Reflex t, Monad m )

6787 => (a -> RequesterT t RequestInt Identity m ())

6888 -> a

6989 -> m (Event t [Int])

7090unwrapApp x appIn = do

7191 ((), e) <- runRequesterT (x appIn) never

72− let unwrapRequests :: forall x. RequestData (PrimState m) RequestInt -> [Int]

73− unwrapRequests (RequestData _ es) = fmap (\(RequestEnvelope _ (RequestInt i)) -> i) $ toList es

74− return $ fmap unwrapRequests e

92+ return $ fmap (map unwrapRequest . requesterDataToList) e

7593

7694testOrdering :: ( Response m ~ Identity

7795 , Request m ~ RequestInt

@@ -177,3 +195,41 @@ delayedPulse pulse = void $ flip runWithReplace (pure () <$ pulse) $ do

177195 -- This has the effect of delaying pulse' from pulse

178196 (_, pulse') <- runWithReplace (pure ()) $ pure (RequestInt 1) <$ pulse

179197 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− ]