f61a68d · patch · git.iko.soy

git.iko.soy/patch

on develop help sign in

Merge branch 'develop' into no-hlint-exceptions

f61a68dJohn Ericson7 years ago

.travis.ymlnew file+171

compare with develop

unifiedsplit

@@ -0,0 +1,171 @@

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

CONTRIBUTING.md+9

@@ -5,6 +5,7 @@ Contributions and issue reports are encouraged and appreciated!

5- [Opening Issues](#opening-issues)

6- [Submitting Changes](#submitting-changes)

7 - [Guidelines for Commit Messages](#guidelines-for-commit-messages)

8+ - [Guidelines for Pull Requests](#guidelines-for-pull-requests)

8 - [Code Quality](#code-quality)

9 - [Code Quality](#code-quality)

9 - [Documentation](#documentation)

10 - [Documentation](#documentation)

@@ -30,6 +31,10 @@ One way to think about it is that your commit message should be able to complete

30#### Body

31#### Body

31For breaking changes, new features, refactors, or other major changes, the body of the commit message should describe the motivation behind the change in greater detail and may include references to the issue tracker. The body shouldn't repeat code/comments from the diff.

32For breaking changes, new features, refactors, or other major changes, the body of the commit message should describe the motivation behind the change in greater detail and may include references to the issue tracker. The body shouldn't repeat code/comments from the diff.

34+### Guidelines for Pull Requests

35+

36+Wherever possible, pull requests should add a single feature or fix a single bug. Pull requests should not bundle several unrelated changes.

37+

33### Code Quality

38### Code Quality

35#### Warnings

40#### Warnings

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

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

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

48+#### Dependencies

49+

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

51+

43### Documentation

52### Documentation

45#### In the code

54#### In the code

ChangeLog.md+60

@@ -2,20 +2,80 @@

3## Unreleased

5+* Data.WeakBag.traverse and Data.FastWeakBag.traverse have been

6+ renamed to Data.WeakBag.traverse_ and Data.FastWeakBag.traverse_

7+ respectively.

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

10+

11+* Add missing `NotReady` instances:

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

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

14+

15+## 0.6.2.4

16+

17+* Update to monoidal-containers 0.6

18+

19+## 0.6.2.3

20+

21+* Add an upper-bound to witherable

22+

23+## 0.6.2.2

24+

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

26+

27+* Update version bounds to fix some CI failures

28+

29+* Add travis CI configuration

30+

31+## 0.6.2.1

32+

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

34+ functor:

35+ * `fan` to `fanG`

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

37+

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

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

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

41+

42+* Generalize merging functions:

43+ `merge` to `mergeG`,

44+ `mergeIncremental` to `mergeIncrementalG`,

45+ `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`.

46+

47+* Generalize distribute function:

48+ `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`,

49+

50+## 0.6.2.0

51+

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

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

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

54+

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

56+

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

7## 0.6.1.0

59## 0.6.1.0

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

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

62+

10* Fix `QueryT` and `RequesterT` tests

63* Fix `QueryT` and `RequesterT` tests

12## 0.6.0.0 -- 2019-03-20

65## 0.6.0.0 -- 2019-03-20

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

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

68+

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

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

70+

16* Remove many deprecated functions.

71* Remove many deprecated functions.

72+

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

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

74+

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

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

76+

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

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

78+

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

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

80+

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

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

Quickref.md+14−11

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

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

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

200

201−Th typeclasses and their associated annotations include:

201+The typeclasses and their associated annotations include:

202

203- `PostBuild`

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

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

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

207 ```

208

209−- `Adjustable`

209+- `Adjustable`

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

211 ```haskell

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

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

271```haskell

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

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

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

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

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

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

277

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

295## Networks

296

297```haskell

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

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

299

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

301+

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

302+-- 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,

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

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

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

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

304

306

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

307+-- 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+-- Event fires. The returned Dynamic of network results occurs when the Event does. Note: Often, the type a is an

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

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

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

309

311

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

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

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

314+```

cabal.haskell-cinew file+16

@@ -0,0 +1,16 @@

1+distribution: xenial

2+benchmarks: False

3+unconstrained: False

4+installed: -all

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

7+install-dependencies: False

9+constraint-set no-th

10+ constraints: reflex -use-template-haskell

11+

12+constraint-set old-these

13+ constraints: these <1

14+

15+constraint-set old-witherable

16+ constraints: witherable <0.3.2

cabal.projectnew file+1

@@ -0,0 +1 @@

1+packages: .

cabal.project.freezenew file+1

@@ -0,0 +1 @@

1+constraints: any.text < 1.2.4.0

default.nixdeleted−39

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

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

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

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

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

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

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

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

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

9−, monoidal-containers, witherable

10−, useTemplateHaskell ? true

11−}:

12−mkDerivation {

13− pname = "reflex";

14− version = "0.6.1";

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

16− libraryHaskellDepends = [

17− base bifunctors containers dependent-map dependent-sum

18− exception-transformers lens

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

20− semigroups stm syb template-haskell these transformers

21− transformers-compat prim-uniq

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

23− mtl ref-tf split transformers data-default

24− random time unbounded-delays monoidal-containers witherable

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

26− ghcjs-base

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

28− haskell-src-exts haskell-src-meta

29− ]);

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

31− hlint filepath directory filemanip

32− ];

33− configureFlags = if useTemplateHaskell then [] else [

34− "-f-use-template-haskell"

35− ];

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

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

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

39−}

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": "e7b76dd552a10916c7d8702c11292dac4f4299ea",

6+ "sha256": "0s1183arrwldcs50qhzgnv94v24n9bgq6dfq64wp0a3q2nzyvgwh"

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+63−32

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

1Name: reflex

2−Version: 0.6.1

2+Version: 0.6.2.4

3Synopsis: Higher-order Functional Reactive Programming

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

5License: BSD3

@@ -17,6 +17,10 @@ extra-source-files:

17 Quickref.md

18 ChangeLog.md

20+tested-with:

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

22+ GHCJS ==8.4

23+

20flag use-reflex-optimizer

24flag use-reflex-optimizer

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

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

22 default: False

26 default: False

@@ -37,38 +41,50 @@ flag fast-weak

37 default: False

41 default: False

38 manual: True

42 manual: True

44+flag split-these

45+ description: Use split these/semialign packages

46+ manual: False

47+ default: True

48+

40library

49library

41 hs-source-dirs: src

50 hs-source-dirs: src

42 build-depends:

51 build-depends:

43 MemoTrie == 0.6.*,

52 MemoTrie == 0.6.*,

44 base >= 4.9 && < 4.13,

53 base >= 4.9 && < 4.13,

45 bifunctors >= 5.2 && < 5.6,

54 bifunctors >= 5.2 && < 5.6,

46− comonad,

55+ comonad >= 5.0.4 && < 5.1,

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

47− containers >= 0.5 && < 0.7,

57+ containers >= 0.6 && < 0.7,

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

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

49− dependent-map >= 0.2.4 && < 0.3,

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

50 exception-transformers == 0.4.*,

60 exception-transformers == 0.4.*,

51 lens >= 4.7 && < 5,

61 lens >= 4.7 && < 5,

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

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

53− monoidal-containers == 0.4.*,

54 mtl >= 2.1 && < 2.3,

63 mtl >= 2.1 && < 2.3,

55 prim-uniq >= 0.1.0.1 && < 0.2,

64 prim-uniq >= 0.1.0.1 && < 0.2,

56− primitive >= 0.5 && < 0.7,

65+ primitive >= 0.5 && < 0.8,

66+ profunctors >= 5.3 && < 5.5,

57 random == 1.1.*,

67 random == 1.1.*,

58 ref-tf == 0.4.*,

68 ref-tf == 0.4.*,

59 reflection == 2.1.*,

69 reflection == 2.1.*,

60 semigroupoids >= 4.0 && < 6,

70 semigroupoids >= 4.0 && < 6,

61− semigroups >= 0.16 && < 0.19,

62 stm >= 2.4 && < 2.6,

71 stm >= 2.4 && < 2.6,

63 syb >= 0.5 && < 0.8,

72 syb >= 0.5 && < 0.8,

64− these >= 0.4 && < 0.9,

65 time >= 1.4 && < 1.9,

73 time >= 1.4 && < 1.9,

66− transformers >= 0.2,

74+ transformers >= 0.5.6.0 && < 0.6,

67− transformers-compat >= 0.3,

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

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

69− witherable >= 0.2 && < 0.4

76+ witherable >= 0.3 && < 0.3.2

77+

78+ if flag(split-these)

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

80+ semialign >=1 && <1.2,

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

82+ else

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

84+ monoidal-containers == 0.4.0.0

71 exposed-modules:

86 exposed-modules:

87+ Control.Monad.ReaderIO

72 Data.AppendMap,

88 Data.AppendMap,

73 Data.FastMutableIntMap,

89 Data.FastMutableIntMap,

74 Data.FastWeakBag,

90 Data.FastWeakBag,

@@ -133,7 +149,7 @@ library

133 if flag(use-template-haskell)

149 if flag(use-template-haskell)

134 cpp-options: -DUSE_TEMPLATE_HASKELL

150 cpp-options: -DUSE_TEMPLATE_HASKELL

135 build-depends:

151 build-depends:

136− dependent-sum >= 0.3 && < 0.5,

152+ dependent-sum >= 0.6 && < 0.7,

137 haskell-src-exts >= 1.16 && < 1.22,

153 haskell-src-exts >= 1.16 && < 1.22,

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

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

139 template-haskell >= 2.9 && < 2.15

155 template-haskell >= 2.9 && < 2.15

@@ -142,7 +158,7 @@ library

142 other-extensions: TemplateHaskell

158 other-extensions: TemplateHaskell

143 else

159 else

144 build-depends:

160 build-depends:

145− dependent-sum == 0.4.*

161+ dependent-sum >= 0.6 && < 0.7

146

162

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

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

148 cpp-options: -DGHCJS_FAST_WEAK

164 cpp-options: -DGHCJS_FAST_WEAK

@@ -159,14 +175,14 @@ test-suite semantics

159 base,

175 base,

160 bifunctors,

176 bifunctors,

161 containers,

177 containers,

162− deepseq >= 1.3 && < 1.5,

178+ deepseq,

163 dependent-map,

179 dependent-map,

164 dependent-sum,

180 dependent-sum,

165 mtl,

181 mtl,

166 ref-tf,

182 ref-tf,

167 reflex,

183 reflex,

168 split,

184 split,

169− transformers >= 0.3

185+ transformers

170 other-modules:

186 other-modules:

171 Reflex.Bench.Focused

187 Reflex.Bench.Focused

172 Reflex.Plan.Pure

188 Reflex.Plan.Pure

@@ -185,7 +201,7 @@ test-suite CrossImpl

185 containers,

201 containers,

186 dependent-map,

202 dependent-map,

187 dependent-sum,

203 dependent-sum,

188− deepseq >= 1.3 && < 1.5,

204+ deepseq,

189 mtl,

205 mtl,

190 transformers,

206 transformers,

191 ref-tf,

207 ref-tf,

@@ -204,7 +220,7 @@ test-suite hlint

204 , directory

220 , directory

205 , filepath

221 , filepath

206 , filemanip

222 , filemanip

207− , hlint

223+ , hlint < 2.1 || >= 2.2.2

208 if impl(ghcjs)

224 if impl(ghcjs)

209 buildable: False

225 buildable: False

210

226

@@ -214,7 +230,7 @@ test-suite EventWriterT

214 hs-source-dirs: test

230 hs-source-dirs: test

215 build-depends: base

231 build-depends: base

216 , containers

232 , containers

217− , deepseq >= 1.3 && < 1.5

233+ , deepseq

218 , dependent-map

234 , dependent-map

219 , dependent-sum

235 , dependent-sum

220 , lens

236 , lens

@@ -223,6 +239,10 @@ test-suite EventWriterT

223 , transformers

239 , transformers

224 , reflex

240 , reflex

225 , ref-tf

241 , ref-tf

242+

243+ if flag(split-these)

244+ build-depends: these-lens

245+

226 other-modules:

246 other-modules:

227 Reflex.Test

247 Reflex.Test

228 Reflex.TestPlan

248 Reflex.TestPlan

@@ -230,13 +250,14 @@ test-suite EventWriterT

230 Reflex.Plan.Pure

250 Reflex.Plan.Pure

231 Test.Run

251 Test.Run

232

252

253+

233test-suite RequesterT

254test-suite RequesterT

234 type: exitcode-stdio-1.0

255 type: exitcode-stdio-1.0

235 main-is: RequesterT.hs

256 main-is: RequesterT.hs

236 hs-source-dirs: test

257 hs-source-dirs: test

237 build-depends: base

258 build-depends: base

238 , containers

259 , containers

239− , deepseq >= 1.3 && < 1.5

260+ , deepseq

240 , dependent-sum

261 , dependent-sum

241 , dependent-map

262 , dependent-map

242 , lens

263 , lens

@@ -245,9 +266,14 @@ test-suite RequesterT

245 , transformers

266 , transformers

246 , reflex

267 , reflex

247 , ref-tf

268 , ref-tf

269+

270+ if flag(split-these)

271+ build-depends: these-lens

272+

248 other-modules:

273 other-modules:

249 Reflex.TestPlan

274 Reflex.TestPlan

250 Reflex.Plan.Pure

275 Reflex.Plan.Pure

276+ Test.Run

251

277

252test-suite QueryT

278test-suite QueryT

253 type: exitcode-stdio-1.0

279 type: exitcode-stdio-1.0

@@ -257,15 +283,18 @@ test-suite QueryT

257 , containers

283 , containers

258 , dependent-map

284 , dependent-map

259 , dependent-sum

285 , dependent-sum

260− , deepseq >= 1.3 && < 1.5

286+ , deepseq

261 , lens

287 , lens

262 , monoidal-containers

288 , monoidal-containers

263 , mtl

289 , mtl

264 , ref-tf

290 , ref-tf

265 , reflex

291 , reflex

266− , semigroups

267 , these

292 , these

268 , transformers

293 , transformers

294+

295+ if flag(split-these)

296+ build-depends: semialign, these-lens

297+

269 other-modules:

298 other-modules:

270 Test.Run

299 Test.Run

271 Reflex.TestPlan

300 Reflex.TestPlan

@@ -280,14 +309,16 @@ test-suite GC-Semantics

280 , containers

309 , containers

281 , dependent-sum

310 , dependent-sum

282 , dependent-map

311 , dependent-map

283− , deepseq >= 1.3 && < 1.5

312+ , deepseq

284 , mtl

313 , mtl

285 , these

314 , these

286 , transformers

315 , transformers

287 , reflex

316 , reflex

288 , ref-tf

317 , ref-tf

289− if impl(ghc < 8)

318+

319+ if flag(split-these)

290− build-depends: semigroups

320+ build-depends: semialign

321+

291 other-modules:

322 other-modules:

292 Reflex.Plan.Pure

323 Reflex.Plan.Pure

293 Reflex.Plan.Reflex

324 Reflex.Plan.Reflex

@@ -300,7 +331,7 @@ test-suite rootCleanup

300 hs-source-dirs: test

331 hs-source-dirs: test

301 build-depends: base

332 build-depends: base

302 , containers

333 , containers

303− , deepseq >= 1.3 && < 1.5

334+ , deepseq

304 , dependent-sum

335 , dependent-sum

305 , mtl

336 , mtl

306 , reflex

337 , reflex

@@ -319,8 +350,8 @@ benchmark spider-bench

319 build-depends:

350 build-depends:

320 base,

351 base,

321 containers,

352 containers,

322− criterion >= 1.1 && < 1.6,

353+ criterion,

323− deepseq >= 1.3 && < 1.5,

354+ deepseq,

324 dependent-map,

355 dependent-map,

325 dependent-sum,

356 dependent-sum,

326 ref-tf,

357 ref-tf,

@@ -329,7 +360,7 @@ benchmark spider-bench

329 reflex,

360 reflex,

330 split,

361 split,

331 stm,

362 stm,

332− transformers >= 0.3

363+ transformers

333 other-modules:

364 other-modules:

334 Reflex.TestPlan

365 Reflex.TestPlan

335 Reflex.Plan.Reflex

366 Reflex.Plan.Reflex

@@ -343,9 +374,9 @@ benchmark saulzar-bench

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

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

344 build-depends:

375 build-depends:

345 base,

376 base,

346− containers >= 0.5 && < 0.7,

377+ containers,

347− criterion >= 1.1 && < 1.6,

378+ criterion,

348− deepseq >= 1.3 && < 1.5,

379+ deepseq,

349 dependent-map,

380 dependent-map,

350 dependent-sum,

381 dependent-sum,

351 loch-th,

382 loch-th,

@@ -357,7 +388,7 @@ benchmark saulzar-bench

357 split,

388 split,

358 stm,

389 stm,

359 time,

390 time,

360− transformers >= 0.3

391+ transformers

361 other-modules:

392 other-modules:

362 Reflex.TestPlan

393 Reflex.TestPlan

363 Reflex.Plan.Reflex

394 Reflex.Plan.Reflex

release.nix+53−7

@@ -1,9 +1,55 @@

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

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

2}:

3let

4let

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

4− inherit (rp.nixpkgs) lib;

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

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

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

9+ perPlatform = lib.genAttrs systems (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+ ];

6−in lib.genAttrs compilers (ghc: {

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

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

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

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

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

9−})

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+ ])) ./.;

38+ };

39+ })

40+ ];

41+ };

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

43+ in variationPkgs // {

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

45+ (builtins.attrValues variationPkgs);

46+ });

47+ in compilerPkgs // {

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

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

50+ });

51+

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

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

54+

55+in perPlatform // { inherit metaCache; }

src/Control/Monad/ReaderIO.hsnew file+60

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

1+{-# language RoleAnnotations #-}

2+{-# language MultiParamTypeClasses #-}

3+{-# language FlexibleInstances #-}

4+{-# language CPP #-}

5+module Control.Monad.ReaderIO

6+ (

7+ ReaderIO (..)

8+ )

9+ where

10+

11+import Control.Monad.Fix

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

13+import Control.Applicative

14+#endif

15+import Control.Monad

16+import Control.Monad.Reader.Class

17+import Control.Monad.IO.Class

18+

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

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

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

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

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

24+type role ReaderIO representational representational

25+

26+instance Functor (ReaderIO e) where

27+ fmap = liftM

28+ {-# INLINE fmap #-}

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

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

31+

32+instance Applicative (ReaderIO e) where

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

34+ {-# INLINE pure #-}

35+ (<*>) = ap

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

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

38+ liftA2 = liftM2

39+ {-# INLINE liftA2 #-}

40+#endif

41+ (*>) = (>>)

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

43+

44+instance Monad (ReaderIO e) where

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

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

47+

48+instance MonadFix (ReaderIO e) where

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

50+ {-# INLINE mfix #-}

51+

52+instance MonadIO (ReaderIO e) where

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

54+ {-# INLINE liftIO #-}

55+

56+instance MonadReader e (ReaderIO e) where

57+ ask = ReaderIO pure

58+ {-# INLINE ask #-}

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

60+ {-# INLINE local #-}

src/Data/AppendMap.hs+5−1

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

32#endif

33import qualified Data.Witherable as W

34import Data.Map.Monoidal

35+import qualified Data.Map.Monoidal as MonoidalMap

36+

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

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

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

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

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

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

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

47pattern AppendMap m = MonoidalMap m

49pattern AppendMap m = MonoidalMap m

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

49instance W.Filterable (MonoidalMap k) where

52instance W.Filterable (MonoidalMap k) where

50− mapMaybe = mapMaybe

53+ mapMaybe = MonoidalMap.mapMaybe

54+#endif

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

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

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

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

src/Data/FastWeakBag.hs+9−4

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

18 , isEmpty

19 , insert

20 , traverse

21+ , traverse_

21 , remove

22 , remove

22 -- * Internal functions

23 -- * Internal functions

23 -- These will not always be available.

24 -- These will not always be available.

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

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

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

117#endif

118#endif

118

119

119−{-# INLINE traverse #-}

120+{-# INLINE traverse_ #-}

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

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

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

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

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

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

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

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

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

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

125#ifdef GHCJS_FAST_WEAK

126#ifdef GHCJS_FAST_WEAK

126−traverse wb f = do

127+traverse_ wb f = do

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

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

128 val <- liftIO $ js_getTicketValue cursor

129 val <- liftIO $ js_getTicketValue cursor

129 f $ unsafeFromRawJSVal val

130 f $ unsafeFromRawJSVal val

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

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

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

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

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

136#else

137#else

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

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

138 cs <- liftIO $ readIORef children

139 cs <- liftIO $ readIORef children

139 forM_ cs $ \c -> do

140 forM_ cs $ \c -> do

140 ma <- liftIO $ deRefWeak c

141 ma <- liftIO $ deRefWeak c

141 mapM_ f ma

142 mapM_ f ma

142#endif

143#endif

143

144

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

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

147+traverse = traverse_

148+

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

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

145-- on the same 'FastWeakBagTicket'.

150-- on the same 'FastWeakBagTicket'.

146{-# INLINE remove #-}

151{-# INLINE remove #-}

src/Data/Functor/Misc.hs+2−12

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

4{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE GADTs #-}

7−{-# LANGUAGE KindSignatures #-}

8{-# LANGUAGE LambdaCase #-}

7{-# LANGUAGE LambdaCase #-}

9{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

10{-# LANGUAGE PatternSynonyms #-}

9{-# LANGUAGE PatternSynonyms #-}

@@ -52,8 +51,7 @@ import Data.IntMap (IntMap)

52import qualified Data.IntMap as IntMap

51import qualified Data.IntMap as IntMap

53import Data.Map (Map)

52import Data.Map (Map)

54import qualified Data.Map as Map

53import qualified Data.Map as Map

55−import Data.Some (Some)

54+import Data.Some (Some(Some))

56−import qualified Data.Some as Some

57import Data.These

55import Data.These

58import Data.Typeable hiding (Refl)

56import Data.Typeable hiding (Refl)

@@ -79,9 +77,6 @@ deriving instance Read k => Read (Const2 k v v)

79instance Show k => GShow (Const2 k v) where

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

80 gshowsPrec n x@(Const2 _) = showsPrec n x

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

82−instance (Show k, Show (f v)) => ShowTag (Const2 k v) f where

83− showTaggedPrec (Const2 _) = showsPrec

84−

85instance Eq k => GEq (Const2 k v) where

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

86 geq (Const2 a) (Const2 b) =

81 geq (Const2 a) (Const2 b) =

87 if a == b

82 if a == b

@@ -124,7 +119,7 @@ intMapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=

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

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

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

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

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

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

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

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

128

123

129--------------------------------------------------------------------------------

124--------------------------------------------------------------------------------

130-- WrapArg

125-- WrapArg

@@ -214,11 +209,6 @@ instance GShow (EitherTag l r) where

214 LeftTag -> showString "LeftTag"

209 LeftTag -> showString "LeftTag"

215 RightTag -> showString "RightTag"

210 RightTag -> showString "RightTag"

216

211

217−instance (Show l, Show r) => ShowTag (EitherTag l r) Identity where

218− showTaggedPrec t n (Identity a) = case t of

219− LeftTag -> showsPrec n a

220− RightTag -> showsPrec n a

221−

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

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

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

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

224eitherToDSum = \case

214eitherToDSum = \case

src/Data/WeakBag.hs+8−3

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

15 , singleton

16 , insert

17 , traverse

18+ , traverse_

18 , remove

19 , remove

19 -- * Internal functions

20 -- * Internal functions

20 -- These will not always be available.

21 -- These will not always be available.

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

99 ticket <- insert a bag wbRef finalizer

100 ticket <- insert a bag wbRef finalizer

100 return (bag, ticket)

101 return (bag, ticket)

101

102

102−{-# INLINE traverse #-}

103+{-# INLINE traverse_ #-}

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

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

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

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

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

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

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

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

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

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

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

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

109 cs <- liftIO $ readIORef children

110 cs <- liftIO $ readIORef children

110 forM_ cs $ \c -> do

111 forM_ cs $ \c -> do

111 ma <- liftIO $ deRefWeak c

112 ma <- liftIO $ deRefWeak c

112 mapM_ f ma

113 mapM_ f ma

113

114

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

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

117+traverse = traverse_

118+

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

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

115-- on the same 'WeakBagTicket'.

120-- on the same 'WeakBagTicket'.

116{-# INLINE remove #-}

121{-# INLINE remove #-}

src/Reflex/Adjustable/Class.hs−1

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

3{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FunctionalDependencies #-}

5{-# LANGUAGE LambdaCase #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE RankNTypes #-}

6{-# LANGUAGE RankNTypes #-}

8{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE TypeFamilies #-}

8{-# LANGUAGE TypeFamilies #-}

src/Reflex/BehaviorWriter/Class.hs−1

@@ -5,7 +5,6 @@ Description: This module defines the 'MonadBehaviorWriter' class

5{-# LANGUAGE CPP #-}

6{-# LANGUAGE FlexibleInstances #-}

7{-# LANGUAGE FunctionalDependencies #-}

8−{-# LANGUAGE MultiParamTypeClasses #-}

9{-# LANGUAGE UndecidableInstances #-}

8{-# LANGUAGE UndecidableInstances #-}

10#ifdef USE_REFLEX_OPTIMIZER

9#ifdef USE_REFLEX_OPTIMIZER

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

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

src/Reflex/Class.hs+112−28

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

7{-# LANGUAGE FunctionalDependencies #-}

8{-# LANGUAGE GADTs #-}

9{-# LANGUAGE LambdaCase #-}

10−{-# LANGUAGE MultiParamTypeClasses #-}

11{-# LANGUAGE NoMonomorphismRestriction #-}

10{-# LANGUAGE NoMonomorphismRestriction #-}

12{-# LANGUAGE PolyKinds #-}

11{-# LANGUAGE PolyKinds #-}

13{-# LANGUAGE RankNTypes #-}

12{-# LANGUAGE RankNTypes #-}

@@ -17,6 +16,7 @@

17{-# LANGUAGE TypeFamilies #-}

16{-# LANGUAGE TypeFamilies #-}

18{-# LANGUAGE TypeOperators #-}

17{-# LANGUAGE TypeOperators #-}

19{-# LANGUAGE UndecidableInstances #-}

18{-# LANGUAGE UndecidableInstances #-}

19+{-# LANGUAGE Trustworthy #-}

20#ifdef USE_REFLEX_OPTIMIZER

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

22#endif

@@ -36,16 +36,21 @@ module Reflex.Class

36 , coerceBehavior

37 , coerceEvent

38 , coerceDynamic

39+ , coerceIncremental

39 , MonadSample (..)

40 , MonadSample (..)

40 , MonadHold (..)

41 , MonadHold (..)

41 -- ** 'fan' related types

42 -- ** 'fan' related types

42 , EventSelector (..)

43 , EventSelector (..)

44+ , EventSelectorG (..)

43 , EventSelectorInt (..)

45 , EventSelectorInt (..)

44 -- * Convenience functions

46 -- * Convenience functions

45 , constDyn

47 , constDyn

46 , pushAlways

48 , pushAlways

47 -- ** Combining 'Event's

49 -- ** Combining 'Event's

48 , leftmost

50 , leftmost

51+ , merge

52+ , mergeIncremental

53+ , mergeIncrementalWithMove

49 , mergeMap

54 , mergeMap

50 , mergeIntMap

55 , mergeIntMap

51 , mergeMapIncremental

56 , mergeMapIncremental

@@ -60,6 +65,7 @@ module Reflex.Class

60 , alignEventWithMaybe

65 , alignEventWithMaybe

61 -- ** Breaking up 'Event's

66 -- ** Breaking up 'Event's

62 , splitE

67 , splitE

68+ , fan

63 , fanEither

69 , fanEither

64 , fanThese

70 , fanThese

65 , fanMap

71 , fanMap

@@ -84,6 +90,7 @@ module Reflex.Class

84 , gate

90 , gate

85 -- ** Combining 'Dynamic's

91 -- ** Combining 'Dynamic's

86 , distributeDMapOverDynPure

92 , distributeDMapOverDynPure

93+ , distributeDMapOverDynPureG

87 , distributeListOverDyn

94 , distributeListOverDyn

88 , distributeListOverDynWith

95 , distributeListOverDynWith

89 , zipDyn

96 , zipDyn

@@ -166,6 +173,17 @@ module Reflex.Class

166 , slowHeadE

173 , slowHeadE

167 ) where

174 ) where

168

175

176+#ifdef MIN_VERSION_semialign

177+import Prelude hiding (zip, zipWith)

178+

179+#if MIN_VERSION_these(0,8,0)

180+import Data.These.Combinators (justThese)

181+#endif

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

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

184+#endif

185+#endif

186+

169import Control.Applicative

187import Control.Applicative

170import Control.Monad.Identity

188import Control.Monad.Identity

171import Control.Monad.Reader

189import Control.Monad.Reader

@@ -193,8 +211,7 @@ import qualified Data.IntMap.Strict as IntMap

193import Data.List.NonEmpty (NonEmpty (..))

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

194import Data.Map (Map)

212import Data.Map (Map)

195import Data.Semigroup (Semigroup, sconcat, stimes, (<>))

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

196−import Data.Some (Some)

214+import Data.Some (Some(Some))

197−import qualified Data.Some as Some

198import Data.String

215import Data.String

199import Data.These

216import Data.These

200import Data.Type.Coercion

217import Data.Type.Coercion

@@ -256,11 +273,16 @@ class ( MonadHold t (PushM t)

256 -- | Merge a collection of events; the resulting 'Event' will only occur if at

273 -- | Merge a collection of events; the resulting 'Event' will only occur if at

257 -- least one input event is occurring, and will contain all of the input keys

274 -- least one input event is occurring, and will contain all of the input keys

258 -- that are occurring simultaneously

275 -- that are occurring simultaneously

276+

259− merge :: GCompare k => DMap k (Event t) -> Event t (DMap k Identity) --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty

277+ --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty

278+ mergeG :: GCompare k => (forall a. q a -> Event t (v a))

279+ -> DMap k q -> Event t (DMap k v)

280+

260 -- | Efficiently fan-out an event to many destinations. You should save the

281 -- | Efficiently fan-out an event to many destinations. You should save the

261− -- result in a @let@-binding, and then repeatedly 'select' on the result to

282+ -- result in a @let@-binding, and then repeatedly 'selectG' on the result to

262 -- create child events

283 -- create child events

263− fan :: GCompare k => Event t (DMap k Identity) -> EventSelector t k

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

285+

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

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

265 -- 'Event' occurs

287 -- 'Event' occurs

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

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

@@ -278,9 +300,14 @@ class ( MonadHold t (PushM t)

278 -- that value.

300 -- that value.

279 unsafeBuildIncremental :: Patch p => PullM t (PatchTarget p) -> Event t p -> Incremental t p

301 unsafeBuildIncremental :: Patch p => PullM t (PatchTarget p) -> Event t p -> Incremental t p

280 -- | Create a merge whose parents can change over time

302 -- | Create a merge whose parents can change over time

303+ mergeIncrementalG :: GCompare k

304+ => (forall a. q a -> Event t (v a))

281− mergeIncremental :: GCompare k => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)

305+ -> Incremental t (PatchDMap k q)

306+ -> Event t (DMap k v)

282 -- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental

307 -- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental

308+ mergeIncrementalWithMoveG :: GCompare k

309+ => (forall a. q a -> Event t (v a))

283− mergeIncrementalWithMove :: GCompare k => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)

310+ -> Incremental t (PatchDMapWithMove k q) -> Event t (DMap k v)

284 -- | Extract the 'Behavior' component of an 'Incremental'

311 -- | Extract the 'Behavior' component of an 'Incremental'

285 currentIncremental :: Patch p => Incremental t p -> Behavior t (PatchTarget p)

312 currentIncremental :: Patch p => Incremental t p -> Behavior t (PatchTarget p)

286 -- | Extract the 'Event' component of an 'Incremental'

313 -- | Extract the 'Event' component of an 'Incremental'

@@ -296,9 +323,25 @@ class ( MonadHold t (PushM t)

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

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

297 -- occurrence type

324 -- occurrence type

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

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

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

327+ -- patch target and patch types.

328+ incrementalCoercion

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

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

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

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

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

301

332

333+-- | Efficiently fan-out an event to many destinations. You should save the

334+-- result in a @let@-binding, and then repeatedly 'select' on the result to

335+-- create child events

336+fan :: forall t k. (Reflex t, GCompare k)

337+ => Event t (DMap k Identity) -> EventSelector t k

338+ --TODO: Can we help enforce the partial application discipline here? The combinator is worthless without it

339+fan e = EventSelector (fixup (selectG (fanG e) :: k a -> Event t (Identity a)) :: forall a. k a -> Event t a)

340+ where

341+ fixup :: forall a. (k a -> Event t (Identity a)) -> k a -> Event t a

342+ fixup = case eventCoercion Coercion :: Coercion (Event t (Identity a)) (Event t a) of

343+ Coercion -> coerce

344+

302--TODO: Specialize this so that we can take advantage of knowing that there's no changing going on

345--TODO: Specialize this so that we can take advantage of knowing that there's no changing going on

303-- | Constructs a single 'Event' out of a map of events. The output event may fire with multiple

346-- | Constructs a single 'Event' out of a map of events. The output event may fire with multiple

304-- keys simultaneously.

347-- keys simultaneously.

@@ -317,6 +360,12 @@ coerceEvent = coerceWith $ eventCoercion Coercion

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

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

318coerceDynamic = coerceWith $ dynamicCoercion Coercion

361coerceDynamic = coerceWith $ dynamicCoercion Coercion

319

362

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

364+coerceIncremental

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

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

367+coerceIncremental = coerceWith $ incrementalCoercion Coercion Coercion

368+

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

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

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

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

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

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

@@ -486,6 +535,17 @@ newtype EventSelector t k = EventSelector

486 select :: forall a. k a -> Event t a

535 select :: forall a. k a -> Event t a

487 }

536 }

488

537

538+newtype EventSelectorG t k v = EventSelectorG

539+ { -- | Retrieve the 'Event' for the given key. The type of the 'Event' is

540+ -- determined by the type of the key, so this can be used to fan-out

541+ -- 'Event's whose sub-'Event's have different types.

542+ --

543+ -- Using 'EventSelector's and the 'fan' primitive is far more efficient than

544+ -- (but equivalent to) using 'mapMaybe' to select only the relevant

545+ -- occurrences of an 'Event'.

546+ selectG :: forall a. k a -> Event t (v a)

547+ }

548+

489-- | Efficiently select an 'Event' keyed on 'Int'. This is more efficient than manually

549-- | Efficiently select an 'Event' keyed on 'Int'. This is more efficient than manually

490-- filtering by key.

550-- filtering by key.

491newtype EventSelectorInt t a = EventSelectorInt { selectInt :: Int -> Event t a }

551newtype EventSelectorInt t a = EventSelectorInt { selectInt :: Int -> Event t a }

@@ -630,11 +690,7 @@ instance (Num a, Reflex t) => Num (Dynamic t a) where

630instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where

690instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where

631 a <> b = pull $ liftM2 (<>) (sample a) (sample b)

691 a <> b = pull $ liftM2 (<>) (sample a) (sample b)

632 sconcat = pull . fmap sconcat . mapM sample

692 sconcat = pull . fmap sconcat . mapM sample

633−#if MIN_VERSION_semigroups(0,17,0)

634 stimes n = fmap $ stimes n

693 stimes n = fmap $ stimes n

635−#else

636− times1p n = fmap $ times1p n

637−#endif

638

694

639-- | Alias for 'mapMaybe'

695-- | Alias for 'mapMaybe'

640fmapMaybe :: Filterable f => (a -> Maybe b) -> f a -> f b

696fmapMaybe :: Filterable f => (a -> Maybe b) -> f a -> f b

@@ -661,9 +717,12 @@ filterRight = mapMaybe (either (const Nothing) Just)

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

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

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

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

663

719

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

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

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

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

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

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

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

724+ f _ = Nothing

725+

667

726

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

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

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

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

@@ -832,11 +891,7 @@ traceEventWith f = push $ \x -> trace (f x) $ return $ Just x

832instance (Semigroup a, Reflex t) => Semigroup (Event t a) where

891instance (Semigroup a, Reflex t) => Semigroup (Event t a) where

833 (<>) = alignWith (mergeThese (<>))

892 (<>) = alignWith (mergeThese (<>))

834 sconcat = fmap sconcat . mergeList . toList

893 sconcat = fmap sconcat . mergeList . toList

835−#if MIN_VERSION_semigroups(0,17,0)

836 stimes n = fmap $ stimes n

894 stimes n = fmap $ stimes n

837−#else

838− times1p n = fmap $ times1p n

839−#endif

840

895

841instance (Semigroup a, Reflex t) => Monoid (Event t a) where

896instance (Semigroup a, Reflex t) => Monoid (Event t a) where

842 mempty = never

897 mempty = never

@@ -1025,6 +1080,13 @@ instance Reflex t => Semialign (Event t) where

1025#endif

1080#endif

1026 align = alignEventWithMaybe Just

1081 align = alignEventWithMaybe Just

1027

1082

1083+#ifdef MIN_VERSION_semialign

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

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

1086+#endif

1087+ zip x y = mapMaybe justThese $ align x y

1088+#endif

1089+

1028

1090

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

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

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

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

@@ -1065,11 +1127,7 @@ zipDynWith f da db =

1065

1127

1066instance (Reflex t, Semigroup a) => Semigroup (Dynamic t a) where

1128instance (Reflex t, Semigroup a) => Semigroup (Dynamic t a) where

1067 (<>) = zipDynWith (<>)

1129 (<>) = zipDynWith (<>)

1068−#if MIN_VERSION_semigroups(0,17,0)

1069 stimes n = fmap $ stimes n

1130 stimes n = fmap $ stimes n

1070−#else

1071− times1p n = fmap $ times1p n

1072−#endif

1073

1131

1074instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where

1132instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where

1075 mconcat = distributeListOverDynWith mconcat

1133 mconcat = distributeListOverDynWith mconcat

@@ -1080,12 +1138,21 @@ instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where

1080-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same

1138-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same

1081-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators.

1139-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators.

1082distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity)

1140distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity)

1083−distributeDMapOverDynPure dm = case DMap.toList dm of

1141+distributeDMapOverDynPure = distributeDMapOverDynPureG coerceDynamic

1142+

1143+-- | This function converts a 'DMap' whose elements are 'Dynamic's into a

1144+-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same

1145+-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators.

1146+distributeDMapOverDynPureG

1147+ :: forall t k q v. (Reflex t, GCompare k)

1148+ => (forall a. q a -> Dynamic t (v a))

1149+ -> DMap k q -> Dynamic t (DMap k v)

1150+distributeDMapOverDynPureG nt dm = case DMap.toList dm of

1084 [] -> constDyn DMap.empty

1151 [] -> constDyn DMap.empty

1085− [k :=> v] -> fmap (DMap.singleton k . Identity) v

1152+ [k :=> v] -> DMap.singleton k <$> nt v

1086 _ ->

1153 _ ->

1087− let getInitial = DMap.traverseWithKey (\_ -> fmap Identity . sample . current) dm

1154+ let getInitial = DMap.traverseWithKey (\_ -> sample . current . nt) dm

1088− edmPre = merge $ DMap.map updated dm

1155+ edmPre = mergeG getCompose $ DMap.map (Compose . updated . nt) dm

1089 result = unsafeBuildDynamic getInitial $ flip pushAlways edmPre $ \news -> do

1156 result = unsafeBuildDynamic getInitial $ flip pushAlways edmPre $ \news -> do

1090 olds <- sample $ current result

1157 olds <- sample $ current result

1091 return $ DMap.unionWithKey (\_ _ new -> new) olds news

1158 return $ DMap.unionWithKey (\_ _ new -> new) olds news

@@ -1155,9 +1222,9 @@ factorEvent

1155 -> Event t (DSum k v)

1222 -> Event t (DSum k v)

1156 -> m (Event t (v a), Event t (DSum k (Product v (Compose (Event t) v))))

1223 -> m (Event t (v a), Event t (DSum k (Product v (Compose (Event t) v))))

1157factorEvent k0 kv' = do

1224factorEvent k0 kv' = do

1158− key :: Behavior t (Some k) <- hold (Some.This k0) $ fmapCheap (\(k :=> _) -> Some.This k) kv'

1225+ key :: Behavior t (Some k) <- hold (Some k0) $ fmapCheap (\(k :=> _) -> Some k) kv'

1159 let update = flip push kv' $ \(newKey :=> newVal) -> sample key >>= \case

1226 let update = flip push kv' $ \(newKey :=> newVal) -> sample key >>= \case

1160− Some.This oldKey -> case newKey `geq` oldKey of

1227+ Some oldKey -> case newKey `geq` oldKey of

1161 Just Refl -> return Nothing

1228 Just Refl -> return Nothing

1162 Nothing -> do

1229 Nothing -> do

1163 newInner <- filterEventKey newKey kv'

1230 newInner <- filterEventKey newKey kv'

@@ -1558,6 +1625,23 @@ fmapCheap f = pushCheap $ return . Just . f

1558tagCheap :: Reflex t => Behavior t b -> Event t a -> Event t b

1625tagCheap :: Reflex t => Behavior t b -> Event t a -> Event t b

1559tagCheap b = pushAlwaysCheap $ \_ -> sample b

1626tagCheap b = pushAlwaysCheap $ \_ -> sample b

1560

1627

1628+-- | Merge a collection of events; the resulting 'Event' will only occur if at

1629+-- least one input event is occurring, and will contain all of the input keys

1630+-- that are occurring simultaneously

1631+merge :: (Reflex t, GCompare k) => DMap k (Event t) -> Event t (DMap k Identity)

1632+merge = mergeG coerceEvent

1633+{-# INLINE merge #-}

1634+

1635+-- | Create a merge whose parents can change over time

1636+mergeIncremental :: (Reflex t, GCompare k)

1637+ => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)

1638+mergeIncremental = mergeIncrementalG coerceEvent

1639+

1640+-- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental

1641+mergeIncrementalWithMove :: (Reflex t, GCompare k)

1642+ => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)

1643+mergeIncrementalWithMove = mergeIncrementalWithMoveG coerceEvent

1644+

1561-- | A "cheap" version of 'mergeWithCheap'. See the performance note on 'pushCheap'.

1645-- | A "cheap" version of 'mergeWithCheap'. See the performance note on 'pushCheap'.

1562{-# INLINE mergeWithCheap #-}

1646{-# INLINE mergeWithCheap #-}

1563mergeWithCheap :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a

1647mergeWithCheap :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a

src/Reflex/Collection.hs+8−1

@@ -27,6 +27,13 @@ module Reflex.Collection

27 , simpleList

28 ) where

30+#ifdef MIN_VERSION_semialign

31+import Prelude hiding (zip, zipWith)

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

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

34+#endif

35+#endif

36+

30import Control.Monad.Identity

37import Control.Monad.Identity

31import Data.Align

38import Data.Align

32import Data.Functor.Misc

39import Data.Functor.Misc

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

123 Nothing -> Just Nothing

130 Nothing -> Just Nothing

124

131

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

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

126− Just _ -> Nothing

133+ Just _ -> Nothing

127 listHoldWithKey

134 listHoldWithKey

128 initialVals

135 initialVals

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

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

src/Reflex/Dynamic/TH.hs+1−1

@@ -81,7 +81,7 @@ mkDynPure = QuasiQuoter

81 }

83mkDynExp :: String -> Q Exp

84−mkDynExp s = case Hs.parseExpWithMode (Hs.defaultParseMode { Hs.extensions = [ Hs.EnableExtension Hs.TemplateHaskell ] }) s of

84+mkDynExp s = case Hs.parseExpWithMode Hs.defaultParseMode { Hs.extensions = [ Hs.EnableExtension Hs.TemplateHaskell ] } s of

85 Hs.ParseFailed (Hs.SrcLoc _ l c) err -> fail $ "mkDyn:" <> show l <> ":" <> show c <> ": " <> err

86 Hs.ParseOk e -> qDynPure $ return $ everywhere (id `extT` reinstateUnqDyn) $ Hs.toExp $ everywhere (id `extT` antiE) e

87 where TH.Name (TH.OccName occName) (TH.NameG _ _ (TH.ModName modName)) = 'unqMarker

src/Reflex/DynamicWriter/Class.hs−2

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

3{-# LANGUAGE CPP #-}

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FunctionalDependencies #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE UndecidableInstances #-}

6{-# LANGUAGE UndecidableInstances #-}

8#ifdef USE_REFLEX_OPTIMIZER

7#ifdef USE_REFLEX_OPTIMIZER

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

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

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

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

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

29 tellDyn = lift . tellDyn

28 tellDyn = lift . tellDyn

30−

src/Reflex/EventWriter/Base.hs+1−1

@@ -52,7 +52,7 @@ import qualified Data.Map as Map

52import Data.Semigroup

53import Data.Some (Some)

54import Data.Tuple

55−import Data.Type.Equality hiding (apply)

55+import Data.Type.Equality

57import Unsafe.Coerce

src/Reflex/EventWriter/Class.hs−1

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

2{-# LANGUAGE CPP #-}

3{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FunctionalDependencies #-}

5−{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE UndecidableInstances #-}

5{-# LANGUAGE UndecidableInstances #-}

7#ifdef USE_REFLEX_OPTIMIZER

6#ifdef USE_REFLEX_OPTIMIZER

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

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

src/Reflex/Host/Class.hs−1

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

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FunctionalDependencies #-}

6{-# LANGUAGE GADTs #-}

7−{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE RankNTypes #-}

7{-# LANGUAGE RankNTypes #-}

9{-# LANGUAGE RoleAnnotations #-}

8{-# LANGUAGE RoleAnnotations #-}

10{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE ScopedTypeVariables #-}

src/Reflex/Network.hs+1−1

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

20import Reflex.PostBuild.Class

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

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

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

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

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

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

src/Reflex/NotReady/Class.hs−1

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

3{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FunctionalDependencies #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE TypeFamilies #-}

8{-# LANGUAGE UndecidableInstances #-}

7{-# LANGUAGE UndecidableInstances #-}

9#ifdef USE_REFLEX_OPTIMIZER

8#ifdef USE_REFLEX_OPTIMIZER

src/Reflex/Patch/DMapWithMove.hs+6−7

@@ -19,9 +19,9 @@ import Reflex.Patch.Class

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

20import qualified Reflex.Patch.MapWithMove as MapWithMove

22+import Data.Constraint.Extras

22import Data.Dependent.Map (DMap, DSum (..), GCompare (..))

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

23import qualified Data.Dependent.Map as DMap

24import qualified Data.Dependent.Map as DMap

24−import Data.Dependent.Sum (EqTag (..))

25import Data.Functor.Constant

26import Data.Functor.Misc

27import Data.Functor.Product

@@ -30,8 +30,7 @@ import Data.GADT.Show (GShow, gshow)

30import qualified Data.Map as Map

31import Data.Maybe

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

33−import Data.Some (Some)

33+import Data.Some (Some(Some))

34−import qualified Data.Some as Some

35import Data.These

34import Data.These

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

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

@@ -105,8 +104,8 @@ validationErrorsForPatchDMapWithMove m =

105 unbalancedMove _ = Nothing

104 unbalancedMove _ = Nothing

106

105

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

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

108−instance EqTag k (NodeInfo k v) => Eq (PatchDMapWithMove k v) where

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

109− PatchDMapWithMove a == PatchDMapWithMove b = a == b

108+ PatchDMapWithMove a == PatchDMapWithMove b = a == b

110

109

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

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

112data Pair1 f g a = Pair1 (f a) (g a)

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

@@ -311,8 +310,8 @@ weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenD

311 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of

310 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of

312 From_Insert v -> MapWithMove.From_Insert $ f v

311 From_Insert v -> MapWithMove.From_Insert $ f v

313 From_Delete -> MapWithMove.From_Delete

312 From_Delete -> MapWithMove.From_Delete

314− From_Move k -> MapWithMove.From_Move $ Some.This k

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

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

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

316 }

315 }

317

316

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

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

src/Reflex/Patch/IntMap.hs−8

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DeriveFoldable #-}

1{-# LANGUAGE DeriveFoldable #-}

3{-# LANGUAGE DeriveFunctor #-}

2{-# LANGUAGE DeriveFunctor #-}

4{-# LANGUAGE DeriveTraversable #-}

3{-# LANGUAGE DeriveTraversable #-}

@@ -33,14 +32,7 @@ instance Patch (PatchIntMap a) where

33instance Semigroup (PatchIntMap v) where

32instance Semigroup (PatchIntMap v) where

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

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

35 -- PatchMap is idempotent, so stimes n is id for every n

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

36−#if MIN_VERSION_semigroups(0,17,0)

37 stimes = stimesIdempotentMonoid

35 stimes = stimesIdempotentMonoid

38−#else

39− times1p n x = case compare n 0 of

40− LT -> error "stimesIdempotentMonoid: negative multiplier"

41− EQ -> mempty

42− GT -> x

43−#endif

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

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

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

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

src/Reflex/Patch/Map.hs−8

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

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE LambdaCase #-}

1{-# LANGUAGE LambdaCase #-}

3{-# LANGUAGE TypeFamilies #-}

2{-# LANGUAGE TypeFamilies #-}

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

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

@@ -35,14 +34,7 @@ instance Ord k => Patch (PatchMap k v) where

35instance Ord k => Semigroup (PatchMap k v) where

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

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

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

37 -- PatchMap is idempotent, so stimes n is id for every n

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

38−#if MIN_VERSION_semigroups(0,17,0)

39 stimes = stimesIdempotentMonoid

37 stimes = stimesIdempotentMonoid

40−#else

41− times1p n x = case compare n 0 of

42− LT -> error "stimesIdempotentMonoid: negative multiplier"

43− EQ -> mempty

44− GT -> x

45−#endif

47-- | The empty 'PatchMap' contains no insertions or deletions

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

48instance Ord k => Monoid (PatchMap k v) where

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

src/Reflex/Patch/MapWithMove.hs+1−1

@@ -155,7 +155,7 @@ patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipW

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

158+ let Just movingTo = Map.lookup to reverseMapping

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

160

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

src/Reflex/PerformEvent/Base.hs+1−1

@@ -141,7 +141,7 @@ hostPerformEventT a = do

141 case mToPerform of

142 Nothing -> return [result']

143 Just toPerform -> do

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

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

145 mrt <- readRef responseTrigger

146 let followupEventTriggers = case mrt of

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

src/Reflex/PerformEvent/Class.hs−1

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

5{-# LANGUAGE FlexibleContexts #-}

6{-# LANGUAGE FlexibleInstances #-}

7{-# LANGUAGE FunctionalDependencies #-}

8−{-# LANGUAGE MultiParamTypeClasses #-}

9{-# LANGUAGE RankNTypes #-}

8{-# LANGUAGE RankNTypes #-}

10{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE TypeFamilies #-}

10{-# LANGUAGE TypeFamilies #-}

src/Reflex/PostBuild/Class.hs−1

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

4{-# LANGUAGE DataKinds #-}

5{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE FunctionalDependencies #-}

7−{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE TypeFamilies #-}

8{-# LANGUAGE TypeFamilies #-}

10{-# LANGUAGE TypeOperators #-}

9{-# LANGUAGE TypeOperators #-}

src/Reflex/Profiled.hs+24−16

@@ -8,6 +8,9 @@

8{-# LANGUAGE StandaloneDeriving #-}

9{-# LANGUAGE TypeFamilies #-}

10{-# LANGUAGE UndecidableInstances #-}

11+{-# LANGUAGE PolyKinds #-}

12+{-# LANGUAGE TypeApplications #-}

13+{-# LANGUAGE RankNTypes #-}

11-- |

14-- |

12-- Module:

15-- Module:

13-- Reflex.Profiled

16-- Reflex.Profiled

@@ -16,7 +19,6 @@

16-- profiling/cost-center information.

19-- profiling/cost-center information.

17module Reflex.Profiled where

20module Reflex.Profiled where

19−import Control.Lens hiding (children)

20import Control.Monad

22import Control.Monad

21import Control.Monad.Exception

23import Control.Monad.Exception

22import Control.Monad.Fix

24import Control.Monad.Fix

@@ -33,6 +35,7 @@ import Data.Map (Map)

33import qualified Data.Map.Strict as Map

35import qualified Data.Map.Strict as Map

34import Data.Monoid ((<>))

36import Data.Monoid ((<>))

35import Data.Ord

37import Data.Ord

38+import Data.Profunctor.Unsafe ((#.))

36import qualified Data.Semigroup as S

39import qualified Data.Semigroup as S

37import Data.Type.Coercion

40import Data.Type.Coercion

38import Foreign.Ptr

41import Foreign.Ptr

@@ -77,9 +80,9 @@ getCostCentreStack = go []

77 go (cc : l) parent

80 go (cc : l) parent

79toCostCentreTree :: Ptr CostCentreStack -> Int -> IO CostCentreTree

82toCostCentreTree :: Ptr CostCentreStack -> Int -> IO CostCentreTree

80−toCostCentreTree ccs n = do

83+toCostCentreTree ccs n =

81− ccList <- getCostCentreStack ccs

82− return $ foldr (\cc child -> CostCentreTree 0 n $ Map.singleton cc child) (CostCentreTree n n mempty) ccList

84+ foldr (\cc child -> CostCentreTree 0 n $ Map.singleton cc child) (CostCentreTree n n mempty)

85+ <$> getCostCentreStack ccs

84getCostCentreTree :: IO CostCentreTree

87getCostCentreTree :: IO CostCentreTree

85getCostCentreTree = do

88getCostCentreTree = do

@@ -133,27 +136,32 @@ instance Reflex t => Reflex (ProfiledTimeline t) where

133 push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us

136 push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us

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

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

135 pull = Behavior_Profiled . pull . coerce

138 pull = Behavior_Profiled . pull . coerce

136− merge :: forall k. GCompare k => DMap k (Event (ProfiledTimeline t)) -> Event (ProfiledTimeline t) (DMap k Identity)

139+ fanG (Event_Profiled e) = EventSelectorG $ coerce $ selectG (fanG $ profileEvent e)

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

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

137− merge = Event_Profiled . merge . (unsafeCoerce :: DMap k (Event (ProfiledTimeline t)) -> DMap k (Event t))

142+ -> DMap k q -> Event (ProfiledTimeline t) (DMap k v)

138− fan (Event_Profiled e) = EventSelector $ coerce $ select (fan $ profileEvent e)

143+ mergeG nt = Event_Profiled #. mergeG (coerce nt)

139 switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b)

144 switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b)

140 coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e)

145 coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e)

141 current (Dynamic_Profiled d) = coerce $ current d

146 current (Dynamic_Profiled d) = coerce $ current d

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

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

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

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

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

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

145− mergeIncremental = Event_Profiled . mergeIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMap k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMap k (Event t)))

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

146− mergeIncrementalWithMove = Event_Profiled . mergeIncrementalWithMove . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMapWithMove k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMapWithMove k (Event t)))

151+ mergeIncrementalWithMoveG nt = (Event_Profiled . coerce) #. mergeIncrementalWithMoveG nt

147 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i

152 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i

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

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

149 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i

154 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i

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

155+ behaviorCoercion c =

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

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

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

157+ eventCoercion c =

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

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

159+ dynamicCoercion c =

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

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

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

161+ incrementalCoercion c d =

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

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

163+ mergeIntIncremental = Event_Profiled . mergeIntIncremental .

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

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

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

158

166

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

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

src/Reflex/Pure.hs+21−17

@@ -5,6 +5,9 @@

5{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE TypeFamilies #-}

8+{-# LANGUAGE RankNTypes #-}

9+{-# LANGUAGE PolyKinds #-}

10+

8#ifdef USE_REFLEX_OPTIMIZER

11#ifdef USE_REFLEX_OPTIMIZER

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

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

10#endif

13#endif

@@ -28,14 +31,9 @@ module Reflex.Pure

28 , Incremental (..)

31 , Incremental (..)

29 ) where

32 ) where

31−#if !MIN_VERSION_base(4,8,0)

32−import Control.Applicative

33−#endif

34−

35import Control.Monad

34import Control.Monad

36import Data.Dependent.Map (DMap, GCompare)

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

37import qualified Data.Dependent.Map as DMap

36import qualified Data.Dependent.Map as DMap

38−import Data.Functor.Identity

39import Data.IntMap (IntMap)

37import Data.IntMap (IntMap)

40import qualified Data.IntMap as IntMap

38import qualified Data.IntMap as IntMap

41import Data.Maybe

39import Data.Maybe

@@ -43,10 +41,11 @@ import Data.MemoTrie

43import Data.Monoid

41import Data.Monoid

44import Data.Type.Coercion

42import Data.Type.Coercion

45import Reflex.Class

43import Reflex.Class

44+import Data.Kind (Type)

47-- | A completely pure-functional 'Reflex' timeline, identifying moments in time

46-- | A completely pure-functional 'Reflex' timeline, identifying moments in time

48-- with the type @/t/@.

47-- with the type @/t/@.

49−data Pure t

48+data Pure (t :: Type)

51-- | The 'Enum' instance of @/t/@ must be dense: for all @/x :: t/@, there must not exist

50-- | The 'Enum' instance of @/t/@ must be dense: for all @/x :: t/@, there must not exist

52-- any @/y :: t/@ such that @/'pred' x < y < x/@. The 'HasTrie' instance will be used

51-- any @/y :: t/@ such that @/'pred' x < y < x/@. The 'HasTrie' instance will be used

@@ -79,17 +78,19 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where

79 -- [UNUSED_CONSTRAINT]: The following type signature for merge will produce a

78 -- [UNUSED_CONSTRAINT]: The following type signature for merge will produce a

80 -- warning because the GCompare instance is not used; however, removing the

79 -- warning because the GCompare instance is not used; however, removing the

81 -- GCompare instance produces a different warning, due to that constraint

80 -- GCompare instance produces a different warning, due to that constraint

82− -- being present in the original class definition

81+ -- being present in the original class definition.

84− --merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity)

83+ --mergeG :: GCompare k => (forall a. q a -> Event (Pure t) (v a))

84+ -- -> DMap k q -> Event (Pure t) (DMap k v)

85− merge events = Event $ memo $ \t ->

85+ mergeG nt events = Event $ memo $ \t ->

86− let currentOccurrences = DMap.mapMaybeWithKey (\_ (Event a) -> Identity <$> a t) events

86+ let currentOccurrences = DMap.mapMaybeWithKey (\_ q -> case nt q of Event a -> a t) events

87 in if DMap.null currentOccurrences

88 then Nothing

89 else Just currentOccurrences

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

91− fan :: GCompare k => Event (Pure t) (DMap k Identity) -> EventSelector (Pure t) k

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

92− fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= fmap runIdentity . DMap.lookup k

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

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

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

95 switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t

96 switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t

@@ -112,8 +113,8 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where

112 --a) -> Incremental (Pure t) p a

113 --a) -> Incremental (Pure t) p a

113 unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t)

114 unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t)

114

115

115− mergeIncremental = mergeIncrementalImpl

116+ mergeIncrementalG = mergeIncrementalImpl

116− mergeIncrementalWithMove = mergeIncrementalImpl

117+ mergeIncrementalWithMoveG = mergeIncrementalImpl

117

118

118 currentIncremental i = Behavior $ \t -> fst $ unIncremental i t

119 currentIncremental i = Behavior $ \t -> fst $ unIncremental i t

119

120

@@ -128,14 +129,17 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where

128 behaviorCoercion Coercion = Coercion

129 behaviorCoercion Coercion = Coercion

129 eventCoercion Coercion = Coercion

130 eventCoercion Coercion = Coercion

130 dynamicCoercion Coercion = Coercion

131 dynamicCoercion Coercion = Coercion

132+ incrementalCoercion Coercion Coercion = Coercion

131

133

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

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

133

135

134 mergeIntIncremental = mergeIntIncrementalImpl

136 mergeIntIncremental = mergeIntIncrementalImpl

135

137

136−mergeIncrementalImpl :: (PatchTarget p ~ DMap k (Event (Pure t)), GCompare k) => Incremental (Pure t) p -> Event (Pure t) (DMap k Identity)

138+mergeIncrementalImpl :: (PatchTarget p ~ DMap k q, GCompare k)

139+ => (forall a. q a -> Event (Pure t) (v a))

140+ -> Incremental (Pure t) p -> Event (Pure t) (DMap k v)

137−mergeIncrementalImpl i = Event $ \t ->

141+mergeIncrementalImpl nt i = Event $ \t ->

138− let results = DMap.mapMaybeWithKey (\_ (Event e) -> Identity <$> e t) $ fst $ unIncremental i t

142+ let results = DMap.mapMaybeWithKey (\_ q -> case nt q of Event e -> e t) $ fst $ unIncremental i t

139 in if DMap.null results

143 in if DMap.null results

140 then Nothing

144 then Nothing

141 else Just results

145 else Just results

src/Reflex/Query/Base.hs+5−7

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

1{-# LANGUAGE FlexibleInstances #-}

2{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3{-# LANGUAGE InstanceSigs #-}

4−{-# LANGUAGE KindSignatures #-}

5{-# LANGUAGE LambdaCase #-}

4{-# LANGUAGE LambdaCase #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE RankNTypes #-}

6{-# LANGUAGE RankNTypes #-}

@@ -38,8 +37,7 @@ import Data.Map (Map)

38import qualified Data.Map as Map

37import qualified Data.Map as Map

39import Data.Monoid ((<>))

38import Data.Monoid ((<>))

40import qualified Data.Semigroup as S

39import qualified Data.Semigroup as S

41−import Data.Some (Some)

40+import Data.Some (Some(Some))

42−import qualified Data.Some as Some

43import Data.These

41import Data.These

45import Reflex.Class

43import Reflex.Class

@@ -145,10 +143,10 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t

145 liftedResult' = fforCheap result' $ \(PatchDMap p) -> PatchDMap $

143 liftedResult' = fforCheap result' $ \(PatchDMap p) -> PatchDMap $

146 mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mr) -> k :=> ComposeMaybe (fmap (getQueryTLoweredResultValue . getCompose) mr)) p

144 mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mr) -> k :=> ComposeMaybe (fmap (getQueryTLoweredResultValue . getCompose) mr)) p

147 liftedBs0 :: Map (Some k) [Behavior t q]

145 liftedBs0 :: Map (Some k) [Behavior t q]

148− liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0

146+ liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0

149 liftedBs' :: Event t (PatchMap (Some k) [Behavior t q])

147 liftedBs' :: Event t (PatchMap (Some k) [Behavior t q])

150 liftedBs' = fforCheap result' $ \(PatchDMap p) -> PatchMap $

148 liftedBs' = fforCheap result' $ \(PatchDMap p) -> PatchMap $

151− Map.fromDistinctAscList $ (\(k :=> ComposeMaybe mr) -> (Some.This k, fmap (getQueryTLoweredResultWritten . getCompose) mr)) <$> DMap.toList p

149+ Map.fromDistinctAscList $ (\(k :=> ComposeMaybe mr) -> (Some k, fmap (getQueryTLoweredResultWritten . getCompose) mr)) <$> DMap.toList p

152 sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q

150 sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q

153 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty

151 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty

154 accumBehaviors :: forall m'. MonadHold t m'

152 accumBehaviors :: forall m'. MonadHold t m'

@@ -189,10 +187,10 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t

189 let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0

187 let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0

190 liftedResult' = fforCheap result' $ mapPatchDMapWithMove (getQueryTLoweredResultValue . getCompose)

188 liftedResult' = fforCheap result' $ mapPatchDMapWithMove (getQueryTLoweredResultValue . getCompose)

191 liftedBs0 :: Map (Some k) [Behavior t q]

189 liftedBs0 :: Map (Some k) [Behavior t q]

192− liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0

190+ liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0

193 liftedBs' :: Event t (PatchMapWithMove (Some k) [Behavior t q])

191 liftedBs' :: Event t (PatchMapWithMove (Some k) [Behavior t q])

194 liftedBs' = fforCheap result' $ weakenPatchDMapWithMoveWith (getQueryTLoweredResultWritten . getCompose) {- \(PatchDMap p) -> PatchMapWithMove $

192 liftedBs' = fforCheap result' $ weakenPatchDMapWithMoveWith (getQueryTLoweredResultWritten . getCompose) {- \(PatchDMap p) -> PatchMapWithMove $

195− Map.fromDistinctAscList $ (\(k :=> mr) -> (Some.This k, fmap (fmap (getQueryTLoweredResultWritten . getCompose)) mr)) <$> DMap.toList p -}

193+ Map.fromDistinctAscList $ (\(k :=> mr) -> (Some k, fmap (fmap (getQueryTLoweredResultWritten . getCompose)) mr)) <$> DMap.toList p -}

196 sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q

194 sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q

197 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty

195 sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty

198 accumBehaviors' :: forall m'. MonadHold t m'

196 accumBehaviors' :: forall m'. MonadHold t m'

src/Reflex/Query/Class.hs−1

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

3{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FunctionalDependencies #-}

5{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE TypeFamilies #-}

6{-# LANGUAGE TypeFamilies #-}

8{-# LANGUAGE UndecidableInstances #-}

7{-# LANGUAGE UndecidableInstances #-}

9-- |

8-- |

src/Reflex/Requester/Base.hs+2−3

@@ -66,8 +66,7 @@ import qualified Data.Map as Map

66import Data.Monoid ((<>))

67import Data.Proxy

68import qualified Data.Semigroup as S

69−import Data.Some (Some)

69+import Data.Some (Some(Some))

70−import qualified Data.Some as Some

71import Data.Type.Equality

70import Data.Type.Equality

72import Data.Unique.Tag

71import Data.Unique.Tag

@@ -441,7 +440,7 @@ traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchN

441 pack = Entry

440 pack = Entry

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

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

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

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

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

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

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

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

446 ndm' <- numberOccurrencesFrom 1 dm'

445 ndm' <- numberOccurrencesFrom 1 dm'

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

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

src/Reflex/Requester/Class.hs−1

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

6{-# LANGUAGE CPP #-}

7{-# LANGUAGE FlexibleInstances #-}

8{-# LANGUAGE FunctionalDependencies #-}

9−{-# LANGUAGE MultiParamTypeClasses #-}

10{-# LANGUAGE RecursiveDo #-}

9{-# LANGUAGE RecursiveDo #-}

11{-# LANGUAGE TypeFamilies #-}

10{-# LANGUAGE TypeFamilies #-}

12{-# LANGUAGE UndecidableInstances #-}

11{-# LANGUAGE UndecidableInstances #-}

src/Reflex/Spider/Internal.hs+274−199

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

9{-# LANGUAGE GADTs #-}

10{-# LANGUAGE GeneralizedNewtypeDeriving #-}

11{-# LANGUAGE LambdaCase #-}

12−{-# LANGUAGE MultiParamTypeClasses #-}

13{-# LANGUAGE MultiWayIf #-}

12{-# LANGUAGE MultiWayIf #-}

14{-# LANGUAGE RankNTypes #-}

13{-# LANGUAGE RankNTypes #-}

15{-# LANGUAGE RoleAnnotations #-}

14{-# LANGUAGE RoleAnnotations #-}

@@ -17,9 +16,15 @@

17{-# LANGUAGE TypeFamilies #-}

16{-# LANGUAGE TypeFamilies #-}

18{-# LANGUAGE TypeOperators #-}

17{-# LANGUAGE TypeOperators #-}

19{-# LANGUAGE UndecidableInstances #-}

18{-# LANGUAGE UndecidableInstances #-}

19+{-# LANGUAGE PolyKinds #-}

20+{-# LANGUAGE DeriveFunctor #-}

21+{-# LANGUAGE StandaloneDeriving #-}

22+{-# LANGUAGE InstanceSigs #-}

23+

20#ifdef USE_REFLEX_OPTIMIZER

24#ifdef USE_REFLEX_OPTIMIZER

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

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

22#endif

26#endif

27+{-# OPTIONS_GHC -Wunused-binds #-}

23-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses

28-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses

24-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.

29-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.

25module Reflex.Spider.Internal (module Reflex.Spider.Internal) where

30module Reflex.Spider.Internal (module Reflex.Spider.Internal) where

@@ -33,7 +38,10 @@ import Control.Monad hiding (forM, forM_, mapM, mapM_)

33import Control.Monad.Exception

38import Control.Monad.Exception

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

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

35import Control.Monad.Primitive

40import Control.Monad.Primitive

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

41+--import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_)

42+import Control.Monad.Reader.Class

43+import Control.Monad.IO.Class

44+import Control.Monad.ReaderIO

37import Control.Monad.Ref

45import Control.Monad.Ref

38import Data.Align

46import Data.Align

39import Data.Coerce

47import Data.Coerce

@@ -49,6 +57,7 @@ import Data.GADT.Compare

49import Data.IntMap.Strict (IntMap)

57import Data.IntMap.Strict (IntMap)

50import qualified Data.IntMap.Strict as IntMap

58import qualified Data.IntMap.Strict as IntMap

51import Data.IORef

59import Data.IORef

60+import Data.Kind (Type)

52import Data.Maybe hiding (mapMaybe)

61import Data.Maybe hiding (mapMaybe)

53import Data.Monoid ((<>))

62import Data.Monoid ((<>))

54import Data.Proxy

63import Data.Proxy

@@ -63,6 +72,15 @@ import System.IO.Unsafe

63import System.Mem.Weak

72import System.Mem.Weak

64import Unsafe.Coerce

73import Unsafe.Coerce

75+#ifdef MIN_VERSION_semialign

76+#if MIN_VERSION_these(0,8,0)

77+import Data.These.Combinators (justThese)

78+#endif

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

80+import Data.Zip (Zip (..))

81+#endif

82+#endif

83+

66#ifdef DEBUG_CYCLES

84#ifdef DEBUG_CYCLES

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

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

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

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

@@ -74,9 +92,9 @@ import Data.Tree (Forest, Tree (..), drawForest)

74import Data.FastWeakBag (FastWeakBag)

92import Data.FastWeakBag (FastWeakBag)

75import qualified Data.FastWeakBag as FastWeakBag

93import qualified Data.FastWeakBag as FastWeakBag

76import Data.Reflection

94import Data.Reflection

77−import Data.Some (Some)

95+import Data.Some (Some(Some))

78−import qualified Data.Some as Some

79import Data.Type.Coercion

96import Data.Type.Coercion

97+import Data.Profunctor.Unsafe ((#.), (.#))

80import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)

98import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)

81import qualified Data.WeakBag as WeakBag

99import qualified Data.WeakBag as WeakBag

82import qualified Reflex.Class

100import qualified Reflex.Class

@@ -85,6 +103,7 @@ import qualified Reflex.Host.Class

85import Reflex.NotReady.Class

103import Reflex.NotReady.Class

86import Reflex.Patch

104import Reflex.Patch

87import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove

105import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove

106+import Reflex.PerformEvent.Base (PerformEventT)

107

89#ifdef DEBUG_TRACE_EVENTS

108#ifdef DEBUG_TRACE_EVENTS

90import qualified Data.ByteString.Char8 as BS8

109import qualified Data.ByteString.Char8 as BS8

@@ -193,12 +212,6 @@ nextNodeIdRef = unsafePerformIO $ newIORef 1

193

212

194newNodeId :: IO Int

213newNodeId :: IO Int

195newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)

214newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)

196−

197−{-# NOINLINE unsafeNodeId #-}

198−unsafeNodeId :: a -> Int

199−unsafeNodeId a = unsafePerformIO $ do

200− touch a

201− newNodeId

202#endif

215#endif

203

216

204--------------------------------------------------------------------------------

217--------------------------------------------------------------------------------

@@ -302,9 +315,10 @@ cacheEvent e =

302#else

315#else

303 Event $

316 Event $

304#endif

317#endif

318+ unsafePerformIO $ do

305− let mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))

319+ mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))

306− !mSubscribedRef = unsafeNewIORef e emptyFastWeak

320+ <- newIORef emptyFastWeak

307− in \sub -> {-# SCC "cacheEvent" #-} do

321+ pure $ \sub -> {-# SCC "cacheEvent" #-} do

308#ifdef DEBUG_TRACE_EVENTS

322#ifdef DEBUG_TRACE_EVENTS

309 unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite

323 unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite

310#endif

324#endif

@@ -319,9 +333,9 @@ cacheEvent e =

319 scheduleClear occRef

333 scheduleClear occRef

320 propagateFast a subscribers

334 propagateFast a subscribers

321 , subscriberInvalidateHeight = \old -> do

335 , subscriberInvalidateHeight = \old -> do

322− FastWeakBag.traverse subscribers $ invalidateSubscriberHeight old

336+ FastWeakBag.traverse_ subscribers $ invalidateSubscriberHeight old

323 , subscriberRecalculateHeight = \new -> do

337 , subscriberRecalculateHeight = \new -> do

324− FastWeakBag.traverse subscribers $ recalculateSubscriberHeight new

338+ FastWeakBag.traverse_ subscribers $ recalculateSubscriberHeight new

325 }

339 }

326 when (isJust occ) $ do

340 when (isJust occ) $ do

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

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

@@ -370,7 +384,7 @@ eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed

370eventNever :: Event x a

384eventNever :: Event x a

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

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

372

386

373−eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k -> Event x a

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

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

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

375

389

376eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a

390eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a

@@ -422,14 +436,14 @@ newSubscriberHold h = return $ Subscriber

422 , subscriberRecalculateHeight = \_ -> return ()

436 , subscriberRecalculateHeight = \_ -> return ()

423 }

437 }

424

438

425−newSubscriberFan :: forall x k. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k -> IO (Subscriber x (DMap k Identity))

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

426newSubscriberFan subscribed = return $ Subscriber

440newSubscriberFan subscribed = return $ Subscriber

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

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

428 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed

442 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed

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

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

430 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a

444 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a

431 scheduleClear $ fanSubscribedOccurrence subscribed

445 scheduleClear $ fanSubscribedOccurrence subscribed

432− let f _ (Pair (Identity v) subsubs) = do

446+ let f _ (Pair v subsubs) = do

433 propagate v $ _fanSubscribedChildren_list subsubs

447 propagate v $ _fanSubscribedChildren_list subsubs

434 return $ Constant ()

448 return $ Constant ()

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

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

@@ -437,12 +451,12 @@ newSubscriberFan subscribed = return $ Subscriber

437 , subscriberInvalidateHeight = \old -> do

451 , subscriberInvalidateHeight = \old -> do

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

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

439 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

453 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

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

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

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

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

442 , subscriberRecalculateHeight = \new -> do

456 , subscriberRecalculateHeight = \new -> do

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

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

444 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

458 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

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

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

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

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

447 }

461 }

448

462

@@ -458,7 +472,7 @@ newSubscriberSwitch subscribed = return $ Subscriber

458 oldHeight <- readIORef $ switchSubscribedHeight subscribed

472 oldHeight <- readIORef $ switchSubscribedHeight subscribed

459 when (oldHeight /= invalidHeight) $ do

473 when (oldHeight /= invalidHeight) $ do

460 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight

474 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight

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

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

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

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

463 , subscriberRecalculateHeight = \new -> do

477 , subscriberRecalculateHeight = \new -> do

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

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

@@ -481,8 +495,8 @@ newSubscriberCoincidenceOuter subscribed = return $ Subscriber

481 Nothing -> do

495 Nothing -> do

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

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

483 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight

497 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight

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

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

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

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

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

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

487 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ

501 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ

488 scheduleClear $ coincidenceSubscribedOccurrence subscribed

502 scheduleClear $ coincidenceSubscribedOccurrence subscribed

@@ -529,14 +543,14 @@ propagate :: a -> WeakBag (Subscriber x a) -> EventM x ()

529propagate a subscribers = withIncreasedDepth $ do

543propagate a subscribers = withIncreasedDepth $ do

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

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

531 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work

545 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work

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

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

533

547

534-- | Propagate everything at the current height

548-- | Propagate everything at the current height

535propagateFast :: a -> FastWeakBag (Subscriber x a) -> EventM x ()

549propagateFast :: a -> FastWeakBag (Subscriber x a) -> EventM x ()

536propagateFast a subscribers = withIncreasedDepth $ do

550propagateFast a subscribers = withIncreasedDepth $ do

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

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

538 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work

552 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work

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

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

540

554

541--------------------------------------------------------------------------------

555--------------------------------------------------------------------------------

542-- EventSubscribed

556-- EventSubscribed

@@ -545,6 +559,11 @@ propagateFast a subscribers = withIncreasedDepth $ do

545toAny :: a -> Any

559toAny :: a -> Any

546toAny = unsafeCoerce

560toAny = unsafeCoerce

547

561

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

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

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

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

566+-- perfectly safe.

548data EventSubscribed x = EventSubscribed

567data EventSubscribed x = EventSubscribed

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

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

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

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

@@ -577,12 +596,12 @@ eventSubscribedNever = EventSubscribed

577#endif

596#endif

578 }

597 }

579

598

580−eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x

599+eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x

581eventSubscribedFan !subscribed = EventSubscribed

600eventSubscribedFan !subscribed = EventSubscribed

582 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed

601 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed

583 , eventSubscribedRetained = toAny subscribed

602 , eventSubscribedRetained = toAny subscribed

584#ifdef DEBUG_CYCLES

603#ifdef DEBUG_CYCLES

585− , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]

604+ , eventSubscribedGetParents = return [Some $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]

586 , eventSubscribedHasOwnHeightRef = False

605 , eventSubscribedHasOwnHeightRef = False

587 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed

606 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed

588#endif

607#endif

@@ -595,7 +614,7 @@ eventSubscribedSwitch !subscribed = EventSubscribed

595#ifdef DEBUG_CYCLES

614#ifdef DEBUG_CYCLES

596 , eventSubscribedGetParents = do

615 , eventSubscribedGetParents = do

597 s <- readIORef $ switchSubscribedCurrentParent subscribed

616 s <- readIORef $ switchSubscribedCurrentParent subscribed

598− return [Some.This $ _eventSubscription_subscribed s]

617+ return [Some $ _eventSubscription_subscribed s]

599 , eventSubscribedHasOwnHeightRef = True

618 , eventSubscribedHasOwnHeightRef = True

600 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed

619 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed

601#endif

620#endif

@@ -608,8 +627,8 @@ eventSubscribedCoincidence !subscribed = EventSubscribed

608#ifdef DEBUG_CYCLES

627#ifdef DEBUG_CYCLES

609 , eventSubscribedGetParents = do

628 , eventSubscribedGetParents = do

610 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed

629 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed

611− let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed

630+ let outerParent = Some $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed

612− innerParents = maybeToList $ fmap Some.This innerSubscription

631+ innerParents = maybeToList $ fmap Some innerSubscription

613 return $ outerParent : innerParents

632 return $ outerParent : innerParents

614 , eventSubscribedHasOwnHeightRef = True

633 , eventSubscribedHasOwnHeightRef = True

615 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed

634 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed

@@ -625,13 +644,13 @@ whoCreatedEventSubscribed = eventSubscribedWhoCreated

625

644

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

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

627walkInvalidHeightParents s0 = do

646walkInvalidHeightParents s0 = do

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

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

629 h <- liftIO $ readIORef $ eventSubscribedHeightRef s

648 h <- liftIO $ readIORef $ eventSubscribedHeightRef s

630 when (h == invalidHeight) $ do

649 when (h == invalidHeight) $ do

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

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

632− modify (Some.This s :)

651+ modify (Some s :)

633 mapM_ loop =<< liftIO (eventSubscribedGetParents s)

652 mapM_ loop =<< liftIO (eventSubscribedGetParents s)

634− forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight

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

635 return subscribers

654 return subscribers

636#endif

655#endif

637

656

@@ -659,7 +678,7 @@ behaviorPull !p = Behavior $ do

659 val <- liftIO $ readIORef $ pullValue p

678 val <- liftIO $ readIORef $ pullValue p

660 case val of

679 case val of

661 Just subscribed -> do

680 Just subscribed -> do

662− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some.This (BehaviorSubscribedPull subscribed)) :))

681+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedPull subscribed)) :))

663 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))

682 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))

664 liftIO $ touch $ pullSubscribedOwnInvalidator subscribed

683 liftIO $ touch $ pullSubscribedOwnInvalidator subscribed

665 return $ pullSubscribedValue subscribed

684 return $ pullSubscribedValue subscribed

@@ -668,7 +687,7 @@ behaviorPull !p = Behavior $ do

668 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"

687 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"

669 parentsRef <- liftIO $ newIORef []

688 parentsRef <- liftIO $ newIORef []

670 holdInits <- askBehaviorHoldInits

689 holdInits <- askBehaviorHoldInits

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

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

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

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

673 parents <- liftIO $ readIORef parentsRef

692 parents <- liftIO $ readIORef parentsRef

674 let subscribed = PullSubscribed

693 let subscribed = PullSubscribed

@@ -678,7 +697,7 @@ behaviorPull !p = Behavior $ do

678 , pullSubscribedParents = parents

697 , pullSubscribedParents = parents

679 }

698 }

680 liftIO $ writeIORef (pullValue p) $ Just subscribed

699 liftIO $ writeIORef (pullValue p) $ Just subscribed

681− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some.This (BehaviorSubscribedPull subscribed)) :))

700+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedPull subscribed)) :))

682 return a

701 return a

683

702

684behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p)

703behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p)

@@ -689,7 +708,7 @@ readHoldTracked :: Hold x p -> BehaviorM x (PatchTarget p)

689readHoldTracked h = do

708readHoldTracked h = do

690 result <- liftIO $ readIORef $ holdValue h

709 result <- liftIO $ readIORef $ holdValue h

691 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))

710 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))

692− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some.This (BehaviorSubscribedHold h)) :))

711+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedHold h)) :))

693 liftIO $ touch h -- Otherwise, if this gets inlined enough, the hold's parent reference may get collected

712 liftIO $ touch h -- Otherwise, if this gets inlined enough, the hold's parent reference may get collected

694 return result

713 return result

695

714

@@ -703,42 +722,46 @@ readBehaviorUntracked b = do

703-- Dynamic

722-- Dynamic

704--------------------------------------------------------------------------------

723--------------------------------------------------------------------------------

705

724

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

726+

706−data Dynamic x p = Dynamic

727+data Dynamic x target p = Dynamic

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

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

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

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

709 }

730 }

710

731

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

733+

734+

735+

736+

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

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

712dynamicHold !h = Dynamic

738dynamicHold !h = Dynamic

713 { dynamicCurrent = behaviorHold h

739 { dynamicCurrent = behaviorHold h

714 , dynamicUpdated = eventHold h

740 , dynamicUpdated = eventHold h

715 }

741 }

716

742

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

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

718dynamicHoldIdentity = dynamicHold

744dynamicHoldIdentity = dynamicHold

719

745

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

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

721dynamicConst !a = Dynamic

747dynamicConst !a = Dynamic

722 { dynamicCurrent = behaviorConst a

748 { dynamicCurrent = behaviorConst a

723 , dynamicUpdated = eventNever

749 , dynamicUpdated = eventNever

724 }

750 }

725

751

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

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

727dynamicDyn !d = Dynamic

753dynamicDyn !d = Dynamic

728 { dynamicCurrent = behaviorDyn d

754 { dynamicCurrent = behaviorDyn d

729 , dynamicUpdated = eventDyn d

755 , dynamicUpdated = eventDyn d

730 }

756 }

731

757

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

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

733dynamicDynIdentity = dynamicDyn

759dynamicDynIdentity = dynamicDyn

734

760

735--------------------------------------------------------------------------------

761--------------------------------------------------------------------------------

736-- Combinators

762-- Combinators

737--------------------------------------------------------------------------------

763--------------------------------------------------------------------------------

738

764

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

740−--representational so we can use coerce

741−

742--type role Hold representational

765--type role Hold representational

743data Hold x p

766data Hold x p

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

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

@@ -759,20 +782,25 @@ globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv

759

782

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

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

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

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

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

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

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

788+type role SpiderTimelineEnv nominal

789+

762−data SpiderTimelineEnv x = SpiderTimelineEnv

790+data SpiderTimelineEnv' x = SpiderTimelineEnv

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

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

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

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

765#ifdef DEBUG

793#ifdef DEBUG

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

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

767#endif

795#endif

768 }

796 }

769−type role SpiderTimelineEnv nominal

797+type role SpiderTimelineEnv' phantom

770

798

771instance Eq (SpiderTimelineEnv x) where

799instance Eq (SpiderTimelineEnv x) where

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

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

773

801

774instance GEq SpiderTimelineEnv where

802instance GEq SpiderTimelineEnv where

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

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

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

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

777 else Nothing

805 else Nothing

778

806

@@ -795,7 +823,7 @@ runEventM :: EventM x a -> IO a

795runEventM = unEventM

823runEventM = unEventM

796

824

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

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

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

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

799

827

800class MonadIO m => Defer a m where

828class MonadIO m => Defer a m where

801 getDeferralQueue :: m (IORef [a])

829 getDeferralQueue :: m (IORef [a])

@@ -862,7 +890,7 @@ instance HasSpiderTimeline x => Defer (Some Clear) (EventM x) where

862

890

863{-# INLINE scheduleClear #-}

891{-# INLINE scheduleClear #-}

864scheduleClear :: Defer (Some Clear) m => IORef (Maybe a) -> m ()

892scheduleClear :: Defer (Some Clear) m => IORef (Maybe a) -> m ()

865−scheduleClear r = defer $ Some.This $ Clear r

893+scheduleClear r = defer $ Some $ Clear r

866

894

867instance HasSpiderTimeline x => Defer (Some IntClear) (EventM x) where

895instance HasSpiderTimeline x => Defer (Some IntClear) (EventM x) where

868 {-# INLINE getDeferralQueue #-}

896 {-# INLINE getDeferralQueue #-}

@@ -870,7 +898,7 @@ instance HasSpiderTimeline x => Defer (Some IntClear) (EventM x) where

870

898

871{-# INLINE scheduleIntClear #-}

899{-# INLINE scheduleIntClear #-}

872scheduleIntClear :: Defer (Some IntClear) m => IORef (IntMap a) -> m ()

900scheduleIntClear :: Defer (Some IntClear) m => IORef (IntMap a) -> m ()

873−scheduleIntClear r = defer $ Some.This $ IntClear r

901+scheduleIntClear r = defer $ Some $ IntClear r

874

902

875instance HasSpiderTimeline x => Defer (Some RootClear) (EventM x) where

903instance HasSpiderTimeline x => Defer (Some RootClear) (EventM x) where

876 {-# INLINE getDeferralQueue #-}

904 {-# INLINE getDeferralQueue #-}

@@ -878,7 +906,7 @@ instance HasSpiderTimeline x => Defer (Some RootClear) (EventM x) where

878

906

879{-# INLINE scheduleRootClear #-}

907{-# INLINE scheduleRootClear #-}

880scheduleRootClear :: Defer (Some RootClear) m => IORef (DMap k Identity) -> m ()

908scheduleRootClear :: Defer (Some RootClear) m => IORef (DMap k Identity) -> m ()

881−scheduleRootClear r = defer $ Some.This $ RootClear r

909+scheduleRootClear r = defer $ Some $ RootClear r

882

910

883instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where

911instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where

884 {-# INLINE getDeferralQueue #-}

912 {-# INLINE getDeferralQueue #-}

@@ -933,9 +961,9 @@ getHoldEventSubscription h = do

933

961

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

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

935

963

936−--type role BehaviorM representational

937-- BehaviorM can sample behaviors

964-- BehaviorM can sample behaviors

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

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

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

939

967

940instance Monad (BehaviorM x) where

968instance Monad (BehaviorM x) where

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

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

@@ -986,7 +1014,7 @@ data RootSubscribed x a = forall k. GCompare k => RootSubscribed

986#endif

1014#endif

987 }

1015 }

988

1016

989−data Root x (k :: * -> *)

1017+data Root x k

990 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event

1018 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event

991 , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))

1019 , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))

992 , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))

1020 , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))

@@ -1056,25 +1084,25 @@ heightBagVerify b@(HeightBag s c) = if

1056heightBagVerify = id

1084heightBagVerify = id

1057#endif

1085#endif

1058

1086

1059−data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren

1087+data FanSubscribedChildren x k v a = FanSubscribedChildren

1060− { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a))

1088+ { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x (v a)))

1061− , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k)

1089+ , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k v)

1062− , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k)))

1090+ , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k v)))

1063 }

1091 }

1064

1092

1065−data FanSubscribed (x :: *) k

1093+data FanSubscribed x k v

1066− = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k)))

1094+ = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))

1067− , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))

1095+ , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k v)))

1068− , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty

1096+ , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k v))) -- This DMap should never be empty

1069 , fanSubscribedParent :: !(EventSubscription x)

1097 , fanSubscribedParent :: !(EventSubscription x)

1070#ifdef DEBUG_NODEIDS

1098#ifdef DEBUG_NODEIDS

1071 , fanSubscribedNodeId :: Int

1099 , fanSubscribedNodeId :: Int

1072#endif

1100#endif

1073 }

1101 }

1074

1102

1075−data Fan x k

1103+data Fan x k v

1076− = Fan { fanParent :: !(Event x (DMap k Identity))

1104+ = Fan { fanParent :: !(Event x (DMap k v))

1077− , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k)))

1105+ , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))

1078 }

1106 }

1079

1107

1080data SwitchSubscribed x a

1108data SwitchSubscribed x a

@@ -1136,19 +1164,27 @@ instance HasSpiderTimeline x => Align (Event x) where

1136#if MIN_VERSION_these(0, 8, 0)

1164#if MIN_VERSION_these(0, 8, 0)

1137instance HasSpiderTimeline x => Semialign (Event x) where

1165instance HasSpiderTimeline x => Semialign (Event x) where

1138#endif

1166#endif

1167+ align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $

1139− align ea eb = mapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]

1168+ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]

1169+

1170+#ifdef MIN_VERSION_semialign

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

1172+instance HasSpiderTimeline x => Zip (Event x) where

1173+#endif

1174+ zip x y = mapMaybe justThese $ align x y

1175+#endif

1140

1176

1141data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)

1177data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)

1142 | BuildDyn !(EventM x (PatchTarget p), Event x p)

1178 | BuildDyn !(EventM x (PatchTarget p), Event x p)

1143 | HoldDyn !(Hold x p)

1179 | HoldDyn !(Hold x p)

1144

1180

1145−newtype Dyn x p = Dyn { unDyn :: IORef (DynType x p) }

1181+newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }

1146

1182

1147−newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)

1183+newMapDyn :: HasSpiderTimeline x => (a -> b) -> DynamicS x (Identity a) -> DynamicS x (Identity b)

1148newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)

1184newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)

1149

1185

1150--TODO: Avoid the duplication between this and R.zipDynWith

1186--TODO: Avoid the duplication between this and R.zipDynWith

1151−zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c)

1187+zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> DynamicS x (Identity a) -> DynamicS x (Identity b) -> DynamicS x (Identity c)

1152zipDynWith f da db =

1188zipDynWith f da db =

1153 let eab = align (dynamicUpdated da) (dynamicUpdated db)

1189 let eab = align (dynamicUpdated da) (dynamicUpdated db)

1154 ec = flip push eab $ \o -> do

1190 ec = flip push eab $ \o -> do

@@ -1171,18 +1207,12 @@ buildDynamic readV0 v' = do

1171 return d

1207 return d

1172

1208

1173unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p

1209unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p

1174−unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ UnsafeDyn x

1210+unsafeBuildDynamic readV0 v' =

1175− where x = (readV0, v')

1211+ Dyn $ unsafePerformIO $ newIORef $ UnsafeDyn (readV0, v')

1176

1212

1177-- ResultM can read behaviors and events

1213-- ResultM can read behaviors and events

1178type ResultM = EventM

1214type ResultM = EventM

1179

1215

1180−{-# NOINLINE unsafeNewIORef #-}

1181−unsafeNewIORef :: a -> b -> IORef b

1182−unsafeNewIORef a b = unsafePerformIO $ do

1183− touch a

1184− newIORef b

1185−

1186instance HasSpiderTimeline x => Functor (Event x) where

1216instance HasSpiderTimeline x => Functor (Event x) where

1187 fmap f = push $ return . Just . f

1217 fmap f = push $ return . Just . f

1188

1218

@@ -1195,33 +1225,42 @@ push f e = cacheEvent (pushCheap f e)

1195

1225

1196{-# INLINABLE pull #-}

1226{-# INLINABLE pull #-}

1197pull :: BehaviorM x a -> Behavior x a

1227pull :: BehaviorM x a -> Behavior x a

1198−pull a = behaviorPull $ Pull

1228+pull a = unsafePerformIO $ do

1199− { pullCompute = a

1229+ ref <- newIORef Nothing

1200− , pullValue = unsafeNewIORef a Nothing

1201#ifdef DEBUG_NODEIDS

1230#ifdef DEBUG_NODEIDS

1202− , pullNodeId = unsafeNodeId a

1231+ nid <- newNodeId

1203#endif

1232#endif

1233+ pure $ behaviorPull $ Pull

1234+ { pullCompute = a

1235+ , pullValue = ref

1236+#ifdef DEBUG_NODEIDS

1237+ , pullNodeId = nid

1238+#endif

1204− }

1239+ }

1205

1240

1206{-# INLINABLE switch #-}

1241{-# INLINABLE switch #-}

1207switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a

1242switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a

1243+switch a = unsafePerformIO $ do

1244+ ref <- newIORef Nothing

1208−switch a = eventSwitch $ Switch

1245+ pure $ eventSwitch $ Switch

1209− { switchParent = a

1246+ { switchParent = a

1210− , switchSubscribed = unsafeNewIORef a Nothing

1247+ , switchSubscribed = ref

1211− }

1248+ }

1212

1249

1213coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a

1250coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a

1251+coincidence a = unsafePerformIO $ do

1252+ ref <- newIORef Nothing

1214−coincidence a = eventCoincidence $ Coincidence

1253+ pure $ eventCoincidence $ Coincidence

1215− { coincidenceParent = a

1254+ { coincidenceParent = a

1216− , coincidenceSubscribed = unsafeNewIORef a Nothing

1255+ , coincidenceSubscribed = ref

1217− }

1256+ }

1218

1257

1219-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors

1258-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors

1220run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b

1259run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b

1221run roots after = do

1260run roots after = do

1222 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"

1261 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"

1223 let t = spiderTimeline :: SpiderTimelineEnv x

1262 let t = spiderTimeline :: SpiderTimelineEnv x

1224− result <- SpiderHost $ withMVar (_spiderTimeline_lock t) $ \_ -> unSpiderHost $ runFrame $ do

1263+ result <- SpiderHost $ withMVar (_spiderTimeline_lock (unSTE t)) $ \_ -> unSpiderHost $ runFrame $ do

1225 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do

1264 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do

1226 occBefore <- liftIO $ do

1265 occBefore <- liftIO $ do

1227 occBefore <- readIORef occRef

1266 occBefore <- readIORef occRef

@@ -1285,9 +1324,9 @@ type WeakList a = [Weak a]

1285withIncreasedDepth :: CanTrace x m => m a -> m a

1324withIncreasedDepth :: CanTrace x m => m a -> m a

1286withIncreasedDepth a = do

1325withIncreasedDepth a = do

1287 spiderTimeline <- askSpiderTimelineEnv

1326 spiderTimeline <- askSpiderTimelineEnv

1288− liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ

1327+ liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) succ

1289 result <- a

1328 result <- a

1290− liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred

1329+ liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) pred

1291 return result

1330 return result

1292#else

1331#else

1293withIncreasedDepth :: m a -> m a

1332withIncreasedDepth :: m a -> m a

@@ -1314,7 +1353,7 @@ traceMWhen _ b getMessage = when b $ do

1314 message <- getMessage

1353 message <- getMessage

1315#ifdef DEBUG

1354#ifdef DEBUG

1316 spiderTimeline <- askSpiderTimelineEnv

1355 spiderTimeline <- askSpiderTimelineEnv

1317− d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline

1356+ d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE spiderTimeline

1318#else

1357#else

1319 let d = 0

1358 let d = 0

1320#endif

1359#endif

@@ -1355,25 +1394,25 @@ propagateSubscriberHold h a = do

1355data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset

1394data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset

1356

1395

1357runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a

1396runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a

1358−runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)

1397+runBehaviorM a mwi holdInits = runReaderIO (unBehaviorM a) (mwi, holdInits)

1359

1398

1360askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))

1399askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))

1361askInvalidator = do

1400askInvalidator = do

1362− (!m, _) <- BehaviorM ask

1401+ (!m, _) <- ask

1363 case m of

1402 case m of

1364 Nothing -> return Nothing

1403 Nothing -> return Nothing

1365 Just (!wi, _) -> return $ Just wi

1404 Just (!wi, _) -> return $ Just wi

1366

1405

1367askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))

1406askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))

1368askParentsRef = do

1407askParentsRef = do

1369− (!m, _) <- BehaviorM ask

1408+ (!m, _) <- ask

1370 case m of

1409 case m of

1371 Nothing -> return Nothing

1410 Nothing -> return Nothing

1372 Just (_, !p) -> return $ Just p

1411 Just (_, !p) -> return $ Just p

1373

1412

1374askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])

1413askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])

1375askBehaviorHoldInits = do

1414askBehaviorHoldInits = do

1376− (_, !his) <- BehaviorM ask

1415+ (_, !his) <- ask

1377 return his

1416 return his

1378

1417

1379{-# INLINE getDynHold #-}

1418{-# INLINE getDynHold #-}

@@ -1418,6 +1457,9 @@ getRootSubscribed k r sub = do

1418 when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"

1457 when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"

1419 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)

1458 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)

1420 writeIORef uninitRef $! uninit

1459 writeIORef uninitRef $! uninit

1460+#ifdef DEBUG_NODEIDS

1461+ nid <- newNodeId

1462+#endif

1421 let !subscribed = RootSubscribed

1463 let !subscribed = RootSubscribed

1422 { rootSubscribedKey = k

1464 { rootSubscribedKey = k

1423 , rootSubscribedCachedSubscribed = cached

1465 , rootSubscribedCachedSubscribed = cached

@@ -1426,7 +1468,7 @@ getRootSubscribed k r sub = do

1426 , rootSubscribedUninit = uninit

1468 , rootSubscribedUninit = uninit

1427 , rootSubscribedWeakSelf = weakSelf

1469 , rootSubscribedWeakSelf = weakSelf

1428#ifdef DEBUG_NODEIDS

1470#ifdef DEBUG_NODEIDS

1429− , rootSubscribedNodeId = unsafeNodeId (k, r, subs)

1471+ , rootSubscribedNodeId = nid

1430#endif

1472#endif

1431 }

1473 }

1432 -- If we die at the same moment that all our children die, they will

1474 -- If we die at the same moment that all our children die, they will

@@ -1475,16 +1517,10 @@ newFanInt = do

1475 , _fanInt_occRef = occRef

1517 , _fanInt_occRef = occRef

1476 }

1518 }

1477

1519

1478−{-# NOINLINE unsafeNewFanInt #-}

1479−unsafeNewFanInt :: b -> FanInt x a

1480−unsafeNewFanInt b = unsafePerformIO $ do

1481− touch b

1482− newFanInt

1483−

1484fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a

1520fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a

1485−fanInt p =

1521+fanInt p = unsafePerformIO $ do

1486− let self = unsafeNewFanInt p

1522+ self <- newFanInt

1487− in EventSelectorInt $ \k -> Event $ \sub -> do

1523+ pure $ EventSelectorInt $ \k -> Event $ \sub -> do

1488 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)

1524 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)

1489 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input

1525 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input

1490 (subscription, parentOcc) <- subscribeAndRead p $ Subscriber

1526 (subscription, parentOcc) <- subscribeAndRead p $ Subscriber

@@ -1492,15 +1528,15 @@ fanInt p =

1492 liftIO $ writeIORef (_fanInt_occRef self) m

1528 liftIO $ writeIORef (_fanInt_occRef self) m

1493 scheduleIntClear $ _fanInt_occRef self

1529 scheduleIntClear $ _fanInt_occRef self

1494 FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> do --TODO: Do we need to know that no subscribers are being added as we traverse?

1530 FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> do --TODO: Do we need to know that no subscribers are being added as we traverse?

1495− FastWeakBag.traverse b $ \s -> do

1531+ FastWeakBag.traverse_ b $ \s -> do

1496 subscriberPropagate s v

1532 subscriberPropagate s v

1497 , subscriberInvalidateHeight = \old -> do

1533 , subscriberInvalidateHeight = \old -> do

1498 FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do

1534 FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do

1499− FastWeakBag.traverse b $ \s -> do

1535+ FastWeakBag.traverse_ b $ \s -> do

1500 subscriberInvalidateHeight s old

1536 subscriberInvalidateHeight s old

1501 , subscriberRecalculateHeight = \new -> do

1537 , subscriberRecalculateHeight = \new -> do

1502 FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do

1538 FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do

1503− FastWeakBag.traverse b $ \s -> do

1539+ FastWeakBag.traverse_ b $ \s -> do

1504 subscriberRecalculateHeight s new

1540 subscriberRecalculateHeight s new

1505 }

1541 }

1506 liftIO $ do

1542 liftIO $ do

@@ -1520,7 +1556,7 @@ fanInt p =

1520 return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)

1556 return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)

1521

1557

1522{-# INLINABLE getFanSubscribed #-}

1558{-# INLINABLE getFanSubscribed #-}

1523−getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket, FanSubscribed x k, Maybe a)

1559+getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k v -> Subscriber x (v a) -> EventM x (WeakBagTicket, FanSubscribed x k v, Maybe (v a))

1524getFanSubscribed k f sub = do

1560getFanSubscribed k f sub = do

1525 mSubscribed <- liftIO $ readIORef $ fanSubscribed f

1561 mSubscribed <- liftIO $ readIORef $ fanSubscribed f

1526 case mSubscribed of

1562 case mSubscribed of

@@ -1538,13 +1574,16 @@ getFanSubscribed k f sub = do

1538 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"

1574 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"

1539 occRef <- liftIO $ newIORef parentOcc

1575 occRef <- liftIO $ newIORef parentOcc

1540 when (isJust parentOcc) $ scheduleClear occRef

1576 when (isJust parentOcc) $ scheduleClear occRef

1577+#ifdef DEBUG_NODEIDS

1578+ nid <- liftIO newNodeId

1579+#endif

1541 let subscribed = FanSubscribed

1580 let subscribed = FanSubscribed

1542 { fanSubscribedCachedSubscribed = fanSubscribed f

1581 { fanSubscribedCachedSubscribed = fanSubscribed f

1543 , fanSubscribedOccurrence = occRef

1582 , fanSubscribedOccurrence = occRef

1544 , fanSubscribedParent = subscription

1583 , fanSubscribedParent = subscription

1545 , fanSubscribedSubscribers = subscribersRef

1584 , fanSubscribedSubscribers = subscribersRef

1546#ifdef DEBUG_NODEIDS

1585#ifdef DEBUG_NODEIDS

1547− , fanSubscribedNodeId = unsafeNodeId f

1586+ , fanSubscribedNodeId = nid

1548#endif

1587#endif

1549 }

1588 }

1550 let !self = (k, subscribed)

1589 let !self = (k, subscribed)

@@ -1554,7 +1593,7 @@ getFanSubscribed k f sub = do

1554 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed

1593 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed

1555 return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)

1594 return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)

1556

1595

1557−cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO ()

1596+cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k v) -> IO ()

1558cleanupFanSubscribed (k, subscribed) = do

1597cleanupFanSubscribed (k, subscribed) = do

1559 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

1598 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

1560 let reducedSubscribers = DMap.delete k subscribers

1599 let reducedSubscribers = DMap.delete k subscribers

@@ -1566,7 +1605,7 @@ cleanupFanSubscribed (k, subscribed) = do

1566 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers

1605 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers

1567

1606

1568{-# INLINE subscribeFanSubscribed #-}

1607{-# INLINE subscribeFanSubscribed #-}

1569−subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO WeakBagTicket

1608+subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k v -> Subscriber x (v a) -> IO WeakBagTicket

1570subscribeFanSubscribed k subscribed sub = do

1609subscribeFanSubscribed k subscribed sub = do

1571 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

1610 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

1572 case DMap.lookup k subscribers of

1611 case DMap.lookup k subscribers of

@@ -1604,6 +1643,9 @@ getSwitchSubscribed s sub = do

1604 when (isJust parentOcc) $ scheduleClear occRef

1643 when (isJust parentOcc) $ scheduleClear occRef

1605 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"

1644 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"

1606 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed

1645 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed

1646+#ifdef DEBUG_NODEIDS

1647+ nid <- liftIO newNodeId

1648+#endif

1607 let !subscribed = SwitchSubscribed

1649 let !subscribed = SwitchSubscribed

1608 { switchSubscribedCachedSubscribed = switchSubscribed s

1650 { switchSubscribedCachedSubscribed = switchSubscribed s

1609 , switchSubscribedOccurrence = occRef

1651 , switchSubscribedOccurrence = occRef

@@ -1616,7 +1658,7 @@ getSwitchSubscribed s sub = do

1616 , switchSubscribedCurrentParent = subscriptionRef

1658 , switchSubscribedCurrentParent = subscriptionRef

1617 , switchSubscribedWeakSelf = weakSelf

1659 , switchSubscribedWeakSelf = weakSelf

1618#ifdef DEBUG_NODEIDS

1660#ifdef DEBUG_NODEIDS

1619− , switchSubscribedNodeId = unsafeNodeId s

1661+ , switchSubscribedNodeId = nid

1620#endif

1662#endif

1621 }

1663 }

1622 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"

1664 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"

@@ -1661,6 +1703,9 @@ getCoincidenceSubscribed c sub = do

1661 scheduleClear innerSubdRef

1703 scheduleClear innerSubdRef

1662 weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"

1704 weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"

1663 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed

1705 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed

1706+#ifdef DEBUG_NODEIDS

1707+ nid <- liftIO newNodeId

1708+#endif

1664 let subscribed = CoincidenceSubscribed

1709 let subscribed = CoincidenceSubscribed

1665 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c

1710 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c

1666 , coincidenceSubscribedOccurrence = occRef

1711 , coincidenceSubscribedOccurrence = occRef

@@ -1671,7 +1716,7 @@ getCoincidenceSubscribed c sub = do

1671 , coincidenceSubscribedInnerParent = innerSubdRef

1716 , coincidenceSubscribedInnerParent = innerSubdRef

1672 , coincidenceSubscribedWeakSelf = weakSelf

1717 , coincidenceSubscribedWeakSelf = weakSelf

1673#ifdef DEBUG_NODEIDS

1718#ifdef DEBUG_NODEIDS

1674− , coincidenceSubscribedNodeId = unsafeNodeId c

1719+ , coincidenceSubscribedNodeId = nid

1675#endif

1720#endif

1676 }

1721 }

1677 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"

1722 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"

@@ -1688,26 +1733,34 @@ cleanupCoincidenceSubscribed subscribed = do

1688subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket

1733subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket

1689subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed

1734subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed

1690

1735

1691−{-# INLINE merge #-}

1736+{-# INLINE mergeG #-}

1692−merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)

1737+mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k)

1738+ => (forall a. q a -> Event x (v a))

1739+ -> DynamicS x (PatchDMap k q) -> Event x (DMap k v)

1693−merge d = cacheEvent (mergeCheap d)

1740+mergeG nt d = cacheEvent (mergeCheap nt d)

1694

1741

1695{-# INLINE mergeWithMove #-}

1742{-# INLINE mergeWithMove #-}

1696−mergeWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)

1743+mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k)

1744+ => (forall a. q a -> Event x (v a))

1745+ -> DynamicS x (PatchDMapWithMove k q) -> Event x (DMap k v)

1697−mergeWithMove d = cacheEvent (mergeCheapWithMove d)

1746+mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)

1698

1747

1699{-# INLINE [1] mergeCheap #-}

1748{-# INLINE [1] mergeCheap #-}

1749+mergeCheap

1700−mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)

1750+ :: forall k x q v. (HasSpiderTimeline x, GCompare k)

1751+ => (forall a. q a -> Event x (v a))

1752+ -> DynamicS x (PatchDMap k q)

1753+ -> Event x (DMap k v)

1701−mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy

1754+mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy

1702 where

1755 where

1703− updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)

1756+ updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)

1704 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do

1757 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do

1705 let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do

1758 let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do

1706 (mOldSubd, newPs) <- case me of

1759 (mOldSubd, newPs) <- case me of

1707 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps

1760 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps

1708 Just e -> do

1761 Just e -> do

1709 let s = subscriber $ return k

1762 let s = subscriber $ return k

1710− subscription@(EventSubscription _ subd) <- subscribe e s

1763+ subscription@(EventSubscription _ subd) <- subscribe (nt e) s

1711 newParentHeight <- liftIO $ getEventSubscribedHeight subd

1764 newParentHeight <- liftIO $ getEventSubscribedHeight subd

1712 let newParent = MergeSubscribedParent subscription

1765 let newParent = MergeSubscribedParent subscription

1713 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight

1766 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight

@@ -1717,28 +1770,33 @@ mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy

1717 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

1770 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

1718 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)

1771 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)

1719 foldM f ([], oldParents) $ DMap.toList p

1772 foldM f ([], oldParents) $ DMap.toList p

1773+

1720− getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParent x)

1774+ getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParent x)

1721 getInitialSubscribers initialParents subscriber = do

1775 getInitialSubscribers initialParents subscriber = do

1722 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do

1776 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do

1723 let s = subscriber $ return k

1777 let s = subscriber $ return k

1724− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s

1778+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s

1725 height <- liftIO $ getEventSubscribedHeight parentSubd

1779 height <- liftIO $ getEventSubscribedHeight parentSubd

1726− return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription)

1780+ return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParent subscription)

1727 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers

1781 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers

1728 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here

1782 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here

1729 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers

1783 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers

1730 )

1784 )

1785+

1731 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)

1786 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)

1732 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub

1787 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub

1733

1788

1734{-# INLINE [1] mergeCheapWithMove #-}

1789{-# INLINE [1] mergeCheapWithMove #-}

1735−mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)

1790+mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)

1791+ => (forall a. q a -> Event x (v a))

1792+ -> DynamicS x (PatchDMapWithMove k q)

1793+ -> Event x (DMap k v)

1736−mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy

1794+mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy

1737 where

1795 where

1738− updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)

1796+ updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)

1739 updateMe subscriber heightBagRef oldParents p = do

1797 updateMe subscriber heightBagRef oldParents p = do

1740 -- Prepare new parents for insertion

1798 -- Prepare new parents for insertion

1741− let subscribeParent :: forall a. k a -> Event x a -> EventM x (MergeSubscribedParentWithMove x k a)

1799+ let subscribeParent :: forall a. k a -> Event x (v a) -> EventM x (MergeSubscribedParentWithMove x k a)

1742 subscribeParent k e = do

1800 subscribeParent k e = do

1743 keyRef <- liftIO $ newIORef k

1801 keyRef <- liftIO $ newIORef k

1744 let s = subscriber $ liftIO $ readIORef keyRef

1802 let s = subscriber $ liftIO $ readIORef keyRef

@@ -1747,9 +1805,9 @@ mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy

1747 newParentHeight <- getEventSubscribedHeight subd

1805 newParentHeight <- getEventSubscribedHeight subd

1748 modifyIORef' heightBagRef $ heightBagAdd newParentHeight

1806 modifyIORef' heightBagRef $ heightBagAdd newParentHeight

1749 return $ MergeSubscribedParentWithMove subscription keyRef

1807 return $ MergeSubscribedParentWithMove subscription keyRef

1750− p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey subscribeParent p

1808+ p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey (\k q -> subscribeParent k (nt q)) p

1751 -- Collect old parents for deletion and update the keys of moved parents

1809 -- Collect old parents for deletion and update the keys of moved parents

1752− let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Event x) a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a

1810+ let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a

1753 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of

1811 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of

1754 Nothing -> do

1812 Nothing -> do

1755 oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent

1813 oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent

@@ -1760,46 +1818,47 @@ mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy

1760 return Nothing

1818 return Nothing

1761 toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents

1819 toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents

1762 return (toDelete, applyAlways p' oldParents)

1820 return (toDelete, applyAlways p' oldParents)

1763− getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k)

1821+ getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)

1764 getInitialSubscribers initialParents subscriber = do

1822 getInitialSubscribers initialParents subscriber = do

1765 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do

1823 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do

1766 keyRef <- liftIO $ newIORef k

1824 keyRef <- liftIO $ newIORef k

1767 let s = subscriber $ liftIO $ readIORef keyRef

1825 let s = subscriber $ liftIO $ readIORef keyRef

1768− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s

1826+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s

1769 height <- liftIO $ getEventSubscribedHeight parentSubd

1827 height <- liftIO $ getEventSubscribedHeight parentSubd

1770− return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)

1828+ return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)

1771 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers

1829 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers

1772 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here

1830 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here

1773 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers

1831 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers

1774 )

1832 )

1833+

1775 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)

1834 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)

1776 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub

1835 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub

1777

1836

1778−type MergeUpdateFunc k x p s

1837+type MergeUpdateFunc k v x p s

1779− = (forall a. EventM x (k a) -> Subscriber x a)

1838+ = (forall a. EventM x (k a) -> Subscriber x (v a))

1780 -> IORef HeightBag

1839 -> IORef HeightBag

1781 -> DMap k s

1840 -> DMap k s

1782 -> p

1841 -> p

1783 -> EventM x ([EventSubscription x], DMap k s)

1842 -> EventM x ([EventSubscription x], DMap k s)

1784

1843

1785−type MergeInitFunc k x s

1844+type MergeInitFunc k v q x s

1786− = DMap k (Event x)

1845+ = DMap k q

1787− -> (forall a. EventM x (k a) -> Subscriber x a)

1846+ -> (forall a. EventM x (k a) -> Subscriber x (v a))

1788− -> EventM x (DMap k Identity, [Height], DMap k s)

1847+ -> EventM x (DMap k v, [Height], DMap k s)

1789

1848

1790type MergeDestroyFunc k s

1849type MergeDestroyFunc k s

1791 = DMap k s

1850 = DMap k s

1792 -> IO ()

1851 -> IO ()

1793

1852

1794−data Merge x k s = Merge

1853+data Merge x k v s = Merge

1795 { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))

1854 { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))

1796 , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)

1855 , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)

1797 , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)

1856 , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)

1798− , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k Identity))

1857+ , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k v))

1799− , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k Identity))

1858+ , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k v))

1800 }

1859 }

1801

1860

1802−invalidateMergeHeight :: Merge x k s -> IO ()

1861+invalidateMergeHeight :: Merge x k v s -> IO ()

1803invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)

1862invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)

1804

1863

1805invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()

1864invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()

@@ -1809,8 +1868,7 @@ invalidateMergeHeight' heightRef sub = do

1809 writeIORef heightRef $! invalidHeight

1868 writeIORef heightRef $! invalidHeight

1810 subscriberInvalidateHeight sub oldHeight

1869 subscriberInvalidateHeight sub oldHeight

1811

1870

1812−

1813−revalidateMergeHeight :: Merge x k s -> IO ()

1871+revalidateMergeHeight :: Merge x k v s -> IO ()

1814revalidateMergeHeight m = do

1872revalidateMergeHeight m = do

1815 currentHeight <- readIORef $ _merge_heightRef m

1873 currentHeight <- readIORef $ _merge_heightRef m

1816 when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check

1874 when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check

@@ -1826,19 +1884,19 @@ revalidateMergeHeight m = do

1826 subscriberRecalculateHeight (_merge_sub m) height

1884 subscriberRecalculateHeight (_merge_sub m) height

1827 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"

1885 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"

1828

1886

1829−scheduleMergeSelf :: HasSpiderTimeline x => Merge x k s -> Height -> EventM x ()

1887+scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()

1830scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do

1888scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do

1831 vals <- liftIO $ readIORef $ _merge_accumRef m

1889 vals <- liftIO $ readIORef $ _merge_accumRef m

1832 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

1890 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

1833 --TODO: Assert that m is not empty

1891 --TODO: Assert that m is not empty

1834 subscriberPropagate (_merge_sub m) vals

1892 subscriberPropagate (_merge_sub m) vals

1835

1893

1836−mergeSubscriber :: forall x k s a. (HasSpiderTimeline x, GCompare k) => Merge x k s -> EventM x (k a) -> Subscriber x a

1894+mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => Merge x k v s -> EventM x (k a) -> Subscriber x (v a)

1837mergeSubscriber m getKey = Subscriber

1895mergeSubscriber m getKey = Subscriber

1838 { subscriberPropagate = \a -> do

1896 { subscriberPropagate = \a -> do

1839 oldM <- liftIO $ readIORef $ _merge_accumRef m

1897 oldM <- liftIO $ readIORef $ _merge_accumRef m

1840 k <- getKey

1898 k <- getKey

1841− let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM

1899+ let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k a oldM

1842 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)

1900 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)

1843 liftIO $ writeIORef (_merge_accumRef m) $! newM

1901 liftIO $ writeIORef (_merge_accumRef m) $! newM

1844 when (DMap.null oldM) $ do -- Only schedule the firing once

1902 when (DMap.null oldM) $ do -- Only schedule the firing once

@@ -1853,7 +1911,7 @@ mergeSubscriber m getKey = Subscriber

1853 else liftIO $ do

1911 else liftIO $ do

1854#ifdef DEBUG_CYCLES

1912#ifdef DEBUG_CYCLES

1855 nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed

1913 nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed

1856− stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es

1914+ stacks <- forM nodesInvolvedInCycle $ \(Some es) -> whoCreatedEventSubscribed es

1857 let cycleInfo = ":\n" <> drawForest (listsToForest stacks)

1915 let cycleInfo = ":\n" <> drawForest (listsToForest stacks)

1858#else

1916#else

1859 let cycleInfo = ""

1917 let cycleInfo = ""

@@ -1869,7 +1927,7 @@ mergeSubscriber m getKey = Subscriber

1869 }

1927 }

1870

1928

1871--TODO: Be able to run as much of this as possible promptly

1929--TODO: Be able to run as much of this as possible promptly

1872−updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k s -> MergeUpdateFunc k x p s -> p -> SomeMergeUpdate x

1930+updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x

1873updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)

1931updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)

1874 where updateMe = do

1932 where updateMe = do

1875 oldParents <- liftIO $ readIORef $ _merge_parentsRef m

1933 oldParents <- liftIO $ readIORef $ _merge_parentsRef m

@@ -1877,9 +1935,10 @@ updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m)

1877 liftIO $ writeIORef (_merge_parentsRef m) $! newParents

1935 liftIO $ writeIORef (_merge_parentsRef m) $! newParents

1878 return subscriptionsToKill

1936 return subscriptionsToKill

1879

1937

1880−{-# INLINE mergeCheap' #-}

1938+{-# INLINE mergeGCheap' #-}

1939+mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)

1881−mergeCheap' :: forall k x p s. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k (Event x)) => MergeInitFunc k x s -> MergeUpdateFunc k x p s -> MergeDestroyFunc k s -> Dynamic x p -> Event x (DMap k Identity)

1940+ => MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> DynamicS x p -> Event x (DMap k v)

1882−mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do

1941+mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do

1883 initialParents <- readBehaviorUntracked $ dynamicCurrent d

1942 initialParents <- readBehaviorUntracked $ dynamicCurrent d

1884 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"

1943 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"

1885 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"

1944 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"

@@ -1927,11 +1986,11 @@ mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do

1927 , occ

1986 , occ

1928 )

1987 )

1929

1988

1930−mergeInt :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)

1989+mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)

1931mergeInt = cacheEvent . mergeIntCheap

1990mergeInt = cacheEvent . mergeIntCheap

1932

1991

1933{-# INLINABLE mergeIntCheap #-}

1992{-# INLINABLE mergeIntCheap #-}

1934−mergeIntCheap :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)

1993+mergeIntCheap :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)

1935mergeIntCheap d = Event $ \sub -> do

1994mergeIntCheap d = Event $ \sub -> do

1936 initialParents <- readBehaviorUntracked $ dynamicCurrent d

1995 initialParents <- readBehaviorUntracked $ dynamicCurrent d

1937 accum <- liftIO $ FastMutableIntMap.newEmpty

1996 accum <- liftIO $ FastMutableIntMap.newEmpty

@@ -2028,14 +2087,16 @@ mergeIntCheap d = Event $ \sub -> do

2028 )

2087 )

2029

2088

2030newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }

2089newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }

2090+newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) }

2031

2091

2032−fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k

2092+fanG :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k v) -> EventSelectorG x k v

2033−fan e =

2093+fanG e = unsafePerformIO $ do

2094+ ref <- newIORef Nothing

2034 let f = Fan

2095 let f = Fan

2035 { fanParent = e

2096 { fanParent = e

2036− , fanSubscribed = unsafeNewIORef e Nothing

2097+ , fanSubscribed = ref

2037 }

2098 }

2038− in EventSelector $ \k -> eventFan k f

2099+ pure $ EventSelectorG $ \k -> eventFan k f

2039

2100

2040runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()

2101runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()

2041runHoldInits holdInitRef dynInitRef mergeInitRef = do

2102runHoldInits holdInitRef dynInitRef mergeInitRef = do

@@ -2089,18 +2150,18 @@ clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeI

2089-- | Run an event action outside of a frame

2150-- | Run an event action outside of a frame

2090runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex

2151runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex

2091runFrame a = SpiderHost $ do

2152runFrame a = SpiderHost $ do

2092− let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)

2153+ let env = _spiderTimeline_eventEnv $ unSTE (spiderTimeline :: SpiderTimelineEnv x)

2093 let go = do

2154 let go = do

2094 result <- a

2155 result <- a

2095 runHoldInits (eventEnvHoldInits env) (eventEnvDynInits env) (eventEnvMergeInits env) -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events

2156 runHoldInits (eventEnvHoldInits env) (eventEnvDynInits env) (eventEnvMergeInits env) -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events

2096 return result

2157 return result

2097 result <- runEventM go

2158 result <- runEventM go

2098 toClear <- readIORef $ eventEnvClears env

2159 toClear <- readIORef $ eventEnvClears env

2099− forM_ toClear $ \(Some.This (Clear ref)) -> {-# SCC "clear" #-} writeIORef ref Nothing

2160+ forM_ toClear $ \(Some (Clear ref)) -> {-# SCC "clear" #-} writeIORef ref Nothing

2100 toClearInt <- readIORef $ eventEnvIntClears env

2161 toClearInt <- readIORef $ eventEnvIntClears env

2101− forM_ toClearInt $ \(Some.This (IntClear ref)) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty

2162+ forM_ toClearInt $ \(Some (IntClear ref)) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty

2102 toClearRoot <- readIORef $ eventEnvRootClears env

2163 toClearRoot <- readIORef $ eventEnvRootClears env

2103− forM_ toClearRoot $ \(Some.This (RootClear ref)) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty

2164+ forM_ toClearRoot $ \(Some (RootClear ref)) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty

2104 toAssign <- readIORef $ eventEnvAssignments env

2165 toAssign <- readIORef $ eventEnvAssignments env

2105 toReconnectRef <- newIORef []

2166 toReconnectRef <- newIORef []

2106 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env

2167 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env

@@ -2147,7 +2208,7 @@ runFrame a = SpiderHost $ do

2147 myHeight <- readIORef $ switchSubscribedHeight subscribed

2208 myHeight <- readIORef $ switchSubscribedHeight subscribed

2148 when (parentHeight /= myHeight) $ do

2209 when (parentHeight /= myHeight) $ do

2149 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight

2210 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight

2150− WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight

2211+ WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight

2151 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

2212 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

2152 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do

2213 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do

2153 unsubscribe subscription

2214 unsubscribe subscription

@@ -2188,7 +2249,7 @@ invalidateCoincidenceHeight subscribed = do

2188 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed

2249 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed

2189 when (oldHeight /= invalidHeight) $ do

2250 when (oldHeight /= invalidHeight) $ do

2190 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight

2251 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight

2191− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

2252+ WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

2192

2253

2193updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()

2254updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()

2194updateSwitchHeight new subscribed = do

2255updateSwitchHeight new subscribed = do

@@ -2196,7 +2257,7 @@ updateSwitchHeight new subscribed = do

2196 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion

2257 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion

2197 when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion

2258 when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion

2198 writeIORef (switchSubscribedHeight subscribed) $! new

2259 writeIORef (switchSubscribedHeight subscribed) $! new

2199− WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new

2260+ WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new

2200

2261

2201recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()

2262recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()

2202recalculateCoincidenceHeight subscribed = do

2263recalculateCoincidenceHeight subscribed = do

@@ -2205,7 +2266,7 @@ recalculateCoincidenceHeight subscribed = do

2205 height <- calculateCoincidenceHeight subscribed

2266 height <- calculateCoincidenceHeight subscribed

2206 when (height /= invalidHeight) $ do

2267 when (height /= invalidHeight) $ do

2207 writeIORef (coincidenceSubscribedHeight subscribed) $! height

2268 writeIORef (coincidenceSubscribedHeight subscribed) $! height

2208− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height

2269+ WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height

2209

2270

2210calculateSwitchHeight :: SwitchSubscribed x a -> IO Height

2271calculateSwitchHeight :: SwitchSubscribed x a -> IO Height

2211calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)

2272calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)

@@ -2300,7 +2361,7 @@ instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x))

2300 fail _ = error "Dynamic does not support 'fail'"

2361 fail _ = error "Dynamic does not support 'fail'"

2301

2362

2302{-# INLINABLE newJoinDyn #-}

2363{-# INLINABLE newJoinDyn #-}

2303−newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)

2364+newJoinDyn :: HasSpiderTimeline x => DynamicS x (Identity (DynamicS x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)

2304newJoinDyn d =

2365newJoinDyn d =

2305 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)

2366 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)

2306 eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d

2367 eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d

@@ -2450,7 +2511,7 @@ unsafeNewSpiderTimelineEnv = do

2450#ifdef DEBUG

2511#ifdef DEBUG

2451 depthRef <- newIORef 0

2512 depthRef <- newIORef 0

2452#endif

2513#endif

2453− return $ SpiderTimelineEnv

2514+ return $ STE $ SpiderTimelineEnv

2454 { _spiderTimeline_lock = lock

2515 { _spiderTimeline_lock = lock

2455 , _spiderTimeline_eventEnv = env

2516 , _spiderTimeline_eventEnv = env

2456#ifdef DEBUG

2517#ifdef DEBUG

@@ -2460,19 +2521,19 @@ unsafeNewSpiderTimelineEnv = do

2460

2521

2461-- | Create a new SpiderTimelineEnv

2522-- | Create a new SpiderTimelineEnv

2462newSpiderTimeline :: IO (Some SpiderTimelineEnv)

2523newSpiderTimeline :: IO (Some SpiderTimelineEnv)

2463−newSpiderTimeline = withSpiderTimeline (pure . Some.This)

2524+newSpiderTimeline = withSpiderTimeline (pure . Some)

2464

2525

2465−data LocalSpiderTimeline x s

2526+data LocalSpiderTimeline (x :: Type) s

2466

2527

2467instance Reifies s (SpiderTimelineEnv x) =>

2528instance Reifies s (SpiderTimelineEnv x) =>

2468 HasSpiderTimeline (LocalSpiderTimeline x s) where

2529 HasSpiderTimeline (LocalSpiderTimeline x s) where

2469− spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s)

2530+ spiderTimeline = localSpiderTimeline Proxy $ reflect (Proxy :: Proxy s)

2470

2531

2471localSpiderTimeline

2532localSpiderTimeline

2472− :: Proxy s

2533+ :: proxy s

2473 -> SpiderTimelineEnv x

2534 -> SpiderTimelineEnv x

2474 -> SpiderTimelineEnv (LocalSpiderTimeline x s)

2535 -> SpiderTimelineEnv (LocalSpiderTimeline x s)

2475−localSpiderTimeline _ = unsafeCoerce

2536+localSpiderTimeline _ = coerce

2476

2537

2477-- | Pass a new timeline to the given function.

2538-- | Pass a new timeline to the given function.

2478withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r

2539withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r

@@ -2480,18 +2541,18 @@ withSpiderTimeline k = do

2480 env <- unsafeNewSpiderTimelineEnv

2541 env <- unsafeNewSpiderTimelineEnv

2481 reify env $ \s -> k $ localSpiderTimeline s env

2542 reify env $ \s -> k $ localSpiderTimeline s env

2482

2543

2483−newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2544+newtype SpiderPullM (x :: Type) a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2484

2545

2485type ComputeM = EventM

2546type ComputeM = EventM

2486

2547

2487−newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2548+newtype SpiderPushM (x :: Type) a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2488

2549

2489instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2550instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2490 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}

2551 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}

2491 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }

2552 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }

2492 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }

2553 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }

2493− newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad)

2554+ newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: DynamicS x (Identity a) } -- deriving (Functor, Applicative, Monad)

2494− newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }

2555+ newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: DynamicS x p }

2495 type PullM (SpiderTimeline x) = SpiderPullM x

2556 type PullM (SpiderTimeline x) = SpiderPullM x

2496 type PushM (SpiderTimeline x) = SpiderPushM x

2557 type PushM (SpiderTimeline x) = SpiderPushM x

2497 {-# INLINABLE never #-}

2558 {-# INLINABLE never #-}

@@ -2504,10 +2565,15 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2504 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent

2565 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent

2505 {-# INLINABLE pull #-}

2566 {-# INLINABLE pull #-}

2506 pull = SpiderBehavior . pull . coerce

2567 pull = SpiderBehavior . pull . coerce

2507− {-# INLINABLE merge #-}

2568+ {-# INLINABLE fanG #-}

2508− merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x))

2509− {-# INLINABLE fan #-}

2510− fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))

2569+ fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))

2570+ {-# INLINABLE mergeG #-}

2571+ mergeG

2572+ :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k

2573+ => (forall a. q a -> R.Event (SpiderTimeline x) (v a))

2574+ -> DMap k q

2575+ -> R.Event (SpiderTimeline x) (DMap k v)

2576+ mergeG nt = SpiderEvent . mergeG (unSpiderEvent #. nt) . dynamicConst

2511 {-# INLINABLE switch #-}

2577 {-# INLINABLE switch #-}

2512 switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior

2578 switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior

2513 {-# INLINABLE coincidence #-}

2579 {-# INLINABLE coincidence #-}

@@ -2515,15 +2581,15 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2515 {-# INLINABLE current #-}

2581 {-# INLINABLE current #-}

2516 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic

2582 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic

2517 {-# INLINABLE updated #-}

2583 {-# INLINABLE updated #-}

2518− updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic

2584+ updated = SpiderEvent #. dynamicUpdated .# fmap coerce . unSpiderDynamic

2519 {-# INLINABLE unsafeBuildDynamic #-}

2585 {-# INLINABLE unsafeBuildDynamic #-}

2520 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'

2586 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'

2521 {-# INLINABLE unsafeBuildIncremental #-}

2587 {-# INLINABLE unsafeBuildIncremental #-}

2522 unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv

2588 unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv

2523− {-# INLINABLE mergeIncremental #-}

2589+ {-# INLINABLE mergeIncrementalG #-}

2524− mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental

2590+ mergeIncrementalG nt = SpiderEvent #. mergeG (coerce #. nt) .# unSpiderIncremental

2525− {-# INLINABLE mergeIncrementalWithMove #-}

2591+ {-# INLINABLE mergeIncrementalWithMoveG #-}

2526− mergeIncrementalWithMove = SpiderEvent . mergeWithMove . (unsafeCoerce :: Dynamic x (PatchDMapWithMove k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMapWithMove k (Event x))) . unSpiderIncremental

2592+ mergeIncrementalWithMoveG nt = SpiderEvent #. mergeWithMove (coerce #. nt) .# unSpiderIncremental

2527 {-# INLINABLE currentIncremental #-}

2593 {-# INLINABLE currentIncremental #-}

2528 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental

2594 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental

2529 {-# INLINABLE updatedIncremental #-}

2595 {-# INLINABLE updatedIncremental #-}

@@ -2534,9 +2600,10 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2534 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'

2600 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'

2535 eventCoercion Coercion = Coercion

2601 eventCoercion Coercion = Coercion

2536 behaviorCoercion Coercion = Coercion

2602 behaviorCoercion Coercion = Coercion

2537− dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance

2603+ dynamicCoercion Coercion = Coercion

2604+ incrementalCoercion Coercion Coercion = Coercion

2538 {-# INLINABLE mergeIntIncremental #-}

2605 {-# INLINABLE mergeIntIncremental #-}

2539− mergeIntIncremental = SpiderEvent . mergeInt . (unsafeCoerce :: Dynamic x (PatchIntMap (R.Event (SpiderTimeline x) a)) -> Dynamic x (PatchIntMap (Event x a))) . unSpiderIncremental

2606+ mergeIntIncremental = SpiderEvent . mergeInt . coerce

2540 {-# INLINABLE fanInt #-}

2607 {-# INLINABLE fanInt #-}

2541 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))

2608 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))

2542

2609

@@ -2561,7 +2628,7 @@ instance MonadAtomicRef (EventM x) where

2561 atomicModifyRef r f = liftIO $ atomicModifyRef r f

2628 atomicModifyRef r f = liftIO $ atomicModifyRef r f

2562

2629

2563-- | The monad for actions that manipulate a Spider timeline identified by @x@

2630-- | The monad for actions that manipulate a Spider timeline identified by @x@

2564−newtype SpiderHost x a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

2631+newtype SpiderHost (x :: Type) a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

2565

2632

2566instance Monad (SpiderHost x) where

2633instance Monad (SpiderHost x) where

2567 {-# INLINABLE (>>=) #-}

2634 {-# INLINABLE (>>=) #-}

@@ -2583,7 +2650,7 @@ runSpiderHost (SpiderHost a) = a

2583runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a

2650runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a

2584runSpiderHostForTimeline (SpiderHost a) _ = a

2651runSpiderHostForTimeline (SpiderHost a) _ = a

2585

2652

2586−newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }

2653+newtype SpiderHostFrame (x :: Type) a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }

2587 deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

2654 deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

2588

2655

2589instance Monad (SpiderHostFrame x) where

2656instance Monad (SpiderHostFrame x) where

@@ -2639,3 +2706,11 @@ instance MonadAtomicRef (SpiderHostFrame x) where

2639instance PrimMonad (SpiderHostFrame x) where

2706instance PrimMonad (SpiderHostFrame x) where

2640 type PrimState (SpiderHostFrame x) = PrimState IO

2707 type PrimState (SpiderHostFrame x) = PrimState IO

2641 primitive = SpiderHostFrame . EventM . primitive

2708 primitive = SpiderHostFrame . EventM . primitive

2709+

2710+instance NotReady (SpiderTimeline x) (SpiderHost x) where

2711+ notReadyUntil _ = return ()

2712+ notReady = return ()

2713+

2714+instance HasSpiderTimeline x => NotReady (SpiderTimeline x) (PerformEventT (SpiderTimeline x) (SpiderHost x)) where

2715+ notReadyUntil _ = return ()

2716+ notReady = return ()

src/Reflex/TriggerEvent/Class.hs−1

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

2-- new 'Event's that can be triggered from 'IO'.

3{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FunctionalDependencies #-}

5−{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE UndecidableInstances #-}

5{-# LANGUAGE UndecidableInstances #-}

7module Reflex.TriggerEvent.Class

6module Reflex.TriggerEvent.Class

8 ( TriggerEvent (..)

7 ( TriggerEvent (..)

src/Reflex/Workflow.hs+1−1

@@ -34,7 +34,7 @@ workflow w0 = do

34 rec eResult <- networkHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult

35 return $ fmap fst eResult

37−-- | Similar to 'workflow', but outputs an 'Event' that fires whenever the current 'Workflow' is replaced by the next 'Workflow'.

37+-- | Similar to 'workflow', but outputs an 'Event' that fires at post-build time and whenever the current 'Workflow' is replaced by the next 'Workflow'.

38workflowView :: forall t m a. (Reflex t, NotReady t m, Adjustable t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a)

39workflowView w0 = do

40 rec eResult <- networkView . fmap unWorkflow =<< holdDyn w0 eReplace

test/EventWriterT.hs+6−4

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

@@ -13,6 +14,10 @@ import Data.Functor.Misc

13import qualified Data.Map as M

14import qualified Data.Map as M

14import Data.These

15import Data.These

17+#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))

18+import Data.These.Lens

19+#endif

20+

16import Reflex

21import Reflex

17import Reflex.EventWriter.Base

22import Reflex.EventWriter.Base

18import Test.Run

23import Test.Run

@@ -48,16 +53,13 @@ unwrapApp x appIn = do

48 return e

53 return e

50testOrdering :: (Reflex t, Monad m) => Event t () -> EventWriterT t [Int] m ()

55testOrdering :: (Reflex t, Monad m) => Event t () -> EventWriterT t [Int] m ()

51−testOrdering pulse = do

52− forM_ [10,9..1] $ \i -> tellEvent ([i] <$ pulse)

56+testOrdering pulse = forM_ [10,9..1] $ \i -> tellEvent ([i] <$ pulse)

53− return ()

55testSimultaneous :: (Reflex t, Adjustable t m, MonadHold t m) => Event t (These () ()) -> EventWriterT t [Int] m ()

58testSimultaneous :: (Reflex t, Adjustable t m, MonadHold t m) => Event t (These () ()) -> EventWriterT t [Int] m ()

56testSimultaneous pulse = do

59testSimultaneous pulse = do

57 let e0 = fmapMaybe (^? here) pulse

60 let e0 = fmapMaybe (^? here) pulse

58 e1 = fmapMaybe (^? there) pulse

61 e1 = fmapMaybe (^? there) pulse

59 forM_ [1,3..9] $ \i -> runWithReplace (tellEvent ([i] <$ e0)) $ ffor e1 $ \_ -> tellEvent ([i+1] <$ e0)

62 forM_ [1,3..9] $ \i -> runWithReplace (tellEvent ([i] <$ e0)) $ ffor e1 $ \_ -> tellEvent ([i+1] <$ e0)

60− return ()

62-- | Test that a widget telling and event which fires at the same time it has been replaced

64-- | Test that a widget telling and event which fires at the same time it has been replaced

63-- doesn't count along with the new widget.

65-- doesn't count along with the new widget.

test/GC.hs+4−3

@@ -27,6 +27,7 @@ import qualified Reflex.Spider.Internal as S

28import System.Exit

29import System.Mem

30+import Data.Coerce

31main :: IO ()

32main :: IO ()

32main = do

33main = do

@@ -46,7 +47,7 @@ hostPerf ref = S.runSpiderHost $ do

46 eventToPerform <- Host.runHostFrame $ do

47 eventToPerform <- Host.runHostFrame $ do

47 (reqMap :: S.Event S.Global (DMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) Identity))

48 (reqMap :: S.Event S.Global (DMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) Identity))

48 <- S.SpiderHostFrame

49 <- S.SpiderHostFrame

49− $ fmap ( S.merge

50+ $ fmap ( S.mergeG coerce

50 . S.dynamicHold)

51 . S.dynamicHold)

51 $ S.hold DMap.empty

52 $ S.hold DMap.empty

52 -- Construct a new heap object for the subscriber, invalidating any weak references to the subscriber if they are not retained

53 -- Construct a new heap object for the subscriber, invalidating any weak references to the subscriber if they are not retained

@@ -55,8 +56,8 @@ hostPerf ref = S.runSpiderHost $ do

55 { S.subscriberPropagate = S.subscriberPropagate sub

56 { S.subscriberPropagate = S.subscriberPropagate sub

56 }

57 }

57 return (s, o))

58 return (s, o))

58− $ runIdentity <$> S.select

59+ $ runIdentity . runIdentity <$> S.selectG

59− (S.fan $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response)

60+ (S.fanG $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response)

60 (WrapArg Request)

61 (WrapArg Request)

61 return $ alignWith (mergeThese (<>))

62 return $ alignWith (mergeThese (<>))

62 (flip S.pushCheap eadd $ \_ -> return $ Just $ DMap.singleton Request $ do

63 (flip S.pushCheap eadd $ \_ -> return $ Just $ DMap.singleton Request $ do

test/QueryT.hs+4

@@ -19,6 +19,10 @@ import Data.Map.Monoidal (MonoidalMap)

19import Data.Semigroup

20import Data.These

22+#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))

23+import Data.These.Lens

24+#endif

25+

22import Reflex

26import Reflex

23import Reflex.Patch.MapWithMove

27import Reflex.Patch.MapWithMove

24import Test.Run

28import Test.Run

test/Reflex/Bench/Focused.hs+12

@@ -130,6 +130,16 @@ mapDynChain = iterM (return . fmap (+1))

130joinDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

131joinDynChain = iterM (\d -> return $ join $ fmap (const d) d)

132

133+holdDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

134+holdDynChain = iterM (\d -> sample (current d) >>= flip holdDyn (updated d))

135+

136+buildDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

137+buildDynChain = iterM (\d -> do

138+ let b = fmap (+1) (current d)

139+ e = fmap (*2) (updated d)

140+ buildDynamic (sample b) e)

141+

142+

133combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

143combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

134combineDynChain = iterM (\d -> return $ zipDynWith (+) d d)

144combineDynChain = iterM (\d -> return $ zipDynWith (+) d d)

135

145

@@ -308,6 +318,8 @@ dynamics :: Word -> [(String, TestCase)]

308dynamics n =

318dynamics n =

309 [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d

319 [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d

310 , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d

320 , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d

321+ , testE "holdDynChain" $ fmap updated $ holdDynChain n =<< d

322+ , testE "buildDynChain" $ fmap updated $ buildDynChain n =<< d

311 , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d

323 , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d

312 , testE "dense mergeTree" $ fmap (updated . mergeTreeDyn 8) dense

324 , testE "dense mergeTree" $ fmap (updated . mergeTreeDyn 8) dense

313 , testE "sparse mergeTree" $ fmap (updated . mergeTreeDyn 8) sparse

325 , testE "sparse mergeTree" $ fmap (updated . mergeTreeDyn 8) sparse

test/Reflex/Test/CrossImpl.hs+5

@@ -218,6 +218,11 @@ testCases =

218 bb <- hold b $ pushAlways (const $ hold "asdf" eo) eo

219 let b' = pull $ sample =<< sample bb

220 return (b', e)

221+ , (,) "foldDynWhileFiring" $ TestCase (Map.singleton 0 "zxc", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(_, e) -> do

222+ d <- foldDyn (:) [] $

223+ pushAlways (\a -> foldDyn (:) [a] e) e

224+ let b = current (join (fmap distributeListOverDynPure d))

225+ return (b, e)

221 , (,) "joinDyn" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

226 , (,) "joinDyn" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

222 bb <- hold "b" e

227 bb <- hold "b" e

223 bd <- hold never . fmap (const e) =<< headE e

228 bd <- hold never . fmap (const e) =<< headE e

test/RequesterT.hs+5

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE GADTs #-}

4{-# LANGUAGE GADTs #-}

@@ -15,6 +16,10 @@ import Data.Functor.Misc

15import qualified Data.Map as M

16import qualified Data.Map as M

16import Data.These

17import Data.These

19+#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))

20+import Data.These.Lens

21+#endif

22+

18import Reflex

23import Reflex

19import Reflex.Requester.Base

24import Reflex.Requester.Base

20import Reflex.Requester.Class

25import Reflex.Requester.Class

test/hlint.hs+1

@@ -22,6 +22,7 @@ main = do

22 , "--ignore=Use unless"

23 , "--ignore=Reduce duplication"

24 , "--cpp-define=USE_TEMPLATE_HASKELL"

25+ , "--ignore=Use tuple-section"

25 ]

26 ]

26 recurseInto = and <$> sequence

27 recurseInto = and <$> sequence

27 [ fileType ==? Directory

28 [ fileType ==? Directory