0559114 · reflex · git.iko.soy

git.iko.soy/reflex

on develop help sign in

Merge branch 'develop' into ts-maybet-instances

0559114Elliot Cameron7 years ago

.travis.yml+7−1

compare with develop

unifiedsplit

@@ -29,6 +29,8 @@ matrix:

29 include:

30 - compiler: ghcjs-8.4

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

32+ - compiler: ghc-8.8.1

33+ addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}}

32 - compiler: ghc-8.6.5

34 - compiler: ghc-8.6.5

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

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

34 - compiler: ghc-8.4.4

36 - compiler: ghc-8.4.4

@@ -163,9 +165,13 @@ script:

163 # Constraint set no-th

165 # Constraint set no-th

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

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

165 # Constraint set old-these

167 # Constraint set old-these

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

168+ - if $GHCJS || ! $GHCJS && [ $HCNUMVER -lt 80800 ] ; then ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='these <1' all | color_cabal_output ; fi

167 # Constraint set old-witherable

169 # Constraint set old-witherable

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

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

171+ # Constraint set debug-propagation

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

173+ # Constraint set debug-cycles

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

169

175

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

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

171# EOF

177# EOF

ChangeLog.md+49−4

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

1# Revision history for reflex

3+## 0.6.4.1

5+* Fix a bug in the Reflex Profiled transformer where

6+ `Reflex.Class.mergeIncrementalG` and

7+ `Reflex.Class.mergeIncrementalWithMoveG` implementations referenced

8+ itself instead of the inner transformed timeline, causing an

9+ infinite loop.

10+

11+## 0.6.4

12+

13+* Support GHC 8.8

14+

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

16+

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

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

19+

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

21+

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

23+ code for performance and for cyclic dependencies between events

24+

25+## 0.6.3

26+

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

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

29+

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

31+

32+* Add missing `NotReady` instances:

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

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

35+

3## 0.6.2.4

36## 0.6.2.4

5* Update to monoidal-containers 0.6

38* Update to monoidal-containers 0.6

@@ -11,7 +44,9 @@

11## 0.6.2.2

44## 0.6.2.2

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

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

47+

14* Update version bounds to fix some CI failures

48* Update version bounds to fix some CI failures

49+

15* Add travis CI configuration

50* Add travis CI configuration

17## 0.6.2.1

52## 0.6.2.1

@@ -26,32 +61,42 @@

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

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

28* Generalize merging functions:

63* Generalize merging functions:

29− `merge` to `mergeG`,

64+ `merge` to `mergeG`,

30− `mergeIncremental` to `mergeIncrementalG`,

65+ `mergeIncremental` to `mergeIncrementalG`,

31− `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`.

66+ `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`.

33* Generalize distribute function:

68* Generalize distribute function:

34 `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`,

69 `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`,

36## 0.6.2.0

71## 0.6.2.0

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

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

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

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

75+

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

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

77+

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

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

43## 0.6.1.0

80## 0.6.1.0

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

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

83+

46* Fix `QueryT` and `RequesterT` tests

84* Fix `QueryT` and `RequesterT` tests

48## 0.6.0.0 -- 2019-03-20

86## 0.6.0.0 -- 2019-03-20

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

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

89+

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

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

91+

52* Remove many deprecated functions.

92* Remove many deprecated functions.

93+

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

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

95+

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

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

97+

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

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

99+

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

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

101+

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

102* 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-ci+7

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

10 constraints: reflex -use-template-haskell

12constraint-set old-these

13+ ghc: <8.8

13 constraints: these <1

14 constraints: these <1

15constraint-set old-witherable

16constraint-set old-witherable

16 constraints: witherable <0.3.2

17 constraints: witherable <0.3.2

18+

19+constraint-set debug-propagation

20+ constraints: reflex +debug-propagation

21+

22+constraint-set debug-cycles

23+ constraints: reflex +debug-cycles

cabal.project.freeze+1

@@ -1 +1,2 @@

1constraints: any.text < 1.2.4.0

2+ , hlint < 2.2.6 || > 2.2.6

default.nixdeleted−43

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

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

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

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

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

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

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

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

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

9−, monoidal-containers, witherable, profunctors

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

11−, useTemplateHaskell ? true

12−}:

13−mkDerivation {

14− pname = "reflex";

15− version = "0.6.2.4";

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

17− libraryHaskellDepends = [

18− base bifunctors containers dependent-map dependent-sum

19− exception-transformers lens

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

21− semigroups stm syb template-haskell these transformers

22− transformers-compat prim-uniq

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

24− mtl ref-tf split transformers data-default

25− random time unbounded-delays monoidal-containers witherable

26− profunctors

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

28− ghcjs-base

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

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

31− ]) ++ (if splitThese then [

32− semialign

33− ] else []);

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

35− hlint filepath directory filemanip

36− ];

37− configureFlags =

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

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

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

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

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

43−}

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

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

1+# DO NOT HAND-EDIT THIS FILE

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

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

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

5+ private = json.private or false;

6+ }

7+))

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

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

1+{

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

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

4+ "branch": "develop",

5+ "rev": "f628398d076243a0851b27e625b37f65dff9b89b",

6+ "sha256": "0sl0hf1glgyb1vmf2mhw4r9ipmcqk1y19d3wsic7dix2jwywzrh9"

7+}

hydra.jsondeleted−29

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

1−{

2− "enabled": 1,

3− "hidden": true,

4− "description": "Jobsets",

5− "nixexprinput": "src",

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

7− "checkinterval": 300,

8− "schedulingshares": 100,

9− "enableemail": false,

10− "emailoverride": "",

11− "keepnr": 10,

12− "inputs": {

13− "src": {

14− "type": "git",

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

16− "emailresponsible": false

17− },

18− "nixpkgs": {

19− "type": "git",

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

21− "emailresponsible": false

22− },

23− "prs": {

24− "type": "githubpulls",

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

26− "emailresponsible": false

27− }

28− }

29−}

jobsets.nixdeleted−70

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

1−{ prs }:

2−

3−let

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

5− mkFetchGithub = value: {

6− inherit value;

7− type = "git";

8− emailresponsible = false;

9− };

10−in

11−with pkgs.lib;

12−let

13− defaults = jobs: {

14− inherit (jobs) description;

15− enabled = 1;

16− hidden = false;

17− keepnr = 10;

18− schedulingshares = 100;

19− checkinterval = 120;

20− enableemail = false;

21− emailoverride = "";

22− nixexprinput = "reflex";

23− nixexprpath = "release.nix";

24− inputs = jobs.inputs // {

25− nixpkgs = {

26− type = "git";

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

28− emailresponsible = false;

29− };

30− config = {

31− type = "nix";

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

33− emailresponsible = false;

34− };

35− };

36− };

37− branchJobset = branch: defaults {

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

39− inputs = {

40− reflex = {

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

42− type = "git";

43− emailresponsible = false;

44− };

45− };

46− };

47− makePr = num: info: {

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

49− value = defaults {

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

51− inputs = {

52− reflex = {

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

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

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

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

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

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

59− type = "git";

60− emailresponsible = false;

61− };

62− };

63− };

64− };

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

66− jobsetsAttrs = processedPrs //

67− genAttrs ["develop"] branchJobset;

68−in {

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

70−}

reflex-platform.nixdeleted−8

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

1−let

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

3− owner = "reflex-frp";

4− repo = "reflex-platform";

5− rev = "384cd850f3adf1d404bced2424b5f6efb0f415f2";

6− sha256 = "1ws77prqx8khmp8j6br1ij4k2v4dlgv170r9fmg0p1jivfbn8y9d";

7− };

8−in import reflex-platform-src

reflex.cabal+98−24

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

1Name: reflex

2−Version: 0.6.2.4

2+Version: 0.6.4.1

3Synopsis: Higher-order Functional Reactive Programming

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

5License: BSD3

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

9Stability: Experimental

10Category: FRP

11Build-type: Simple

12−Cabal-version: >=1.9.2

12+Cabal-version: 1.22

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

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

15extra-source-files:

@@ -18,7 +18,7 @@ extra-source-files:

18 ChangeLog.md

20tested-with:

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

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

22 GHCJS ==8.4

24flag use-reflex-optimizer

@@ -41,16 +41,27 @@ flag fast-weak

41 default: False

42 manual: True

44+flag debug-propagation

45+ description: Enable debugging of spider internals

46+ default: False

47+ manual: True

48+

49+flag debug-cycles

50+ description: Enable debugging of event cycles

51+ default: False

52+ manual: True

53+

44flag split-these

54flag split-these

45 description: Use split these/semialign packages

55 description: Use split these/semialign packages

46 manual: False

56 manual: False

47 default: True

57 default: True

49library

59library

60+ default-language: Haskell2010

50 hs-source-dirs: src

61 hs-source-dirs: src

51 build-depends:

62 build-depends:

52 MemoTrie == 0.6.*,

63 MemoTrie == 0.6.*,

53− base >= 4.9 && < 4.13,

64+ base >= 4.9 && < 4.14,

54 bifunctors >= 5.2 && < 5.6,

65 bifunctors >= 5.2 && < 5.6,

55 comonad >= 5.0.4 && < 5.1,

66 comonad >= 5.0.4 && < 5.1,

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

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

@@ -58,20 +69,20 @@ library

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

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

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

70 dependent-map >= 0.3 && < 0.4,

60 exception-transformers == 0.4.*,

71 exception-transformers == 0.4.*,

61− profunctors >= 5.3 && < 5.5,

62 lens >= 4.7 && < 5,

72 lens >= 4.7 && < 5,

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

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

64 mtl >= 2.1 && < 2.3,

74 mtl >= 2.1 && < 2.3,

75+ patch >= 0.0.1 && < 0.1,

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

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

66 primitive >= 0.5 && < 0.8,

77 primitive >= 0.5 && < 0.8,

67− profunctors,

78+ profunctors >= 5.3 && < 5.6,

68 random == 1.1.*,

79 random == 1.1.*,

69 ref-tf == 0.4.*,

80 ref-tf == 0.4.*,

70 reflection == 2.1.*,

81 reflection == 2.1.*,

71 semigroupoids >= 4.0 && < 6,

82 semigroupoids >= 4.0 && < 6,

72 stm >= 2.4 && < 2.6,

83 stm >= 2.4 && < 2.6,

73 syb >= 0.5 && < 0.8,

84 syb >= 0.5 && < 0.8,

74− time >= 1.4 && < 1.9,

85+ time >= 1.4 && < 1.10,

75 transformers >= 0.5.6.0 && < 0.6,

86 transformers >= 0.5.6.0 && < 0.6,

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

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

77 witherable >= 0.3 && < 0.3.2

88 witherable >= 0.3 && < 0.3.2

@@ -89,7 +100,6 @@ library

89 Data.AppendMap,

100 Data.AppendMap,

90 Data.FastMutableIntMap,

101 Data.FastMutableIntMap,

91 Data.FastWeakBag,

102 Data.FastWeakBag,

92− Data.Functor.Misc,

93 Data.Map.Misc,

103 Data.Map.Misc,

94 Data.WeakBag,

104 Data.WeakBag,

95 Reflex,

105 Reflex,

@@ -111,13 +121,6 @@ library

111 Reflex.Host.Class,

121 Reflex.Host.Class,

112 Reflex.Network,

122 Reflex.Network,

113 Reflex.NotReady.Class,

123 Reflex.NotReady.Class,

114− Reflex.Patch,

115− Reflex.Patch.Class,

116− Reflex.Patch.DMap,

117− Reflex.Patch.DMapWithMove,

118− Reflex.Patch.IntMap,

119− Reflex.Patch.Map,

120− Reflex.Patch.MapWithMove,

121 Reflex.PerformEvent.Base,

124 Reflex.PerformEvent.Base,

122 Reflex.PerformEvent.Class,

125 Reflex.PerformEvent.Class,

123 Reflex.PostBuild.Base,

126 Reflex.PostBuild.Base,

@@ -136,6 +139,16 @@ library

136 Reflex.Widget.Basic,

139 Reflex.Widget.Basic,

137 Reflex.Workflow

140 Reflex.Workflow

138

141

142+ reexported-modules:

143+ patch:Data.Functor.Misc,

144+ patch:Data.Patch as Reflex.Patch,

145+ patch:Data.Patch.Class as Reflex.Patch.Class,

146+ patch:Data.Patch.DMap as Reflex.Patch.DMap,

147+ patch:Data.Patch.DMapWithMove as Reflex.Patch.DMapWithMove,

148+ patch:Data.Patch.IntMap as Reflex.Patch.IntMap,

149+ patch:Data.Patch.Map as Reflex.Patch.Map,

150+ patch:Data.Patch.MapWithMove as Reflex.Patch.MapWithMove

151+

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

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

140

153

141 if flag(debug-trace-events)

154 if flag(debug-trace-events)

@@ -147,13 +160,19 @@ library

147 build-depends: ghc

160 build-depends: ghc

148 exposed-modules: Reflex.Optimizer

161 exposed-modules: Reflex.Optimizer

149

162

163+ if flag(debug-propagation)

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

165+

166+ if flag(debug-cycles)

167+ cpp-options: -DDEBUG_CYCLES

168+

150 if flag(use-template-haskell)

169 if flag(use-template-haskell)

151 cpp-options: -DUSE_TEMPLATE_HASKELL

170 cpp-options: -DUSE_TEMPLATE_HASKELL

152 build-depends:

171 build-depends:

153 dependent-sum >= 0.6 && < 0.7,

172 dependent-sum >= 0.6 && < 0.7,

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

173+ haskell-src-exts >= 1.16 && < 1.23,

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

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

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

175+ template-haskell >= 2.9 && < 2.16

157 exposed-modules:

176 exposed-modules:

158 Reflex.Dynamic.TH

177 Reflex.Dynamic.TH

159 other-extensions: TemplateHaskell

178 other-extensions: TemplateHaskell

@@ -168,6 +187,7 @@ library

168 build-depends: ghcjs-base

187 build-depends: ghcjs-base

169

188

170test-suite semantics

189test-suite semantics

190+ default-language: Haskell2010

171 type: exitcode-stdio-1.0

191 type: exitcode-stdio-1.0

172 main-is: semantics.hs

192 main-is: semantics.hs

173 hs-source-dirs: test

193 hs-source-dirs: test

@@ -193,6 +213,7 @@ test-suite semantics

193 Reflex.TestPlan

213 Reflex.TestPlan

194

214

195test-suite CrossImpl

215test-suite CrossImpl

216+ default-language: Haskell2010

196 type: exitcode-stdio-1.0

217 type: exitcode-stdio-1.0

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

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

198 hs-source-dirs: test

219 hs-source-dirs: test

@@ -214,6 +235,7 @@ test-suite CrossImpl

214 Reflex.Plan.Pure

235 Reflex.Plan.Pure

215

236

216test-suite hlint

237test-suite hlint

238+ default-language: Haskell2010

217 type: exitcode-stdio-1.0

239 type: exitcode-stdio-1.0

218 main-is: hlint.hs

240 main-is: hlint.hs

219 hs-source-dirs: test

241 hs-source-dirs: test

@@ -226,6 +248,7 @@ test-suite hlint

226 buildable: False

248 buildable: False

227

249

228test-suite EventWriterT

250test-suite EventWriterT

251+ default-language: Haskell2010

229 type: exitcode-stdio-1.0

252 type: exitcode-stdio-1.0

230 main-is: EventWriterT.hs

253 main-is: EventWriterT.hs

231 hs-source-dirs: test

254 hs-source-dirs: test

@@ -245,28 +268,57 @@ test-suite EventWriterT

245 build-depends: these-lens

268 build-depends: these-lens

246

269

247 other-modules:

270 other-modules:

248− Reflex.Test

249− Reflex.TestPlan

250− Reflex.Plan.Reflex

251− Reflex.Plan.Pure

252 Test.Run

271 Test.Run

253

272

254

273

255−test-suite RequesterT

274+test-suite DebugCycles

275+ default-language: Haskell2010

256 type: exitcode-stdio-1.0

276 type: exitcode-stdio-1.0

257− main-is: RequesterT.hs

277+ main-is: DebugCycles.hs

258 hs-source-dirs: test

278 hs-source-dirs: test

279+ ghc-options: -threaded

259 build-depends: base

280 build-depends: base

260 , containers

281 , containers

261 , deepseq

282 , deepseq

262− , dependent-sum

263 , dependent-map

283 , dependent-map

284+ , dependent-sum

285+ , hspec

264 , lens

286 , lens

265 , mtl

287 , mtl

266 , these

288 , these

267 , transformers

289 , transformers

268 , reflex

290 , reflex

269 , ref-tf

291 , ref-tf

292+ , witherable

293+ , proctest

294+

295+

296+ if flag(split-these)

297+ build-depends: these-lens, semialign

298+

299+ other-modules:

300+ Test.Run

301+

302+

303+test-suite RequesterT

304+ default-language: Haskell2010

305+ type: exitcode-stdio-1.0

306+ main-is: RequesterT.hs

307+ hs-source-dirs: test

308+ build-depends: base

309+ , constraints

310+ , constraints-extras

311+ , containers

312+ , deepseq

313+ , dependent-map

314+ , dependent-sum

315+ , lens

316+ , mtl

317+ , ref-tf

318+ , reflex

319+ , text

320+ , these

321+ , transformers

270

322

271 if flag(split-these)

323 if flag(split-these)

272 build-depends: these-lens

324 build-depends: these-lens

@@ -276,7 +328,23 @@ test-suite RequesterT

276 Reflex.Plan.Pure

328 Reflex.Plan.Pure

277 Test.Run

329 Test.Run

278

330

331+test-suite Adjustable

332+ default-language: Haskell2010

333+ type: exitcode-stdio-1.0

334+ main-is: Adjustable.hs

335+ hs-source-dirs: test

336+ build-depends: base

337+ , containers

338+ , dependent-sum

339+ , reflex

340+ , ref-tf

341+ , these

342+

343+ other-modules:

344+ Test.Run

345+

279test-suite QueryT

346test-suite QueryT

347+ default-language: Haskell2010

280 type: exitcode-stdio-1.0

348 type: exitcode-stdio-1.0

281 main-is: QueryT.hs

349 main-is: QueryT.hs

282 hs-source-dirs: test

350 hs-source-dirs: test

@@ -288,6 +356,7 @@ test-suite QueryT

288 , lens

356 , lens

289 , monoidal-containers

357 , monoidal-containers

290 , mtl

358 , mtl

359+ , patch

291 , ref-tf

360 , ref-tf

292 , reflex

361 , reflex

293 , these

362 , these

@@ -303,6 +372,7 @@ test-suite QueryT

303 Reflex.Plan.Pure

372 Reflex.Plan.Pure

304

373

305test-suite GC-Semantics

374test-suite GC-Semantics

375+ default-language: Haskell2010

306 type: exitcode-stdio-1.0

376 type: exitcode-stdio-1.0

307 main-is: GC.hs

377 main-is: GC.hs

308 hs-source-dirs: test

378 hs-source-dirs: test

@@ -312,6 +382,7 @@ test-suite GC-Semantics

312 , dependent-map

382 , dependent-map

313 , deepseq

383 , deepseq

314 , mtl

384 , mtl

385+ , patch

315 , these

386 , these

316 , transformers

387 , transformers

317 , reflex

388 , reflex

@@ -327,6 +398,7 @@ test-suite GC-Semantics

327 Test.Run

398 Test.Run

328

399

329test-suite rootCleanup

400test-suite rootCleanup

401+ default-language: Haskell2010

330 type: exitcode-stdio-1.0

402 type: exitcode-stdio-1.0

331 main-is: rootCleanup.hs

403 main-is: rootCleanup.hs

332 hs-source-dirs: test

404 hs-source-dirs: test

@@ -344,6 +416,7 @@ test-suite rootCleanup

344 Test.Run

416 Test.Run

345

417

346benchmark spider-bench

418benchmark spider-bench

419+ default-language: Haskell2010

347 type: exitcode-stdio-1.0

420 type: exitcode-stdio-1.0

348 hs-source-dirs: bench test

421 hs-source-dirs: bench test

349 main-is: Main.hs

422 main-is: Main.hs

@@ -368,6 +441,7 @@ benchmark spider-bench

368 Reflex.Bench.Focused

441 Reflex.Bench.Focused

369

442

370benchmark saulzar-bench

443benchmark saulzar-bench

444+ default-language: Haskell2010

371 type: exitcode-stdio-1.0

445 type: exitcode-stdio-1.0

372 hs-source-dirs: bench test

446 hs-source-dirs: bench test

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

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

release.nix+56−7

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

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

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

2}:

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

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

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

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

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

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

9−}))

11+ compilers = [

12+ "ghc"

13+ "ghcjs"

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

15+ "ghcAndroidAarch64"

16+ "ghcAndroidAarch32"

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

18+ "ghcIosAarch64"

19+ ];

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

21+ "-dontUseTemplateHaskell"

22+ ""

23+ ];

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

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

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

27+ inherit system;

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

29+ haskellOverlays = [

30+ # Use this package's source for reflex

31+ (self: super: {

32+ _dep = super._dep // {

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

34+ "release.nix"

35+ ".git"

36+ "dist"

37+ "cabal.haskell-ci"

38+ "cabal.project"

39+ ".travis.yml"

40+ ])) ./.;

41+ };

42+ })

43+ ];

44+ };

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

46+ in variationPkgs // {

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

48+ (builtins.attrValues variationPkgs);

49+ });

50+ in compilerPkgs // {

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

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

53+ });

54+

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

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

57+

58+in perPlatform // { inherit metaCache; }

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

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

37#if MIN_VERSION_base(4,10,0)

38 liftA2 = liftM2

39 {-# INLINE liftA2 #-}

40−#endif

40+#endif

41 (*>) = (>>)

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

src/Data/AppendMap.hs+2−2

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

20 , module Data.Map.Monoidal

21 ) where

23−import Prelude hiding (map, null)

23+import Prelude hiding (null)

25import Data.Coerce

26import Data.Default

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

71 then Nothing

72 else Just bs

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

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

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

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

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

src/Data/FastMutableIntMap.hs+7−3

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

21 , patchIntMapNewElements

22 , patchIntMapNewElementsMap

23 , getDeletions

24+ , toList

24 ) where

25 ) where

26--TODO: Pure JS version

27--TODO: Pure JS version

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

34import Data.IntMap.Strict (IntMap)

35import Data.IntMap.Strict (IntMap)

35import qualified Data.IntMap.Strict as IntMap

36import qualified Data.IntMap.Strict as IntMap

36import Data.IORef

37import Data.IORef

37−import Reflex.Patch.Class

38+import Data.Patch.Class

38−import Reflex.Patch.IntMap

39+import Data.Patch.IntMap

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

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

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

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

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

84 writeIORef r IntMap.empty

85 writeIORef r IntMap.empty

85 return result

86 return result

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

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

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

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

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

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

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

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

91 v <- readIORef r

92 v <- readIORef r

92 writeIORef r $! applyAlways p v

93 writeIORef r $! applyAlways p v

93 return $ IntMap.intersection v m

94 return $ IntMap.intersection v m

95+

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

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

src/Data/FastWeakBag.hs+9−4

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

18 , isEmpty

19 , insert

20 , traverse

21+ , traverse_

21 , remove

22 , remove

22 -- * Internal functions

23 -- * Internal functions

23 -- These will not always be available.

24 -- These will not always be available.

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

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

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

117#endif

118#endif

118

119

119−{-# INLINE traverse #-}

120+{-# INLINE traverse_ #-}

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

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

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

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

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

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

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

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

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

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

125#ifdef GHCJS_FAST_WEAK

126#ifdef GHCJS_FAST_WEAK

126−traverse wb f = do

127+traverse_ wb f = do

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

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

128 val <- liftIO $ js_getTicketValue cursor

129 val <- liftIO $ js_getTicketValue cursor

129 f $ unsafeFromRawJSVal val

130 f $ unsafeFromRawJSVal val

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

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

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

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

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

136#else

137#else

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

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

138 cs <- liftIO $ readIORef children

139 cs <- liftIO $ readIORef children

139 forM_ cs $ \c -> do

140 forM_ cs $ \c -> do

140 ma <- liftIO $ deRefWeak c

141 ma <- liftIO $ deRefWeak c

141 mapM_ f ma

142 mapM_ f ma

142#endif

143#endif

143

144

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

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

147+traverse = traverse_

148+

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

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

145-- on the same 'FastWeakBagTicket'.

150-- on the same 'FastWeakBagTicket'.

146{-# INLINE remove #-}

151{-# INLINE remove #-}

src/Data/Functor/Misc.hsdeleted−234

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

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveDataTypeable #-}

3−{-# LANGUAGE DeriveFunctor #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE GADTs #-}

7−{-# LANGUAGE LambdaCase #-}

8−{-# LANGUAGE MultiParamTypeClasses #-}

9−{-# LANGUAGE PatternSynonyms #-}

10−{-# LANGUAGE PolyKinds #-}

11−{-# LANGUAGE RankNTypes #-}

12−{-# LANGUAGE ScopedTypeVariables #-}

13−{-# LANGUAGE StandaloneDeriving #-}

14−#ifdef USE_REFLEX_OPTIMIZER

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

16−#endif

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

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

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

20−module Data.Functor.Misc

21− ( -- * Const2

22− Const2 (..)

23− , unConst2

24− , dmapToMap

25− , dmapToIntMap

26− , dmapToMapWith

27− , mapToDMap

28− , weakenDMapWith

29− -- * WrapArg

30− , WrapArg (..)

31− -- * Convenience functions for DMap

32− , mapWithFunctorToDMap

33− , intMapWithFunctorToDMap

34− , mapKeyValuePairsMonotonic

35− , combineDMapsWithKey

36− , EitherTag (..)

37− , dmapToThese

38− , eitherToDSum

39− , dsumToEither

40− , ComposeMaybe (..)

41− ) where

42−

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

44−import Control.Monad.Identity

45−import Data.Dependent.Map (DMap)

46−import qualified Data.Dependent.Map as DMap

47−import Data.Dependent.Sum

48−import Data.GADT.Compare

49−import Data.GADT.Show

50−import Data.IntMap (IntMap)

51−import qualified Data.IntMap as IntMap

52−import Data.Map (Map)

53−import qualified Data.Map as Map

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

55−import Data.These

56−import Data.Typeable hiding (Refl)

57−

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

59−-- Const2

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

61−

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

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

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

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

66− deriving (Typeable)

67−

68−-- | Extract the value from a Const2

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

70−unConst2 (Const2 k) = k

71−

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

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

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

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

76−

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

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

79−

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

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

82− if a == b

83− then Just Refl

84− else Nothing

85−

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

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

88− LT -> GLT

89− EQ -> GEQ

90− GT -> GGT

91−

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

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

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

95−

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

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

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

99−

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

101−-- the wrapping 'Functor'

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

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

104−

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

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

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

108−

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

110−-- to a 'DMap'

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

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

113−

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

115−-- functor, to a 'DMap'

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

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

118−

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

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

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

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

123−

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

125−-- WrapArg

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

127−

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

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

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

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

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

133−

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

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

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

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

138−

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

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

141−

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

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

144− GLT -> GLT

145− GEQ -> GEQ

146− GGT -> GGT

147−

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

149−-- Convenience functions for DMap

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

151−

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

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

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

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

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

157−

158−{-# INLINE combineDMapsWithKey #-}

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

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

161−combineDMapsWithKey :: forall f g h i.

162− GCompare f

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

164− -> DMap f g

165− -> DMap f h

166− -> DMap f i

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

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

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

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

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

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

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

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

175−

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

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

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

179− (Nothing, Nothing) -> Nothing

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

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

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

183−

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

185−data EitherTag l r a where

186− LeftTag :: EitherTag l r l

187− RightTag :: EitherTag l r r

188− deriving (Typeable)

189−

190−deriving instance Show (EitherTag l r a)

191−deriving instance Eq (EitherTag l r a)

192−deriving instance Ord (EitherTag l r a)

193−

194−instance GEq (EitherTag l r) where

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

196− (LeftTag, LeftTag) -> Just Refl

197− (RightTag, RightTag) -> Just Refl

198− _ -> Nothing

199−

200−instance GCompare (EitherTag l r) where

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

202− (LeftTag, LeftTag) -> GEQ

203− (LeftTag, RightTag) -> GLT

204− (RightTag, LeftTag) -> GGT

205− (RightTag, RightTag) -> GEQ

206−

207−instance GShow (EitherTag l r) where

208− gshowsPrec _ a = case a of

209− LeftTag -> showString "LeftTag"

210− RightTag -> showString "RightTag"

211−

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

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

214−eitherToDSum = \case

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

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

217−

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

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

220−dsumToEither = \case

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

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

223−

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

225−-- ComposeMaybe

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

227−

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

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

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

231−newtype ComposeMaybe f a =

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

233−

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

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

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

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

45--

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

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

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

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

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

src/Data/WeakBag.hs+8−3

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

15 , singleton

16 , insert

17 , traverse

18+ , traverse_

18 , remove

19 , remove

19 -- * Internal functions

20 -- * Internal functions

20 -- These will not always be available.

21 -- These will not always be available.

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

99 ticket <- insert a bag wbRef finalizer

100 ticket <- insert a bag wbRef finalizer

100 return (bag, ticket)

101 return (bag, ticket)

101

102

102−{-# INLINE traverse #-}

103+{-# INLINE traverse_ #-}

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

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

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

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

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

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

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

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

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

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

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

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

109 cs <- liftIO $ readIORef children

110 cs <- liftIO $ readIORef children

110 forM_ cs $ \c -> do

111 forM_ cs $ \c -> do

111 ma <- liftIO $ deRefWeak c

112 ma <- liftIO $ deRefWeak c

112 mapM_ f ma

113 mapM_ f ma

113

114

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

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

117+traverse = traverse_

118+

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

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

115-- on the same 'WeakBagTicket'.

120-- on the same 'WeakBagTicket'.

116{-# INLINE remove #-}

121{-# INLINE remove #-}

src/Reflex/Adjustable/Class.hs+1−1

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

39import Data.Map (Map)

41import Reflex.Class

42−import Reflex.Patch.DMapWithMove

42+import Data.Patch.DMapWithMove

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

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

src/Reflex/Class.hs+10−6

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

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

30-- signals.

31module Reflex.Class

32− ( module Reflex.Patch

32+ ( module Data.Patch

33 -- * Primitives

34 , Reflex (..)

35 , mergeInt

@@ -200,7 +200,7 @@ import Data.Dependent.Map (DMap, DSum (..))

200import qualified Data.Dependent.Map as DMap

201import Data.Functor.Compose

202import Data.Functor.Product

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

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

204import Data.FastMutableIntMap (PatchIntMap)

205import Data.Foldable

206import Data.Functor.Bind

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

210import qualified Data.IntMap.Strict as IntMap

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

212import Data.Map (Map)

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

213+import Data.Semigroup (Semigroup (..))

214import Data.Some (Some(Some))

215import Data.String

216import Data.These

217import Data.Type.Coercion

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

218import Data.Witherable (Filterable(..))

219import Data.Witherable (Filterable(..))

219import qualified Data.Witherable as W

220import qualified Data.Witherable as W

220import Reflex.FunctorMaybe (FunctorMaybe)

221import Reflex.FunctorMaybe (FunctorMaybe)

221import qualified Reflex.FunctorMaybe

222import qualified Reflex.FunctorMaybe

222−import Reflex.Patch

223+import Data.Patch

223−import qualified Reflex.Patch.MapWithMove as PatchMapWithMove

224+import qualified Data.Patch.MapWithMove as PatchMapWithMove

224

225

225import Debug.Trace (trace)

226import Debug.Trace (trace)

226

227

@@ -286,7 +287,8 @@ class ( MonadHold t (PushM t)

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

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

287 -- 'Event' occurs

288 -- 'Event' occurs

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

664 return = constant

666 return = constant

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

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

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

669+#endif

666

670

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

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

668 mempty = constant mempty

672 mempty = constant mempty

src/Reflex/Collection.hs+1−1

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

130 Nothing -> Just Nothing

131

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

133− Just _ -> Nothing

133+ Just _ -> Nothing

134 listHoldWithKey

135 initialVals

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

src/Reflex/Dynamic.hs+2−1

@@ -87,11 +87,12 @@ import Data.Align

87import Data.Dependent.Map (DMap)

88import qualified Data.Dependent.Map as DMap

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

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

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

91import Data.Map (Map)

92import Data.Maybe

93import Data.Monoid ((<>))

94import Data.These

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

96import Debug.Trace

97import Debug.Trace

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

@@ -44,7 +44,7 @@ import Reflex.Class

44import Reflex.DynamicWriter.Class

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

46import Reflex.Host.Class

47−import qualified Reflex.Patch.MapWithMove as MapWithMove

47+import qualified Data.Patch.MapWithMove as MapWithMove

48import Reflex.PerformEvent.Class

49import Reflex.PostBuild.Class

50import Reflex.Query.Class

src/Reflex/DynamicWriter/Class.hs−1

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

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

28 tellDyn = lift . tellDyn

29−

src/Reflex/Network.hs+1−1

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

20import Reflex.PostBuild.Class

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

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

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

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

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

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

src/Reflex/Patch.hsdeleted−46

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

1−{-# LANGUAGE TypeFamilies #-}

2−-- |

3−-- Module:

4−-- Reflex.Patch

5−-- Description:

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

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

8−module Reflex.Patch

9− ( module Reflex.Patch

10− , module X

11− ) where

12−

13−import Reflex.Patch.Class as X

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

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

16− patchDMapWithMoveToPatchMapWithMoveWith,

17− traversePatchDMapWithMoveWithKey, unPatchDMapWithMove,

18− unsafePatchDMapWithMove, weakenPatchDMapWithMoveWith)

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

20−import Reflex.Patch.Map as X

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

22− patchMapWithMoveNewElementsMap, unPatchMapWithMove,

23− unsafePatchMapWithMove)

24−import Data.Map.Monoidal (MonoidalMap)

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

26−

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

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

29− negateG :: q -> q

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

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

32−

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

34−class Semigroup q => Additive q where

35−

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

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

38−

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

40− type PatchTarget (AdditivePatch p) = p

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

42−

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

44− negateG = fmap negateG

45−

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

src/Reflex/Patch/Class.hsdeleted−34

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

1−{-# LANGUAGE TypeFamilies #-}

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

3−module Reflex.Patch.Class where

4−

5−import Control.Monad.Identity

6−import Data.Maybe

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

8−

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

10−--

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

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

13−class Patch p where

14− type PatchTarget p :: *

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

16− -- 'Nothing'.

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

18−

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

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

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

22−

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

24−instance Patch (Identity a) where

25− type PatchTarget (Identity a) = a

26− apply (Identity a) _ = Just a

27−

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

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

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

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

32−composePatchFunctions g f a =

33− let fp = f a

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

src/Reflex/Patch/DMap.hsdeleted−82

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

1−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2−{-# LANGUAGE LambdaCase #-}

3−{-# LANGUAGE PolyKinds #-}

4−{-# LANGUAGE Rank2Types #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE StandaloneDeriving #-}

7−{-# LANGUAGE TypeFamilies #-}

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

9−module Reflex.Patch.DMap where

10−

11−import Reflex.Patch.Class

12−import Reflex.Patch.IntMap

13−import Reflex.Patch.Map

14−

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

16−import qualified Data.Dependent.Map as DMap

17−import Data.Functor.Constant

18−import Data.Functor.Misc

19−import qualified Data.IntMap as IntMap

20−import qualified Data.Map as Map

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

22−import Data.Some (Some)

23−

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

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

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

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

28−

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

30−

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

32−

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

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

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

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

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

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

39− nothingToJust = \case

40− Nothing -> Just $ Constant ()

41− Just _ -> Nothing

42−

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

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

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

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

47−

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

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

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

51−traversePatchDMap f = traversePatchDMapWithKey $ const f

52−

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

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

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

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

57−

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

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

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

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

62−

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

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

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

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

67−

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

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

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

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

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

73−

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

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

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

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

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

79−

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

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

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

src/Reflex/Patch/DMapWithMove.hsdeleted−363

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

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE FlexibleInstances #-}

4−{-# LANGUAGE GADTs #-}

5−{-# LANGUAGE LambdaCase #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

7−{-# LANGUAGE PatternGuards #-}

8−{-# LANGUAGE PolyKinds #-}

9−{-# LANGUAGE Rank2Types #-}

10−{-# LANGUAGE ScopedTypeVariables #-}

11−{-# LANGUAGE TypeFamilies #-}

12−{-# LANGUAGE UndecidableInstances #-}

13−

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

15−-- move values between keys.

16−module Reflex.Patch.DMapWithMove where

17−

18−import Reflex.Patch.Class

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

20−import qualified Reflex.Patch.MapWithMove as MapWithMove

21−

22−import Data.Constraint.Extras

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

24−import qualified Data.Dependent.Map as DMap

25−import Data.Functor.Constant

26−import Data.Functor.Misc

27−import Data.Functor.Product

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

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

30−import qualified Data.Map as Map

31−import Data.Maybe

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

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

34−import Data.These

35−

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

37−-- destinations.

38−--

39−-- Invariants:

40−--

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

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

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

44−

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

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

47−data NodeInfo k v a = NodeInfo

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

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

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

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

52− }

53− deriving (Show)

54−

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

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

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

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

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

60− -- |Delete the existing key

61− From_Delete :: From k v a

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

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

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

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

66−

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

68−-- operation.

69−type To = ComposeMaybe

70−

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

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

73−validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove

74−

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

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

77−validationErrorsForPatchDMapWithMove m =

78− noSelfMoves <> movesBalanced

79− where

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

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

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

83− selfMove _ = Nothing

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

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

86− case DMap.lookup src m of

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

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

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

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

91− else Nothing

92− _ ->

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

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

95− case DMap.lookup dst m of

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

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

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

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

100− else Nothing

101−

102− _ ->

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

104− unbalancedMove _ = Nothing

105−

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

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

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

109−

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

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

112−

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

114−data Fixup k v a

115− = Fixup_Delete

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

117−

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

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

120− PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m

121− where

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

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

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

125− (Just toAfter, From_Move fromBefore)

126− | isJust $ fromBefore `geq` toAfter

127− -> [toAfter :=> Fixup_Delete]

128− | otherwise

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

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

131− ]

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

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

134− (Nothing, _) -> []

135− mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete

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

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

138− = Fixup_Update $ These x y

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

140− = Fixup_Update $ These x y

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

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

143− combineNodeInfos _ nia nib = NodeInfo

144− { _nodeInfo_from = _nodeInfo_from nia

145− , _nodeInfo_to = _nodeInfo_to nib

146− }

147− applyFixup _ ni = \case

148− Fixup_Delete -> Nothing

149− Fixup_Update u -> Just $ NodeInfo

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

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

152− }

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

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

155− getHere = \case

156− This a -> Just a

157− These a _ -> Just a

158− That _ -> Nothing

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

160− getThere = \case

161− This _ -> Nothing

162− These _ b -> Just b

163− That b -> Just b

164−

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

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

167− mempty = PatchDMapWithMove mempty

168− mappend = (<>)

169−

170−{-

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

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

173− where

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

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

176− removeRedundantDst _ a = Just a

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

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

179− From_Move fromKey -> getDstAction fromKey dstBefore

180− nonMove -> nonMove

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

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

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

184− removeRedundantSrc _ a = Just a

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

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

187− ComposeMaybe Nothing -> ComposeMaybe Nothing

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

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

190−-}

191−

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

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

194−insertDMapKey k v =

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

196−

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

198−--

199−-- @

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

201−-- @

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

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

204− Nothing -> PatchDMapWithMove $ DMap.fromList

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

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

207− ]

208− Just _ -> mempty

209−

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

211−--

212−-- @

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

214−-- bMay = DMap.lookup b dmap

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

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

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

218−-- @

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

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

221− Nothing -> PatchDMapWithMove $ DMap.fromList

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

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

224− ]

225− Just _ -> mempty

226−

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

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

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

230−

231−{-

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

233−k1 = Const2 1

234−k2 = Const2 2

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

236−p1 = moveDMapKey k1 k2

237−p2 = moveDMapKey k2 k1

238−p12 = p1 <> p2

239−p21 = p2 <> p1

240−p12Slow = p1 `mappendPatchDMapWithMoveSlow` p2

241−p21Slow = p2 `mappendPatchDMapWithMoveSlow` p1

242−

243−testPatchDMapWithMove = do

244− print p1

245− print p2

246− print $ p12 == deleteDMapKey k1

247− print $ p21 == deleteDMapKey k2

248− print $ p12Slow == deleteDMapKey k1

249− print $ p21Slow == deleteDMapKey k2

250−

251−dst (PatchDMapWithMove x _) = x

252−src (PatchDMapWithMove _ x) = x

253−-}

254−

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

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

257−unPatchDMapWithMove (PatchDMapWithMove p) = p

258−

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

260−--

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

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

263−unsafePatchDMapWithMove = PatchDMapWithMove

264−

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

266−-- otherwise @Left errors@.

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

268−patchDMapWithMove dm =

269− case validationErrorsForPatchDMapWithMove dm of

270− [] -> Right $ unsafePatchDMapWithMove dm

271− errs -> Left errs

272−

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

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

275−mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $

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

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

278− g = \case

279− From_Insert v -> From_Insert $ f v

280− From_Delete -> From_Delete

281− From_Move k -> From_Move k

282−

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

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

285−traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f

286−

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

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

289−traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p

290− where g :: forall a. k a -> From k v a -> m (From k v' a)

291− g k = \case

292− From_Insert v -> From_Insert <$> f k v

293− From_Delete -> pure From_Delete

294− From_Move fromKey -> pure $ From_Move fromKey

295−

296−-- |Map a function which transforms @'From' k v a@ into a @'From' k v' a@ over a @'NodeInfo' k v a@.

297−nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a

298−nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }

299−

300−-- |Map an effectful function which transforms @'From' k v a@ into a @f ('From' k v' a)@ over a @'NodeInfo' k v a@.

301−nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a)

302−nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni

303−

304−-- |Weaken a 'PatchDMapWithMove' to a 'PatchMapWithMove' by weakening the keys from @k a@ to @'Some' k@ and applying a given weakening function @v a -> v'@ to

305−-- values.

306−weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'

307−weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p

308− where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) v'

309− g ni = MapWithMove.NodeInfo

310− { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of

311− From_Insert v -> MapWithMove.From_Insert $ f v

312− From_Delete -> MapWithMove.From_Delete

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

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

315− }

316−

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

318−-- dependency in the typing and all points are already @a@, hence the function to map each value to @v'@ is not higher rank.

319−patchDMapWithMoveToPatchMapWithMoveWith :: forall k v v' a. (v a -> v') -> PatchDMapWithMove (Const2 k a) v -> PatchMapWithMove k v'

320−patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p

321− where g :: NodeInfo (Const2 k a) v a -> MapWithMove.NodeInfo k v'

322− g ni = MapWithMove.NodeInfo

323− { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of

324− From_Insert v -> MapWithMove.From_Insert $ f v

325− From_Delete -> MapWithMove.From_Delete

326− From_Move (Const2 k) -> MapWithMove.From_Move k

327− , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)

328− }

329−

330−-- |"Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove ('Const2' k a)@; that is, turn a non-dependently-typed patch into a dependently typed

331−-- one but which always has a constant key type represented by 'Const2'. Apply the given function to each @v@ to produce a @v' a@.

332−-- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'

333−const2PatchDMapWithMoveWith :: forall k v v' a. (v -> v' a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) v'

334−const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p

335− where g :: (k, MapWithMove.NodeInfo k v) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v')

336− g (k, ni) = Const2 k :=> NodeInfo

337− { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of

338− MapWithMove.From_Insert v -> From_Insert $ f v

339− MapWithMove.From_Delete -> From_Delete

340− MapWithMove.From_Move fromKey -> From_Move $ Const2 fromKey

341− , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni

342− }

343−

344−-- | Apply the insertions, deletions, and moves to a given 'DMap'.

345−instance GCompare k => Patch (PatchDMapWithMove k v) where

346− type PatchTarget (PatchDMapWithMove k v) = DMap k v

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

348− where insertions = DMap.mapMaybeWithKey insertFunc p

349− insertFunc :: forall a. k a -> NodeInfo k v a -> Maybe (v a)

350− insertFunc _ ni = case _nodeInfo_from ni of

351− From_Insert v -> Just v

352− From_Move k -> DMap.lookup k old

353− From_Delete -> Nothing

354− deletions = DMap.mapMaybeWithKey deleteFunc p

355− deleteFunc :: forall a. k a -> NodeInfo k v a -> Maybe (Constant () a)

356− deleteFunc _ ni = case _nodeInfo_from ni of

357− From_Delete -> Just $ Constant ()

358− _ -> Nothing

359−

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

361−getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))

362−getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p

363− where f _ v ni = Pair v $ _nodeInfo_to ni

src/Reflex/Patch/IntMap.hsdeleted−59

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

1−{-# LANGUAGE DeriveFoldable #-}

2−{-# LANGUAGE DeriveFunctor #-}

3−{-# LANGUAGE DeriveTraversable #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5−{-# LANGUAGE TypeFamilies #-}

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

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

8−module Reflex.Patch.IntMap where

9−

10−import Data.IntMap.Strict (IntMap)

11−import qualified Data.IntMap.Strict as IntMap

12−import Data.Maybe

13−import Data.Semigroup

14−import Reflex.Patch.Class

15−

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

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

18−-- and @Nothing@ means delete.

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

20−

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

22−instance Patch (PatchIntMap a) where

23− type PatchTarget (PatchIntMap a) = IntMap a

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

25− let removes = IntMap.filter isNothing p

26− adds = IntMap.mapMaybe id p

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

28−

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

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

31−-- precedence.

32−instance Semigroup (PatchIntMap v) where

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

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

35− stimes = stimesIdempotentMonoid

36−

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

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

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

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

41−

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

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

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

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

46−

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

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

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

50−

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

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

53−patchIntMapNewElementsMap :: PatchIntMap a -> IntMap a

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

55−

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

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

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

59−getDeletions (PatchIntMap m) v = IntMap.intersection v m

src/Reflex/Patch/Map.hsdeleted−55

@@ -1,55 +0,0 @@

1−{-# LANGUAGE LambdaCase #-}

2−{-# LANGUAGE TypeFamilies #-}

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

4−-- and deletions

5−module Reflex.Patch.Map where

6−

7−import Reflex.Patch.Class

8−

9−import Data.Map (Map)

10−import qualified Data.Map as Map

11−import Data.Maybe

12−import Data.Semigroup

13−

14−-- | A set of changes to a 'Map'. Any element may be inserted/updated or

15−-- deleted. Insertions are represented as values wrapped in 'Just', while

16−-- deletions are represented as 'Nothing's

17−newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }

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

19−

20−-- | Apply the insertions or deletions to a given 'Map'.

21−instance Ord k => Patch (PatchMap k v) where

22− type PatchTarget (PatchMap k v) = Map k v

23− {-# INLINABLE apply #-}

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

25− where insertions = Map.mapMaybeWithKey (const id) p

26− deletions = Map.mapMaybeWithKey (const nothingToJust) p

27− nothingToJust = \case

28− Nothing -> Just ()

29− Just _ -> Nothing

30−

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

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

33−-- precedence.

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

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

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

37− stimes = stimesIdempotentMonoid

38−

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

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

41− mempty = PatchMap mempty

42− mappend = (<>)

43−

44−-- | 'fmap'ping a 'PatchMap' will alter all of the values it will insert.

45−-- Deletions are unaffected.

46−instance Functor (PatchMap k) where

47− fmap f = PatchMap . fmap (fmap f) . unPatchMap

48−

49−-- | Returns all the new elements that will be added to the 'Map'

50−patchMapNewElements :: PatchMap k v -> [v]

51−patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p

52−

53−-- | Returns all the new elements that will be added to the 'Map'

54−patchMapNewElementsMap :: PatchMap k v -> Map k v

55−patchMapNewElementsMap (PatchMap p) = Map.mapMaybe id p

src/Reflex/Patch/MapWithMove.hsdeleted−270

@@ -1,270 +0,0 @@

1−{-# LANGUAGE DeriveFoldable #-}

2−{-# LANGUAGE DeriveFunctor #-}

3−{-# LANGUAGE DeriveTraversable #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE LambdaCase #-}

6−{-# LANGUAGE PatternGuards #-}

7−{-# LANGUAGE ScopedTypeVariables #-}

8−{-# LANGUAGE TypeFamilies #-}

9−-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to

10−-- another

11−module Reflex.Patch.MapWithMove where

12−

13−import Reflex.Patch.Class

14−

15−import Control.Arrow

16−import Control.Monad.State

17−import Data.Foldable

18−import Data.Function

19−import Data.List

20−import Data.Map (Map)

21−import qualified Data.Map as Map

22−import Data.Maybe

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

24−import qualified Data.Set as Set

25−import Data.These (These(..))

26−import Data.Tuple

27−

28−-- | Patch a DMap with additions, deletions, and moves. Invariant: If key @k1@

29−-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,

30−-- and vice versa. There should never be any unpaired From/To keys.

31−newtype PatchMapWithMove k v = PatchMapWithMove (Map k (NodeInfo k v)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable)

32−

33−-- | Holds the information about each key: where its new value should come from,

34−-- and where its old value should go to

35−data NodeInfo k v = NodeInfo

36− { _nodeInfo_from :: !(From k v)

37− -- ^ Where do we get the new value for this key?

38− , _nodeInfo_to :: !(To k)

39− -- ^ If the old value is being kept (i.e. moved rather than deleted or

40− -- replaced), where is it going?

41− }

42− deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)

43−

44−-- | Describe how a key's new value should be produced

45−data From k v

46− = From_Insert v -- ^ Insert the given value here

47− | From_Delete -- ^ Delete the existing value, if any, from here

48− | From_Move !k -- ^ Move the value here from the given key

49− deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)

50−

51−-- | Describe where a key's old value will go. If this is 'Just', that means

52−-- the key's old value will be moved to the given other key; if it is 'Nothing',

53−-- that means it will be deleted.

54−type To = Maybe

55−

56−-- | Create a 'PatchMapWithMove', validating it

57−patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)

58−patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing

59− where valid = forwardLinks == backwardLinks

60− forwardLinks = Map.mapMaybe _nodeInfo_to m

61− backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, v) ->

62− case _nodeInfo_from v of

63− From_Move from -> Just (from, to)

64− _ -> Nothing

65−

66−-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'

67−patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v

68−patchMapWithMoveInsertAll m = PatchMapWithMove $ flip fmap m $ \v -> NodeInfo

69− { _nodeInfo_from = From_Insert v

70− , _nodeInfo_to = Nothing

71− }

72−

73−-- | Extract the internal representation of the 'PatchMapWithMove'

74−unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)

75−unPatchMapWithMove (PatchMapWithMove p) = p

76−

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

78−insertMapKey :: k -> v -> PatchMapWithMove k v

79−insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing

80−

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

82−--

83−-- @

84−-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))

85−-- @

86−moveMapKey :: Ord k => k -> k -> PatchMapWithMove k v

87−moveMapKey src dst

88− | src == dst = mempty

89− | otherwise =

90− PatchMapWithMove $ Map.fromList

91− [ (dst, NodeInfo (From_Move src) Nothing)

92− , (src, NodeInfo From_Delete (Just dst))

93− ]

94−

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

96−--

97−-- @

98−-- let aMay = Map.lookup a map

99−-- bMay = Map.lookup b map

100−-- in maybe id (Map.insert a) (bMay `mplus` aMay)

101−-- . maybe id (Map.insert b) (aMay `mplus` bMay)

102−-- . Map.delete a . Map.delete b $ map

103−-- @

104−swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v

105−swapMapKey src dst

106− | src == dst = mempty

107− | otherwise =

108− PatchMapWithMove $ Map.fromList

109− [ (dst, NodeInfo (From_Move src) (Just src))

110− , (src, NodeInfo (From_Move dst) (Just dst))

111− ]

112−

113−-- |Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'Map.delete'.

114−deleteMapKey :: k -> PatchMapWithMove k v

115−deleteMapKey k = PatchMapWithMove . Map.singleton k $ NodeInfo From_Delete Nothing

116−

117−-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants.

118−--

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

120−unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v

121−unsafePatchMapWithMove = PatchMapWithMove

122−

123−-- | Apply the insertions, deletions, and moves to a given 'Map'

124−instance Ord k => Patch (PatchMapWithMove k v) where

125− type PatchTarget (PatchMapWithMove k v) = Map k v

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

127− where insertions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of

128− From_Insert v -> Just v

129− From_Move k -> Map.lookup k old

130− From_Delete -> Nothing

131− deletions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of

132− From_Delete -> Just ()

133− _ -> Nothing

134−

135−-- | Returns all the new elements that will be added to the 'Map'.

136−patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]

137−patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap

138−

139−-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@.

140−patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v

141−patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p

142− where f ni = case _nodeInfo_from ni of

143− From_Insert v -> Just v

144− From_Move _ -> Nothing

145− From_Delete -> Nothing

146−

147−-- | Create a 'PatchMapWithMove' that, if applied to the given 'Map', will sort

148−-- its values using the given ordering function. The set keys of the 'Map' is

149−-- not changed.

150−patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v

151−patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted

152− where unsorted = Map.toList m

153− sorted = sortBy (cmp `on` snd) unsorted

154− f (to, _) (from, _) = if to == from then Nothing else

155− Just (from, to)

156− reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted

157− g (to, _) (from, _) = if to == from then Nothing else

158− let Just movingTo = Map.lookup from reverseMapping

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

160−

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

162−-- will produce a 'Map' with the same values as the second 'Map' but with the

163−-- values sorted with the given ordering function.

164−patchThatChangesAndSortsMapWith :: forall k v. (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v

165−patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex

166− where newList = Map.toList newByIndexUnsorted

167− newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList

168−

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

170−-- will produce the second 'Map'.

171−patchThatChangesMap :: (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v

172−patchThatChangesMap oldByIndex newByIndex = patch

173− where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex

174− (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do

175− let f k v = do

176− remainingValues <- get

177− let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys

178− then Map.delete v remainingValues

179− else Map.insert v remainingKeys remainingValues

180− case Map.lookup v remainingValues of

181− Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take

182− Just fromKs ->

183− if k `Set.member` fromKs

184− then do

185− putRemainingKeys $ Set.delete k fromKs

186− return $ NodeInfo (From_Move k) $ Just undefined -- There's an existing value, and it's here, so no patch necessary

187− else do

188− (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here

189− putRemainingKeys remainingKeys

190− return $ NodeInfo (From_Move fromK) $ Just undefined

191− Map.traverseWithKey f newByIndex

192− unusedOldKeys = fold unusedValuesByValue

193− pointlessMove k = \case

194− From_Move k' | k == k' -> True

195− _ -> False

196− keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)

197− then Just undefined

198− else Nothing

199− patch = unsafePatchMapWithMove $ Map.filterWithKey (\k -> not . pointlessMove k . _nodeInfo_from) $ Map.mergeWithKey (\k a _ -> Just $ nodeInfoSetTo (keyWasMoved k) a) (Map.mapWithKey $ \k -> nodeInfoSetTo $ keyWasMoved k) (Map.mapWithKey $ \k _ -> NodeInfo From_Delete $ keyWasMoved k) insertsAndMoves oldByIndex

200−

201−-- | Change the 'From' value of a 'NodeInfo'

202−nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v

203−nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }

204−

205−-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or

206−-- 'Applicative', 'Monad', etc.) action to get the new value

207−nodeInfoMapMFrom :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)

208−nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni

209−

210−-- | Set the 'To' field of a 'NodeInfo'

211−nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v

212−nodeInfoSetTo to ni = ni { _nodeInfo_to = to }

213−

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

215−data Fixup k v

216− = Fixup_Delete

217− | Fixup_Update (These (From k v) (To k))

218−

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

220−instance Ord k => Semigroup (PatchMapWithMove k v) where

221− PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m

222− where

223− connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb

224− h :: (k, (Maybe k, From k v)) -> [(k, Fixup k v)]

225− h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of

226− (Just toAfter, From_Move fromBefore)

227− | fromBefore == toAfter

228− -> [(toAfter, Fixup_Delete)]

229− | otherwise

230− -> [ (toAfter, Fixup_Update (This editBefore))

231− , (fromBefore, Fixup_Update (That mToAfter))

232− ]

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

234− (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]

235− (Nothing, _) -> []

236− mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete

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

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

239− = Fixup_Update $ These x y

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

241− = Fixup_Update $ These x y

242− mergeFixups _ _ _ = error "PatchMapWithMove: incompatible fixups"

243− fixups = Map.fromListWithKey mergeFixups $ concatMap h connections

244− combineNodeInfos _ nia nib = NodeInfo

245− { _nodeInfo_from = _nodeInfo_from nia

246− , _nodeInfo_to = _nodeInfo_to nib

247− }

248− applyFixup _ ni = \case

249− Fixup_Delete -> Nothing

250− Fixup_Update u -> Just $ NodeInfo

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

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

253− }

254− m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups

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

256− getHere = \case

257− This a -> Just a

258− These a _ -> Just a

259− That _ -> Nothing

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

261− getThere = \case

262− This _ -> Nothing

263− These _ b -> Just b

264− That b -> Just b

265−

266−--TODO: Figure out how to implement this in terms of PatchDMapWithMove rather than duplicating it here

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

268−instance Ord k => Monoid (PatchMapWithMove k v) where

269− mempty = PatchMapWithMove mempty

270− mappend = (<>)

src/Reflex/PerformEvent/Base.hs+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 (Identity <$>) toPerform

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

145 mrt <- readRef responseTrigger

146 let followupEventTriggers = case mrt of

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

src/Reflex/Profiled.hs+2−2

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

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

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

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

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

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

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

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

152 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i

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

154 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i

src/Reflex/Query/Base.hs+6−1

@@ -16,6 +16,7 @@ module Reflex.Query.Base

16 , mapQueryResult

17 , dynWithQueryT

18 , withQueryT

19+ , mapQueryT

19 ) where

20 ) where

21import Control.Applicative (liftA2)

22import Control.Applicative (liftA2)

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

46import Reflex.EventWriter.Base

47import Reflex.EventWriter.Base

47import Reflex.EventWriter.Class

48import Reflex.EventWriter.Class

48import Reflex.Host.Class

49import Reflex.Host.Class

49−import qualified Reflex.Patch.MapWithMove as MapWithMove

50+import qualified Data.Patch.MapWithMove as MapWithMove

50import Reflex.PerformEvent.Class

51import Reflex.PerformEvent.Class

51import Reflex.PostBuild.Class

52import Reflex.PostBuild.Class

52import Reflex.Query.Class

53import Reflex.Query.Class

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

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

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

288 return result

289 return result

289

290

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

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

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

294+

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

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

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

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

292 => Dynamic t (QueryMorphism q q')

297 => Dynamic t (QueryMorphism q q')

src/Reflex/Query/Class.hs+40

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

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE DeriveDataTypeable #-}

2{-# LANGUAGE DeriveDataTypeable #-}

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

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

21 , MonadQuery (..)

22 , MonadQuery (..)

22 , tellQueryDyn

23 , tellQueryDyn

23 , queryDyn

24 , queryDyn

25+ , subQuery

24 , mapQuery

26 , mapQuery

25 , mapQueryResult

27 , mapQueryResult

26 ) where

28 ) where

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

35import qualified Data.Map.Monoidal as MonoidalMap

37import qualified Data.Map.Monoidal as MonoidalMap

36import Data.Semigroup (Semigroup(..))

38import Data.Semigroup (Semigroup(..))

37import Foreign.Storable

39import Foreign.Storable

40+import Data.Void

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

42+import Control.Applicative

39import Reflex.Class

44import Reflex.Class

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

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

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

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

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

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

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

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

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

62+

63+-- | Trivial queries have trivial results.

64+instance Query () where

65+ type QueryResult () = ()

66+ crop _ _ = ()

67+

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

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

70+--

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

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

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

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

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

76+-- uninhabited as desired.

77+instance Query Void where

78+ type QueryResult Void = ()

79+ crop = absurd

80+

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

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

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

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

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

86+ crop = liftA2 crop

87+#endif

88+

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

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

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

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

55data QueryMorphism q q' = QueryMorphism

91data QueryMorphism q q' = QueryMorphism

@@ -116,3 +152,7 @@ queryDyn :: (Reflex t, Monad m, MonadQuery t q m) => Dynamic t q -> m (Dynamic t

116queryDyn q = do

152queryDyn q = do

117 tellQueryDyn q

153 tellQueryDyn q

118 zipDynWith crop q <$> askQueryResult

154 zipDynWith crop q <$> askQueryResult

155+

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

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

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

src/Reflex/Spider/Internal.hs+454−257

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

38import Control.Monad.Exception

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

40import Control.Monad.Primitive

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

42import Control.Monad.Reader.Class

41import Control.Monad.Reader.Class

43import Control.Monad.IO.Class

42import Control.Monad.IO.Class

44import Control.Monad.ReaderIO

43import Control.Monad.ReaderIO

45import Control.Monad.Ref

44import Control.Monad.Ref

45+import Control.Monad.Fail (MonadFail)

46+import qualified Control.Monad.Fail as MonadFail

46import Data.Align

47import Data.Align

47import Data.Coerce

48import Data.Coerce

48import Data.Dependent.Map (DMap, DSum (..))

49import Data.Dependent.Map (DMap, DSum (..))

@@ -59,12 +60,13 @@ import qualified Data.IntMap.Strict as IntMap

59import Data.IORef

60import Data.IORef

60import Data.Kind (Type)

61import Data.Kind (Type)

61import Data.Maybe hiding (mapMaybe)

62import Data.Maybe hiding (mapMaybe)

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

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

63import Data.Proxy

64import Data.Proxy

64import Data.These

65import Data.These

65import Data.Traversable

66import Data.Traversable

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

66import Data.Witherable (Filterable, mapMaybe)

68import Data.Witherable (Filterable, mapMaybe)

67−import GHC.Exts

69+import GHC.Exts hiding (toList)

68import GHC.IORef (IORef (..))

70import GHC.IORef (IORef (..))

69import GHC.Stack

71import GHC.Stack

70import Reflex.FastWeak

72import Reflex.FastWeak

@@ -83,14 +85,16 @@ import Data.Zip (Zip (..))

84#ifdef DEBUG_CYCLES

86#ifdef DEBUG_CYCLES

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

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

88+#endif

89+

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

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

87import qualified Data.List.NonEmpty as NonEmpty

91import qualified Data.List.NonEmpty as NonEmpty

88−import Data.Monoid (mempty)

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

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

90−#endif

93+import Data.List (isPrefixOf)

92−import Data.FastWeakBag (FastWeakBag)

95+import Data.FastWeakBag (FastWeakBag, FastWeakBagTicket)

93import qualified Data.FastWeakBag as FastWeakBag

96import qualified Data.FastWeakBag as FastWeakBag

97+

94import Data.Reflection

98import Data.Reflection

95import Data.Some (Some(Some))

99import Data.Some (Some(Some))

96import Data.Type.Coercion

100import Data.Type.Coercion

@@ -101,20 +105,26 @@ import qualified Reflex.Class

101import qualified Reflex.Class as R

105import qualified Reflex.Class as R

102import qualified Reflex.Host.Class

106import qualified Reflex.Host.Class

103import Reflex.NotReady.Class

107import Reflex.NotReady.Class

104−import Reflex.Patch

108+import Data.Patch

105−import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove

109+import qualified Data.Patch.DMapWithMove as PatchDMapWithMove

110+import Reflex.PerformEvent.Base (PerformEventT)

106

111

107#ifdef DEBUG_TRACE_EVENTS

112#ifdef DEBUG_TRACE_EVENTS

108import qualified Data.ByteString.Char8 as BS8

113import qualified Data.ByteString.Char8 as BS8

109import System.IO (stderr)

114import System.IO (stderr)

115+import Data.List (isPrefixOf)

110#endif

116#endif

111

117

112−#ifdef DEBUG_TRACE_EVENTS

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

119+debugStrLn :: String -> IO ()

120+debugStrLn = putStrLn

113

121

122+#ifdef DEBUG_TRACE_EVENTS

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

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

115withStackOneLine expr = unsafePerformIO $ do

124withStackOneLine expr = unsafePerformIO $ do

116 stack <- currentCallStack

125 stack <- currentCallStack

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

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

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

118

128

119#endif

129#endif

120

130

@@ -125,28 +135,42 @@ debugInvalidateHeight :: Bool

125debugInvalidate :: Bool

135debugInvalidate :: Bool

126

136

127#ifdef DEBUG

137#ifdef DEBUG

128−

129#define DEBUG_NODEIDS

138#define DEBUG_NODEIDS

130

139

140+#ifdef DEBUG_TRACE_PROPAGATION

131debugPropagate = True

141debugPropagate = True

142+#else

143+debugPropagate = False

144+#endif

132

145

146+#ifdef DEBUG_TRACE_HEIGHT

147+debugInvalidateHeight = True

148+#else

133debugInvalidateHeight = False

149debugInvalidateHeight = False

150+#endif

134

151

152+#ifdef DEBUG_TRACE_INVALIDATION

135debugInvalidate = True

153debugInvalidate = True

154+#else

155+debugInvalidate = False

156+#endif

136

157

137class HasNodeId a where

158class HasNodeId a where

138 getNodeId :: a -> Int

159 getNodeId :: a -> Int

139

160

140−instance HasNodeId (Hold x p a) where

161+instance HasNodeId (CacheSubscribed x a) where

141− getNodeId = holdNodeId

162+ getNodeId = _cacheSubscribed_nodeId

142

163

143−instance HasNodeId (PushSubscribed x a b) where

164+instance HasNodeId (FanInt x a) where

144− getNodeId = pushSubscribedNodeId

165+ getNodeId = _fanInt_nodeId

166+

167+instance HasNodeId (Hold x p) where

168+ getNodeId = holdNodeId

145

169

146instance HasNodeId (SwitchSubscribed x a) where

170instance HasNodeId (SwitchSubscribed x a) where

147 getNodeId = switchSubscribedNodeId

171 getNodeId = switchSubscribedNodeId

148

172

149−instance HasNodeId (FanSubscribed x a) where

173+instance HasNodeId (FanSubscribed x v a) where

150 getNodeId = fanSubscribedNodeId

174 getNodeId = fanSubscribedNodeId

151

175

152instance HasNodeId (CoincidenceSubscribed x a) where

176instance HasNodeId (CoincidenceSubscribed x a) where

@@ -160,41 +184,16 @@ instance HasNodeId (Pull x a) where

160

184

161{-# INLINE showNodeId #-}

185{-# INLINE showNodeId #-}

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

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

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

187+showNodeId = showNodeId' . getNodeId

164−

188+

165−showSubscriberType :: Subscriber x a -> String

189+showNodeId' :: Int -> String

166−showSubscriberType = \case

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

167− SubscriberPush _ _ -> "SubscriberPush"

191+

168− SubscriberMerge _ _ -> "SubscriberMerge"

169− SubscriberFan _ -> "SubscriberFan"

170− SubscriberMergeChange _ -> "SubscriberMergeChange"

171− SubscriberHold _ -> "SubscriberHold"

172− SubscriberHoldIdentity _ -> "SubscriberHoldIdentity"

173− SubscriberSwitch _ -> "SubscriberSwitch"

174− SubscriberCoincidenceOuter _ -> "SubscriberCoincidenceOuter"

175− SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"

176− SubscriberHandle -> "SubscriberHandle"

177−

178−showEventType :: Event x a -> String

179−showEventType = \case

180− EventRoot _ _ -> "EventRoot"

181− EventNever -> "EventNever"

182− EventPush _ -> "EventPush"

183− EventMerge _ -> "EventMerge"

184− EventFan _ _ -> "EventFan"

185− EventSwitch _ -> "EventSwitch"

186− EventCoincidence _ -> "EventCoincidence"

187− EventHold _ -> "EventHold"

188− EventDyn _ -> "EventDyn"

189− EventHoldIdentity _ -> "EventHoldIdentity"

190− EventDynIdentity _ -> "EventDynIdentity"

191

192

192#else

193#else

193

194

194debugPropagate = False

195debugPropagate = False

195−

196debugInvalidateHeight = False

197−

198debugInvalidate = False

197debugInvalidate = False

199

198

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

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

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

202showNodeId :: a -> String

201showNodeId :: a -> String

203showNodeId _ = ""

202showNodeId _ = ""

204

203

204+{-# INLINE showNodeId' #-}

205+showNodeId' :: Int -> String

206+showNodeId' _ = ""

207+

205#endif

208#endif

206

209

207#ifdef DEBUG_NODEIDS

210#ifdef DEBUG_NODEIDS

@@ -247,9 +250,9 @@ subscribeAndRead = unEvent

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

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

248-- efficient than 'push'

251-- efficient than 'push'

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

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

250−pushCheap :: (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b

253+pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b

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

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

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

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

253 { subscriberPropagate = \a -> do

256 { subscriberPropagate = \a -> do

254 mb <- f a

257 mb <- f a

255 mapM_ (subscriberPropagate sub) mb

258 mapM_ (subscriberPropagate sub) mb

@@ -268,10 +271,10 @@ terminalSubscriber p = Subscriber

268

271

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

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

270{-# INLINE subscribeAndReadHead #-}

273{-# INLINE subscribeAndReadHead #-}

271−subscribeAndReadHead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)

274+subscribeAndReadHead :: HasSpiderTimeline x => Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)

272subscribeAndReadHead e sub = do

275subscribeAndReadHead e sub = do

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

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

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

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

275 { subscriberPropagate = \a -> do

278 { subscriberPropagate = \a -> do

276 liftIO $ unsubscribe =<< readIORef subscriptionRef

279 liftIO $ unsubscribe =<< readIORef subscriptionRef

277 subscriberPropagate sub a

280 subscriberPropagate sub a

@@ -282,24 +285,29 @@ subscribeAndReadHead e sub = do

282 return (subscription, occ)

285 return (subscription, occ)

283

286

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

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

285−headE :: (MonadIO m, Defer (SomeMergeInit x) m) => Event x a -> m (Event x a)

288+headE :: (MonadIO m, Defer (SomeMergeInit x) m, HasSpiderTimeline x) => Event x a -> m (Event x a)

286headE originalE = do

289headE originalE = do

287 parent <- liftIO $ newIORef $ Just originalE

290 parent <- liftIO $ newIORef $ Just originalE

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

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

289 let clearParent = liftIO $ writeIORef parent Nothing

292 let clearParent = liftIO $ writeIORef parent Nothing

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

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

291 when (isJust occ) clearParent

294 when (isJust occ) clearParent

292− return $ Event $ \sub -> do

295+ return $ Event $ \sub ->

293 liftIO (readIORef parent) >>= \case

296 liftIO (readIORef parent) >>= \case

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

297+ Nothing -> subscribeAndReadNever

295 Just e -> subscribeAndReadHead e sub

298 Just e -> subscribeAndReadHead e sub

296

299

297data CacheSubscribed x a

300data CacheSubscribed x a

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

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

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

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

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

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

304+#ifdef DEBUG_NODEIDS

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

306+#endif

301 }

307 }

302

308

309+

310+

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

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

304-- repeatedly

312-- repeatedly

305--

313--

@@ -324,18 +332,23 @@ cacheEvent e =

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

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

325 Just subscribedTicket -> return subscribedTicket

333 Just subscribedTicket -> return subscribedTicket

326 Nothing -> do

334 Nothing -> do

335+#ifdef DEBUG_NODEIDS

336+ nodeId <- liftIO newNodeId

337+#endif

327 subscribers <- liftIO FastWeakBag.empty

338 subscribers <- liftIO FastWeakBag.empty

328 occRef <- liftIO $ newIORef Nothing -- This should never be read prior to being set below

339 occRef <- liftIO $ newIORef Nothing -- This should never be read prior to being set below

340+#ifdef DEBUG_NODEIDS

341+ (parentSub, occ) <- subscribeAndRead e $ debugSubscriber' ("cacheEvent" <> showNodeId' nodeId) $ Subscriber

342+#else

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

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

344+#endif

330− { subscriberPropagate = \a -> do

345+ { subscriberPropagate = \a -> do

331− liftIO $ writeIORef occRef $ Just a

346+ liftIO $ writeIORef occRef (Just a)

332− scheduleClear occRef

347+ scheduleClear occRef

333− propagateFast a subscribers

348+ propagateFast a subscribers

334− , subscriberInvalidateHeight = \old -> do

335− FastWeakBag.traverse subscribers $ invalidateSubscriberHeight old

349+ , subscriberInvalidateHeight = FastWeakBag.traverse_ subscribers . invalidateSubscriberHeight

336− , subscriberRecalculateHeight = \new -> do

337− FastWeakBag.traverse subscribers $ recalculateSubscriberHeight new

350+ , subscriberRecalculateHeight = FastWeakBag.traverse_ subscribers . recalculateSubscriberHeight

338− }

351+ }

339 when (isJust occ) $ do

352 when (isJust occ) $ do

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

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

341 scheduleClear occRef

354 scheduleClear occRef

@@ -343,29 +356,45 @@ cacheEvent e =

343 { _cacheSubscribed_subscribers = subscribers

356 { _cacheSubscribed_subscribers = subscribers

344 , _cacheSubscribed_parent = parentSub

357 , _cacheSubscribed_parent = parentSub

345 , _cacheSubscribed_occurrence = occRef

358 , _cacheSubscribed_occurrence = occRef

359+#ifdef DEBUG_NODEIDS

360+ , _cacheSubscribed_nodeId = nodeId

361+#endif

346 }

362 }

347 subscribedTicket <- liftIO $ mkFastWeakTicket subscribed

363 subscribedTicket <- liftIO $ mkFastWeakTicket subscribed

348 liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket

364 liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket

349 return subscribedTicket

365 return subscribedTicket

350− liftIO $ do

366+ liftIO $ cacheSubscription sub mSubscribedRef subscribedTicket

367+

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

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

370+cacheSubscription sub mSubscribedRef subscribedTicket = do

351− subscribed <- getFastWeakTicketValue subscribedTicket

371+ subscribed <- getFastWeakTicketValue subscribedTicket

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

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

353− occ <- readIORef $ _cacheSubscribed_occurrence subscribed

373+ occ <- readIORef $ _cacheSubscribed_occurrence subscribed

374+

375+ let parentSub = _cacheSubscribed_parent subscribed

354− let es = EventSubscription

376+ es = EventSubscription

355− { _eventSubscription_unsubscribe = do

377+ { _eventSubscription_unsubscribe = do

356− FastWeakBag.remove ticket

378+ FastWeakBag.remove ticket

379+

357− isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed

380+ isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed

358− when isEmpty $ do

381+ when isEmpty $ do

359− writeIORef mSubscribedRef emptyFastWeak

382+ writeIORef mSubscribedRef emptyFastWeak

360− unsubscribe $ _cacheSubscribed_parent subscribed

383+ unsubscribe parentSub

361− touch ticket

384+ touch ticket

362− touch subscribedTicket

385+ touch subscribedTicket

363− , _eventSubscription_subscribed = EventSubscribed

386+ , _eventSubscription_subscribed = EventSubscribed

364− { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed

387+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed parentSub

365− , eventSubscribedRetained = toAny subscribedTicket

388+ , eventSubscribedRetained = toAny subscribedTicket

389+#ifdef DEBUG_CYCLES

390+ , eventSubscribedGetParents = return [_eventSubscription_subscribed parentSub]

391+ , eventSubscribedHasOwnHeightRef = False

392+ , eventSubscribedWhoCreated = whoCreatedIORef mSubscribedRef

393+#endif

366− }

394+ }

367− }

395+ }

368− return (es, occ)

396+ return (es, occ)

397+

369

398

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

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

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

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

@@ -377,11 +406,14 @@ wrap tag getSpecificSubscribed sub = do

377 let es = tag subd

406 let es = tag subd

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

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

379

408

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

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

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

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

382

411

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

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

414+

383eventNever :: Event x a

415eventNever :: Event x a

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

416+eventNever = Event $ const subscribeAndReadNever

385

417

386eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k v -> Event x (v a)

418eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k v -> Event x (v a)

387eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f

419eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f

@@ -436,10 +468,10 @@ newSubscriberHold h = return $ Subscriber

436 }

468 }

437

469

438newSubscriberFan :: forall x k v. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k v -> IO (Subscriber x (DMap k v))

470newSubscriberFan :: forall x k v. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k v -> IO (Subscriber x (DMap k v))

439−newSubscriberFan subscribed = return $ Subscriber

471+newSubscriberFan subscribed = debugSubscriber ("SubscriberFan " <> showNodeId subscribed) $ Subscriber

440 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do

472 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do

441 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed

473 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed

442− tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"

474+ tracePropagate (Proxy :: Proxy x) $ show (DMap.size subs) <> " keys subscribed, " <> show (DMap.size a) <> " keys firing"

443 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a

475 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a

444 scheduleClear $ fanSubscribedOccurrence subscribed

476 scheduleClear $ fanSubscribedOccurrence subscribed

445 let f _ (Pair v subsubs) = do

477 let f _ (Pair v subsubs) = do

@@ -448,72 +480,55 @@ newSubscriberFan subscribed = return $ Subscriber

448 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_

480 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_

449 return ()

481 return ()

450 , subscriberInvalidateHeight = \old -> do

482 , subscriberInvalidateHeight = \old -> do

451− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed

452 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

483 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

453− forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old

484+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old

454− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"

455 , subscriberRecalculateHeight = \new -> do

485 , subscriberRecalculateHeight = \new -> do

456− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed

457 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

486 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

458− forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new

487+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new

459− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"

460 }

488 }

461

489

462newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)

490newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)

463−newSubscriberSwitch subscribed = return $ Subscriber

491+newSubscriberSwitch subscribed = debugSubscriber ("SubscriberCoincidenceOuter" <> showNodeId subscribed) $ Subscriber

464 { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do

492 { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do

465− tracePropagate (Proxy :: Proxy x) $ "SubscriberSwitch" <> showNodeId subscribed

466 liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a

493 liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a

467 scheduleClear $ switchSubscribedOccurrence subscribed

494 scheduleClear $ switchSubscribedOccurrence subscribed

468 propagate a $ switchSubscribedSubscribers subscribed

495 propagate a $ switchSubscribedSubscribers subscribed

469 , subscriberInvalidateHeight = \_ -> do

496 , subscriberInvalidateHeight = \_ -> do

470− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed

471 oldHeight <- readIORef $ switchSubscribedHeight subscribed

497 oldHeight <- readIORef $ switchSubscribedHeight subscribed

472 when (oldHeight /= invalidHeight) $ do

498 when (oldHeight /= invalidHeight) $ do

473 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight

499 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight

474− WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

500+ WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

475− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"

476− , subscriberRecalculateHeight = \new -> do

501+ , subscriberRecalculateHeight = (`updateSwitchHeight` subscribed)

477− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed

478− updateSwitchHeight new subscribed

479− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"

480− }

502+ }

481

503

482newSubscriberCoincidenceOuter :: forall x b. HasSpiderTimeline x => CoincidenceSubscribed x b -> IO (Subscriber x (Event x b))

504newSubscriberCoincidenceOuter :: forall x b. HasSpiderTimeline x => CoincidenceSubscribed x b -> IO (Subscriber x (Event x b))

483−newSubscriberCoincidenceOuter subscribed = return $ Subscriber

505+newSubscriberCoincidenceOuter subscribed = debugSubscriber ("SubscriberCoincidenceOuter" <> showNodeId subscribed) $ Subscriber

484 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do

506 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do

485− tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceOuter" <> showNodeId subscribed

486 outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed

507 outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed

487 tracePropagate (Proxy :: Proxy x) $ " outerHeight = " <> show outerHeight

508 tracePropagate (Proxy :: Proxy x) $ " outerHeight = " <> show outerHeight

488 (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed

509 (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed

489 tracePropagate (Proxy :: Proxy x) $ " isJust occ = " <> show (isJust occ)

510 tracePropagate (Proxy :: Proxy x) $ " isJust occ = " <> show (isJust occ)

490 tracePropagate (Proxy :: Proxy x) $ " innerHeight = " <> show innerHeight

511 tracePropagate (Proxy :: Proxy x) $ " innerHeight = " <> show innerHeight

512+

491 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd

513 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd

492 scheduleClear $ coincidenceSubscribedInnerParent subscribed

514 scheduleClear $ coincidenceSubscribedInnerParent subscribed

493 case occ of

515 case occ of

494− Nothing -> do

516+ Nothing ->

495 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height

517 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height

496 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight

518 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight

497− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight

519+ WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight

498− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight

520+ WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight

499 Just o -> do -- Since it's already firing, no need to adjust height

521 Just o -> do -- Since it's already firing, no need to adjust height

500 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ

522 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ

501 scheduleClear $ coincidenceSubscribedOccurrence subscribed

523 scheduleClear $ coincidenceSubscribedOccurrence subscribed

502 propagate o $ coincidenceSubscribedSubscribers subscribed

524 propagate o $ coincidenceSubscribedSubscribers subscribed

503− , subscriberInvalidateHeight = \_ -> do

504− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed

505− invalidateCoincidenceHeight subscribed

525+ , subscriberInvalidateHeight = \_ -> invalidateCoincidenceHeight subscribed

506− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"

507− , subscriberRecalculateHeight = \_ -> do

508− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed

509− recalculateCoincidenceHeight subscribed

526+ , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed

510− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"

511 }

527 }

512

528

513newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)

529newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)

514−newSubscriberCoincidenceInner subscribed = return $ Subscriber

530+newSubscriberCoincidenceInner subscribed = debugSubscriber ("SubscriberCoincidenceInner" <> showNodeId subscribed) $ Subscriber

515 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do

531 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do

516− tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceInner" <> showNodeId subscribed

517 occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed

532 occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed

518 case occ of

533 case occ of

519 Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event

534 Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event

@@ -521,14 +536,8 @@ newSubscriberCoincidenceInner subscribed = return $ Subscriber

521 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a

536 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a

522 scheduleClear $ coincidenceSubscribedOccurrence subscribed

537 scheduleClear $ coincidenceSubscribedOccurrence subscribed

523 propagate a $ coincidenceSubscribedSubscribers subscribed

538 propagate a $ coincidenceSubscribedSubscribers subscribed

524− , subscriberInvalidateHeight = \_ -> do

525− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed

526− invalidateCoincidenceHeight subscribed

539+ , subscriberInvalidateHeight = \_ -> invalidateCoincidenceHeight subscribed

527− when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"

528− , subscriberRecalculateHeight = \_ -> do

529− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed

530− recalculateCoincidenceHeight subscribed

540+ , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed

531− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"

532 }

541 }

533

542

534invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()

543invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()

@@ -538,18 +547,18 @@ recalculateSubscriberHeight :: Height -> Subscriber x a -> IO ()

538recalculateSubscriberHeight = flip subscriberRecalculateHeight

547recalculateSubscriberHeight = flip subscriberRecalculateHeight

539

548

540-- | Propagate everything at the current height

549-- | Propagate everything at the current height

541−propagate :: a -> WeakBag (Subscriber x a) -> EventM x ()

550+propagate :: forall x a. HasSpiderTimeline x => a -> WeakBag (Subscriber x a) -> EventM x ()

542−propagate a subscribers = withIncreasedDepth $ do

551+propagate a subscribers = withIncreasedDepth (Proxy::Proxy x) $

543 -- 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

552 -- 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 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work

553 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work

545− WeakBag.traverse subscribers $ \s -> subscriberPropagate s a

554+ WeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a

546

555

547-- | Propagate everything at the current height

556-- | Propagate everything at the current height

548−propagateFast :: a -> FastWeakBag (Subscriber x a) -> EventM x ()

557+propagateFast :: forall x a. HasSpiderTimeline x => a -> FastWeakBag (Subscriber x a) -> EventM x ()

549−propagateFast a subscribers = withIncreasedDepth $ do

558+propagateFast a subscribers = withIncreasedDepth (Proxy::Proxy x) $

550 -- 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

559 -- 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 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work

560 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work

552− FastWeakBag.traverse subscribers $ \s -> subscriberPropagate s a

561+ FastWeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a

553

562

554--------------------------------------------------------------------------------

563--------------------------------------------------------------------------------

555-- EventSubscribed

564-- EventSubscribed

@@ -567,7 +576,7 @@ data EventSubscribed x = EventSubscribed

567 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)

576 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)

568 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any

577 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any

569#ifdef DEBUG_CYCLES

578#ifdef DEBUG_CYCLES

570− , eventSubscribedGetParents :: !(IO [Some (EventSubscribed x)]) -- For debugging loops

579+ , eventSubscribedGetParents :: !(IO [EventSubscribed x]) -- For debugging loops

571 , eventSubscribedHasOwnHeightRef :: !Bool

580 , eventSubscribedHasOwnHeightRef :: !Bool

572 , eventSubscribedWhoCreated :: !(IO [String])

581 , eventSubscribedWhoCreated :: !(IO [String])

573#endif

582#endif

@@ -600,7 +609,7 @@ eventSubscribedFan !subscribed = EventSubscribed

600 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed

609 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed

601 , eventSubscribedRetained = toAny subscribed

610 , eventSubscribedRetained = toAny subscribed

602#ifdef DEBUG_CYCLES

611#ifdef DEBUG_CYCLES

603− , eventSubscribedGetParents = return [Some $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]

612+ , eventSubscribedGetParents = return [_eventSubscription_subscribed $ fanSubscribedParent subscribed]

604 , eventSubscribedHasOwnHeightRef = False

613 , eventSubscribedHasOwnHeightRef = False

605 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed

614 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed

606#endif

615#endif

@@ -613,7 +622,7 @@ eventSubscribedSwitch !subscribed = EventSubscribed

613#ifdef DEBUG_CYCLES

622#ifdef DEBUG_CYCLES

614 , eventSubscribedGetParents = do

623 , eventSubscribedGetParents = do

615 s <- readIORef $ switchSubscribedCurrentParent subscribed

624 s <- readIORef $ switchSubscribedCurrentParent subscribed

616− return [Some $ _eventSubscription_subscribed s]

625+ return [_eventSubscription_subscribed s]

617 , eventSubscribedHasOwnHeightRef = True

626 , eventSubscribedHasOwnHeightRef = True

618 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed

627 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed

619#endif

628#endif

@@ -626,8 +635,8 @@ eventSubscribedCoincidence !subscribed = EventSubscribed

626#ifdef DEBUG_CYCLES

635#ifdef DEBUG_CYCLES

627 , eventSubscribedGetParents = do

636 , eventSubscribedGetParents = do

628 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed

637 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed

629− let outerParent = Some $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed

638+ let outerParent = _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed

630− innerParents = maybeToList $ fmap Some innerSubscription

639+ innerParents = maybeToList $ innerSubscription

631 return $ outerParent : innerParents

640 return $ outerParent : innerParents

632 , eventSubscribedHasOwnHeightRef = True

641 , eventSubscribedHasOwnHeightRef = True

633 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed

642 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed

@@ -641,15 +650,15 @@ getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es

641whoCreatedEventSubscribed :: EventSubscribed x -> IO [String]

650whoCreatedEventSubscribed :: EventSubscribed x -> IO [String]

642whoCreatedEventSubscribed = eventSubscribedWhoCreated

651whoCreatedEventSubscribed = eventSubscribedWhoCreated

643

652

644−walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)]

653+walkInvalidHeightParents :: EventSubscribed x -> IO [EventSubscribed x]

645walkInvalidHeightParents s0 = do

654walkInvalidHeightParents s0 = do

646− subscribers <- flip execStateT mempty $ ($ Some s0) $ fix $ \loop (Some s) -> do

655+ subscribers <- flip execStateT mempty $ ($ s0) $ fix $ \loop s -> do

647 h <- liftIO $ readIORef $ eventSubscribedHeightRef s

656 h <- liftIO $ readIORef $ eventSubscribedHeightRef s

648 when (h == invalidHeight) $ do

657 when (h == invalidHeight) $ do

649 when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed

658 when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed

650− modify (Some s :)

659+ modify (s :)

651 mapM_ loop =<< liftIO (eventSubscribedGetParents s)

660 mapM_ loop =<< liftIO (eventSubscribedGetParents s)

652− forM_ subscribers $ \(Some s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight

661+ forM_ subscribers $ \s -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight

653 return subscribers

662 return subscribers

654#endif

663#endif

655

664

@@ -971,8 +980,10 @@ instance Monad (BehaviorM x) where

971 BehaviorM x >> BehaviorM y = BehaviorM $ x >> y

980 BehaviorM x >> BehaviorM y = BehaviorM $ x >> y

972 {-# INLINE return #-}

981 {-# INLINE return #-}

973 return x = BehaviorM $ return x

982 return x = BehaviorM $ return x

983+#if !MIN_VERSION_base(4,13,0)

974 {-# INLINE fail #-}

984 {-# INLINE fail #-}

975 fail s = BehaviorM $ fail s

985 fail s = BehaviorM $ fail s

986+#endif

976

987

977data BehaviorSubscribed x a

988data BehaviorSubscribed x a

978 = forall p. BehaviorSubscribedHold (Hold x p)

989 = forall p. BehaviorSubscribedHold (Hold x p)

@@ -1032,7 +1043,7 @@ data SomeMergeUpdate x = SomeMergeUpdate

1032newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }

1043newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }

1033

1044

1034-- EventM can do everything BehaviorM can, plus create holds

1045-- EventM can do everything BehaviorM can, plus create holds

1035−newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException) -- The environment should be Nothing if we are not in a frame, and Just if we are - in which case it is a list of assignments to be done after the frame is over

1046+newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException)

1036

1047

1037newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }

1048newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }

1038

1049

@@ -1057,7 +1068,8 @@ heightBagFromList :: [Height] -> HeightBag

1057heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights

1068heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights

1058

1069

1059heightBagAdd :: Height -> HeightBag -> HeightBag

1070heightBagAdd :: Height -> HeightBag -> HeightBag

1060−heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $ IntMap.insertWithKey (\_ _ old -> succ old) h 0 c

1071+heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $

1072+ IntMap.insertWithKey (\_ _ old -> succ old) h 0 c

1061

1073

1062heightBagRemove :: Height -> HeightBag -> HeightBag

1074heightBagRemove :: Height -> HeightBag -> HeightBag

1063heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of

1075heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of

@@ -1066,6 +1078,13 @@ heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.loo

1066 0 -> IntMap.delete h c

1078 0 -> IntMap.delete h c

1067 _ -> IntMap.insert h (pred old) c

1079 _ -> IntMap.insert h (pred old) c

1068

1080

1081+heightBagRemoveMaybe :: Height -> HeightBag -> Maybe HeightBag

1082+heightBagRemoveMaybe (Height h) b@(HeightBag s c) = heightBagVerify . removed <$> IntMap.lookup h c where

1083+ removed old = HeightBag (pred s) $ case old of

1084+ 0 -> IntMap.delete h c

1085+ _ -> IntMap.insert h (pred old) c

1086+

1087+

1069heightBagMax :: HeightBag -> Height

1088heightBagMax :: HeightBag -> Height

1070heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of

1089heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of

1071 Just ((h, _), _) -> Height h

1090 Just ((h, _), _) -> Height h

@@ -1313,55 +1332,110 @@ mkWeakPtrWithDebug x debugNote = do

1313 x' <- evaluate x

1332 x' <- evaluate x

1314 mkWeakPtr x' $

1333 mkWeakPtr x' $

1315 if debugFinalize

1334 if debugFinalize

1316− then Just $ putStrLn $ "finalizing: " ++ debugNote

1335+ then Just $ debugStrLn $ "finalizing: " ++ debugNote

1317 else Nothing

1336 else Nothing

1318

1337

1319type WeakList a = [Weak a]

1338type WeakList a = [Weak a]

1320

1339

1321−{-# INLINE withIncreasedDepth #-}

1340+type CanTrace x m = (HasSpiderTimeline x, MonadIO m)

1341+

1342+

1343+

1344+

1322#ifdef DEBUG

1345#ifdef DEBUG

1346+

1347+debugSubscriber :: forall x a. HasSpiderTimeline x => String -> Subscriber x a -> IO (Subscriber x a)

1348+debugSubscriber description = return . debugSubscriber' description

1349+

1350+debugSubscriber' :: forall x a. HasSpiderTimeline x => String -> Subscriber x a -> Subscriber x a

1351+debugSubscriber' description subscribed = Subscriber

1352+ {

1353+ subscriberPropagate = \m -> do

1354+ tracePropagate (Proxy :: Proxy x) ("subscriberPropagate: " <> description)

1355+ subscriberPropagate subscribed m

1356+ , subscriberInvalidateHeight = \old -> do

1357+ traceInvalidateHeight $ "invalidateSubscriberHeight: " <> description <> ", old = " <> show (unHeight old)

1358+ subscriberInvalidateHeight subscribed old

1359+ traceInvalidateHeight $ "invalidateSubscriberHeight: " <> description <> ", done"

1360+ , subscriberRecalculateHeight = \new -> do

1361+ traceInvalidateHeight $ "subscriberRecalculateHeight: " <> description <> ", new = " <> show (unHeight new)

1362+ subscriberRecalculateHeight subscribed new

1363+ traceInvalidateHeight $ "subscriberRecalculateHeight: " <> description <> ", done"

1364+ }

1365+

1366+

1323−withIncreasedDepth :: CanTrace x m => m a -> m a

1367+{-# INLINE withIncreasedDepth #-}

1368+withIncreasedDepth :: forall proxy x m a. CanTrace x m => proxy x -> m a -> m a

1324−withIncreasedDepth a = do

1369+withIncreasedDepth _ a = do

1325− spiderTimeline <- askSpiderTimelineEnv

1326− liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) succ

1370+ liftIO $ modifyIORef' (_spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)) succ

1327 result <- a

1371 result <- a

1328− liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) pred

1372+ liftIO $ modifyIORef' (_spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)) pred

1329 return result

1373 return result

1330−#else

1331−withIncreasedDepth :: m a -> m a

1332−withIncreasedDepth = id

1333−#endif

1334−

1335−type CanTrace x m = (HasSpiderTimeline x, MonadIO m)

1336

1374

1337{-# INLINE tracePropagate #-}

1375{-# INLINE tracePropagate #-}

1338tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()

1376tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()

1339−tracePropagate p = traceWhen p debugPropagate

1377+tracePropagate p = when debugPropagate . trace p

1340

1378

1341{-# INLINE traceInvalidate #-}

1379{-# INLINE traceInvalidate #-}

1342traceInvalidate :: String -> IO ()

1380traceInvalidate :: String -> IO ()

1343−traceInvalidate = when debugInvalidate . liftIO . putStrLn

1381+traceInvalidate = when debugInvalidate . liftIO . debugStrLn

1382+

1383+{-# INLINE traceInvalidateHeight #-}

1384+traceInvalidateHeight :: String -> IO ()

1385+traceInvalidateHeight = when debugInvalidateHeight . liftIO . debugStrLn

1344

1386

1345−{-# INLINE traceWhen #-}

1387+{-# INLINE trace #-}

1346−traceWhen :: (CanTrace x m) => proxy x -> Bool -> String -> m ()

1388+trace :: (CanTrace x m) => proxy x -> String -> m ()

1347−traceWhen p b message = traceMWhen p b $ return message

1389+trace p message = traceM p $ return message

1348

1390

1349−{-# INLINE traceMWhen #-}

1391+{-# INLINE traceM #-}

1350−traceMWhen :: (CanTrace x m) => proxy x -> Bool -> m String -> m ()

1392+traceM :: forall x proxy m. (CanTrace x m) => proxy x -> m String -> m ()

1351−traceMWhen _ b getMessage = when b $ do

1393+traceM _ getMessage = do

1352 message <- getMessage

1394 message <- getMessage

1353−#ifdef DEBUG

1354− spiderTimeline <- askSpiderTimelineEnv

1355− d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE spiderTimeline

1395+ d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)

1396+ liftIO $ debugStrLn $ replicate d ' ' <> message

1397+

1356#else

1398#else

1357− let d = 0

1399+

1400+{-# INLINE withIncreasedDepth #-}

1401+withIncreasedDepth :: proxy x -> m a -> m a

1402+withIncreasedDepth _ = id

1403+

1404+{-# INLINE tracePropagate #-}

1405+tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()

1406+tracePropagate _ _ = return ()

1407+

1408+{-# INLINE traceInvalidate #-}

1409+traceInvalidate :: String -> IO ()

1410+traceInvalidate _ = return ()

1411+

1412+{-# INLINE traceInvalidateHeight #-}

1413+traceInvalidateHeight :: String -> IO ()

1414+traceInvalidateHeight _ = return ()

1415+

1416+{-# INLINE debugSubscriber #-}

1417+debugSubscriber :: String -> Subscriber x a -> IO (Subscriber x a)

1418+debugSubscriber _ = return

1419+

1420+{-# INLINE debugSubscriber' #-}

1421+debugSubscriber' :: String -> Subscriber x a -> Subscriber x a

1422+debugSubscriber' _ = id

1423+

1424+

1425+

1426+{-# INLINE trace #-}

1427+trace :: (CanTrace x m) => proxy x -> String -> m ()

1428+trace _ _ = return ()

1429+

1430+{-# INLINE traceM #-}

1431+traceM :: (CanTrace x m) => proxy x -> m String -> m ()

1432+traceM _ _ = return ()

1433+

1358#endif

1434#endif

1359− liftIO $ putStrLn $ replicate d ' ' <> message

1360

1435

1361whoCreatedIORef :: IORef a -> IO [String]

1436whoCreatedIORef :: IORef a -> IO [String]

1362whoCreatedIORef (IORef a) = whoCreated $! a

1437whoCreatedIORef (IORef a) = whoCreated $! a

1363

1438

1364−#ifdef DEBUG_CYCLES

1365groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]

1439groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]

1366groupByHead = \case

1440groupByHead = \case

1367 [] -> []

1441 [] -> []

@@ -1372,20 +1446,54 @@ groupByHead = \case

1372 | otherwise -> (x, xs :| []) : l

1446 | otherwise -> (x, xs :| []) : l

1373

1447

1374listsToForest :: Eq a => [[a]] -> Forest a

1448listsToForest :: Eq a => [[a]] -> Forest a

1375−listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l

1449+listsToForest lists = buildForest <$> groupByHead (mapMaybe nonEmpty lists)

1450+ where buildForest (a, lists') = Node a $ listsToForest $ toList lists'

1451+

1452+showStacks :: [[String]] -> String

1453+showStacks = drawForest . listsToForest . fmap (filterStack "Reflex.Spider.Internal")

1454+

1455+filterStack :: String -> [String] -> [String]

1456+#ifdef DEBUG_HIDE_INTERNALS

1457+filterStack prefix = filter (not . (prefix `isPrefixOf`))

1458+#else

1459+filterStack prefix = id

1376#endif

1460#endif

1377

1461

1462+#ifdef DEBUG_CYCLES

1463+

1464+data EventLoopException = EventLoopException [[String]]

1465+instance Exception EventLoopException

1466+

1467+instance Show EventLoopException where

1468+ show (EventLoopException stacks) = "causality loop detected:\n" <> if null stacks

1469+ then "no location information, compile with profiling enabled for stack tree"

1470+ else showStacks stacks

1471+

1472+#else

1473+

1474+data EventLoopException = EventLoopException

1475+instance Exception EventLoopException

1476+

1477+instance Show EventLoopException where

1478+ show EventLoopException = "causality loop detected: \n" <>

1479+ "compile reflex with flag 'debug-cycles' and compile with profiling enabled for stack tree"

1480+

1481+#endif

1482+

1483+

1378{-# INLINE propagateSubscriberHold #-}

1484{-# INLINE propagateSubscriberHold #-}

1379propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()

1485propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()

1380propagateSubscriberHold h a = do

1486propagateSubscriberHold h a = do

1381− {-# SCC "trace" #-} traceMWhen (Proxy :: Proxy x) debugPropagate $ liftIO $ do

1487+ {-# SCC "trace" #-} when debugPropagate $ traceM (Proxy :: Proxy x) $ liftIO $ do

1382 invalidators <- liftIO $ readIORef $ holdInvalidators h

1488 invalidators <- liftIO $ readIORef $ holdInvalidators h

1383 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)

1489 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)

1490+

1384 v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h

1491 v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h

1385 case {-# SCC "apply" #-} apply a v of

1492 case {-# SCC "apply" #-} apply a v of

1386 Nothing -> return ()

1493 Nothing -> return ()

1387 Just v' -> do

1494 Just v' -> do

1495+ {-# SCC "trace2" #-} withIncreasedDepth (Proxy :: Proxy x) $

1388− {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate (Proxy :: Proxy x) $ "propagateSubscriberHold: assigning Hold" <> showNodeId h

1496+ tracePropagate (Proxy :: Proxy x) ("propagateSubscriberHold: assigning Hold" <> showNodeId h)

1389 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h

1497 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h

1390 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h

1498 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h

1391 defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'

1499 defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'

@@ -1439,7 +1547,7 @@ getDynHold d = do

1439zeroRef :: IORef Height

1547zeroRef :: IORef Height

1440zeroRef = unsafePerformIO $ newIORef zeroHeight

1548zeroRef = unsafePerformIO $ newIORef zeroHeight

1441

1549

1442−getRootSubscribed :: GCompare k => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)

1550+getRootSubscribed :: forall k x a. (GCompare k, HasSpiderTimeline x) => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)

1443getRootSubscribed k r sub = do

1551getRootSubscribed k r sub = do

1444 mSubscribed <- readIORef $ rootSubscribed r

1552 mSubscribed <- readIORef $ rootSubscribed r

1445 let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r

1553 let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r

@@ -1453,7 +1561,9 @@ getRootSubscribed k r sub = do

1453 let !cached = rootSubscribed r

1561 let !cached = rootSubscribed r

1454 uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"

1562 uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"

1455 (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed

1563 (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed

1564+

1456− when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"

1565+ tracePropagate (Proxy::Proxy x) $ "getRootSubscribed: calling rootInit"

1566+

1457 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)

1567 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)

1458 writeIORef uninitRef $! uninit

1568 writeIORef uninitRef $! uninit

1459#ifdef DEBUG_NODEIDS

1569#ifdef DEBUG_NODEIDS

@@ -1503,6 +1613,9 @@ data FanInt x a = FanInt

1503 { _fanInt_subscribers :: {-# UNPACK #-} !(FastMutableIntMap (FastWeakBag (Subscriber x a))) --TODO: Clean up the keys in here when their child weak bags get empty --TODO: Remove our own subscription when the subscribers list is completely empty

1613 { _fanInt_subscribers :: {-# UNPACK #-} !(FastMutableIntMap (FastWeakBag (Subscriber x a))) --TODO: Clean up the keys in here when their child weak bags get empty --TODO: Remove our own subscription when the subscribers list is completely empty

1504 , _fanInt_subscriptionRef :: {-# UNPACK #-} !(IORef (EventSubscription x)) -- This should have a valid subscription iff subscribers is non-empty

1614 , _fanInt_subscriptionRef :: {-# UNPACK #-} !(IORef (EventSubscription x)) -- This should have a valid subscription iff subscribers is non-empty

1505 , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a))

1615 , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a))

1616+#ifdef DEBUG_NODEIDS

1617+ , _fanInt_nodeId :: {-# UNPACK #-} !Int

1618+#endif

1506 }

1619 }

1507

1620

1508newFanInt :: IO (FanInt x a)

1621newFanInt :: IO (FanInt x a)

@@ -1510,10 +1623,16 @@ newFanInt = do

1510 subscribers <- FastMutableIntMap.newEmpty --TODO: Clean up the keys in here when their child weak bags get empty --TODO: Remove our own subscription when the subscribers list is completely empty

1623 subscribers <- FastMutableIntMap.newEmpty --TODO: Clean up the keys in here when their child weak bags get empty --TODO: Remove our own subscription when the subscribers list is completely empty

1511 subscriptionRef <- newIORef $ error "fanInt: no subscription"

1624 subscriptionRef <- newIORef $ error "fanInt: no subscription"

1512 occRef <- newIORef $ error "fanInt: no occurrence"

1625 occRef <- newIORef $ error "fanInt: no occurrence"

1626+#ifdef DEBUG_NODEIDS

1627+ nodeId <- newNodeId

1628+#endif

1513 return $ FanInt

1629 return $ FanInt

1514 { _fanInt_subscribers = subscribers

1630 { _fanInt_subscribers = subscribers

1515 , _fanInt_subscriptionRef = subscriptionRef

1631 , _fanInt_subscriptionRef = subscriptionRef

1516 , _fanInt_occRef = occRef

1632 , _fanInt_occRef = occRef

1633+#ifdef DEBUG_NODEIDS

1634+ , _fanInt_nodeId = nodeId

1635+#endif

1517 }

1636 }

1518

1637

1519fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a

1638fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a

@@ -1522,20 +1641,21 @@ fanInt p = unsafePerformIO $ do

1522 pure $ EventSelectorInt $ \k -> Event $ \sub -> do

1641 pure $ EventSelectorInt $ \k -> Event $ \sub -> do

1523 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)

1642 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)

1524 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input

1643 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input

1644+ let desc = "fanInt" <> showNodeId self <> ", k = " <> show k

1525− (subscription, parentOcc) <- subscribeAndRead p $ Subscriber

1645+ (subscription, parentOcc) <- subscribeAndRead p $ debugSubscriber' desc $ Subscriber

1526 { subscriberPropagate = \m -> do

1646 { subscriberPropagate = \m -> do

1527 liftIO $ writeIORef (_fanInt_occRef self) m

1647 liftIO $ writeIORef (_fanInt_occRef self) m

1528 scheduleIntClear $ _fanInt_occRef self

1648 scheduleIntClear $ _fanInt_occRef self

1529− FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> do --TODO: Do we need to know that no subscribers are being added as we traverse?

1649+ FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> --TODO: Do we need to know that no subscribers are being added as we traverse?

1530− FastWeakBag.traverse b $ \s -> do

1650+ FastWeakBag.traverse_ b $ \s ->

1531 subscriberPropagate s v

1651 subscriberPropagate s v

1532− , subscriberInvalidateHeight = \old -> do

1652+ , subscriberInvalidateHeight = \old ->

1533− FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do

1653+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->

1534− FastWeakBag.traverse b $ \s -> do

1654+ FastWeakBag.traverse_ b $ \s ->

1535 subscriberInvalidateHeight s old

1655 subscriberInvalidateHeight s old

1536− , subscriberRecalculateHeight = \new -> do

1656+ , subscriberRecalculateHeight = \new ->

1537− FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do

1657+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->

1538− FastWeakBag.traverse b $ \s -> do

1658+ FastWeakBag.traverse_ b $ \s ->

1539 subscriberRecalculateHeight s new

1659 subscriberRecalculateHeight s new

1540 }

1660 }

1541 liftIO $ do

1661 liftIO $ do

@@ -1549,10 +1669,25 @@ fanInt p = unsafePerformIO $ do

1549 FastMutableIntMap.insert (_fanInt_subscribers self) k b

1669 FastMutableIntMap.insert (_fanInt_subscribers self) k b

1550 return b

1670 return b

1551 Just b -> return b

1671 Just b -> return b

1552− t <- liftIO $ FastWeakBag.insert sub b

1672+ ticket <- liftIO $ FastWeakBag.insert sub b

1553 currentOcc <- readIORef (_fanInt_occRef self)

1673 currentOcc <- readIORef (_fanInt_occRef self)

1554− (EventSubscription _ (EventSubscribed !heightRef _)) <- readIORef (_fanInt_subscriptionRef self)

1674+

1675+ subscribed <- fanIntSubscribed ticket self

1555− return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)

1676+ return (EventSubscription (FastWeakBag.remove ticket) subscribed, IntMap.lookup k currentOcc)

1677+

1678+fanIntSubscribed :: FastWeakBagTicket k -> FanInt x a -> IO (EventSubscribed x)

1679+fanIntSubscribed ticket self = do

1680+ subscribedParent <- _eventSubscription_subscribed <$> readIORef (_fanInt_subscriptionRef self)

1681+ return $ EventSubscribed

1682+ { eventSubscribedHeightRef = eventSubscribedHeightRef subscribedParent

1683+ , eventSubscribedRetained = toAny (_fanInt_subscriptionRef self, ticket)

1684+#ifdef DEBUG_CYCLES

1685+ , eventSubscribedGetParents = return [subscribedParent]

1686+ , eventSubscribedHasOwnHeightRef = False

1687+ , eventSubscribedWhoCreated = whoCreatedIORef $ _fanInt_subscriptionRef self

1688+#endif

1689+ }

1690+

1556

1691

1557{-# INLINABLE getFanSubscribed #-}

1692{-# INLINABLE getFanSubscribed #-}

1558getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k v -> Subscriber x (v a) -> EventM x (WeakBagTicket, FanSubscribed x k v, Maybe (v a))

1693getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k v -> Subscriber x (v a) -> EventM x (WeakBagTicket, FanSubscribed x k v, Maybe (v a))

@@ -1750,7 +1885,7 @@ mergeCheap

1750 => (forall a. q a -> Event x (v a))

1885 => (forall a. q a -> Event x (v a))

1751 -> DynamicS x (PatchDMap k q)

1886 -> DynamicS x (PatchDMap k q)

1752 -> Event x (DMap k v)

1887 -> Event x (DMap k v)

1753−mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy

1888+mergeCheap nt = mergeGCheap' unMergeSubscribedParent getInitialSubscribers updateMe destroy

1754 where

1889 where

1755 updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)

1890 updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)

1756 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do

1891 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do

@@ -1765,7 +1900,9 @@ mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy

1765 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight

1900 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight

1766 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps

1901 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps

1767 forM_ mOldSubd $ \oldSubd -> do

1902 forM_ mOldSubd $ \oldSubd -> do

1903+ oldHeight <- liftIO $ getEventSubscribedHeight $

1768− oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd

1904+ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd

1905+

1769 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

1906 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

1770 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)

1907 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)

1771 foldM f ([], oldParents) $ DMap.toList p

1908 foldM f ([], oldParents) $ DMap.toList p

@@ -1790,7 +1927,7 @@ mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)

1790 => (forall a. q a -> Event x (v a))

1927 => (forall a. q a -> Event x (v a))

1791 -> DynamicS x (PatchDMapWithMove k q)

1928 -> DynamicS x (PatchDMapWithMove k q)

1792 -> Event x (DMap k v)

1929 -> Event x (DMap k v)

1793−mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy

1930+mergeCheapWithMove nt = mergeGCheap' _mergeSubscribedParentWithMove_subscription getInitialSubscribers updateMe destroy

1794 where

1931 where

1795 updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)

1932 updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)

1796 updateMe subscriber heightBagRef oldParents p = do

1933 updateMe subscriber heightBagRef oldParents p = do

@@ -1809,13 +1946,17 @@ mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy

1809 let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a

1946 let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a

1810 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of

1947 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of

1811 Nothing -> do

1948 Nothing -> do

1812− oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent

1949+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $

1950+ _mergeSubscribedParentWithMove_subscription parent

1951+

1813 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

1952 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

1814 return $ Just $ _mergeSubscribedParentWithMove_subscription parent

1953 return $ Just $ _mergeSubscribedParentWithMove_subscription parent

1815 Just toKey -> do

1954 Just toKey -> do

1816 liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey

1955 liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey

1817 return Nothing

1956 return Nothing

1957+ toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $

1818− toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents

1958+ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents

1959+

1819 return (toDelete, applyAlways p' oldParents)

1960 return (toDelete, applyAlways p' oldParents)

1820 getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)

1961 getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)

1821 getInitialSubscribers initialParents subscriber = do

1962 getInitialSubscribers initialParents subscriber = do

@@ -1840,6 +1981,8 @@ type MergeUpdateFunc k v x p s

1840 -> p

1981 -> p

1841 -> EventM x ([EventSubscription x], DMap k s)

1982 -> EventM x ([EventSubscription x], DMap k s)

1842

1983

1984+type MergeGetSubscription x s = forall a. s a -> EventSubscription x

1985+

1843type MergeInitFunc k v q x s

1986type MergeInitFunc k v q x s

1844 = DMap k q

1987 = DMap k q

1845 -> (forall a. EventM x (k a) -> Subscriber x (v a))

1988 -> (forall a. EventM x (k a) -> Subscriber x (v a))

@@ -1863,14 +2006,17 @@ invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_su

1863invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()

2006invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()

1864invalidateMergeHeight' heightRef sub = do

2007invalidateMergeHeight' heightRef sub = do

1865 oldHeight <- readIORef heightRef

2008 oldHeight <- readIORef heightRef

1866− when (oldHeight /= invalidHeight) $ do -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents

2009+ -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents

2010+ when (oldHeight /= invalidHeight) $ do

1867 writeIORef heightRef $! invalidHeight

2011 writeIORef heightRef $! invalidHeight

1868 subscriberInvalidateHeight sub oldHeight

2012 subscriberInvalidateHeight sub oldHeight

1869

2013

1870revalidateMergeHeight :: Merge x k v s -> IO ()

2014revalidateMergeHeight :: Merge x k v s -> IO ()

1871revalidateMergeHeight m = do

2015revalidateMergeHeight m = do

1872 currentHeight <- readIORef $ _merge_heightRef m

2016 currentHeight <- readIORef $ _merge_heightRef m

2017+

1873− when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check

2018+ -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check

2019+ when (currentHeight == invalidHeight) $ do

1874 heights <- readIORef $ _merge_heightBagRef m

2020 heights <- readIORef $ _merge_heightBagRef m

1875 parents <- readIORef $ _merge_parentsRef m

2021 parents <- readIORef $ _merge_parentsRef m

1876 -- When the number of heights in the bag reaches the number of parents, we should have a valid height

2022 -- When the number of heights in the bag reaches the number of parents, we should have a valid height

@@ -1878,7 +2024,7 @@ revalidateMergeHeight m = do

1878 LT -> return ()

2024 LT -> return ()

1879 EQ -> do

2025 EQ -> do

1880 let height = succHeight $ heightBagMax heights

2026 let height = succHeight $ heightBagMax heights

1881− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height

2027+ traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height

1882 writeIORef (_merge_heightRef m) $! height

2028 writeIORef (_merge_heightRef m) $! height

1883 subscriberRecalculateHeight (_merge_sub m) height

2029 subscriberRecalculateHeight (_merge_sub m) height

1884 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"

2030 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"

@@ -1886,36 +2032,45 @@ revalidateMergeHeight m = do

1886scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()

2032scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()

1887scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do

2033scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do

1888 vals <- liftIO $ readIORef $ _merge_accumRef m

2034 vals <- liftIO $ readIORef $ _merge_accumRef m

1889− 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

2035+ -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us,

2036+ -- it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers

2037+ liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty

1890 --TODO: Assert that m is not empty

2038 --TODO: Assert that m is not empty

1891 subscriberPropagate (_merge_sub m) vals

2039 subscriberPropagate (_merge_sub m) vals

1892

2040

2041+checkCycle :: HasSpiderTimeline x => EventSubscribed x -> EventM x ()

2042+checkCycle subscribed = liftIO $ do

2043+ height <- readIORef (eventSubscribedHeightRef subscribed)

2044+

2045+ -- currentHeight <- getCurrentHeight

2046+ -- when (height <= currentHeight) $ if height /= invalidHeight

2047+ -- then do

2048+ -- myStack <- liftIO $ whoCreatedIORef undefined --TODO

2049+ -- error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)

2050+ -- else liftIO $

2051+ when (height == invalidHeight) $

2052+#ifdef DEBUG_CYCLES

2053+ do

2054+ nodesInvolvedInCycle <- walkInvalidHeightParents subscribed

2055+ stacks <- forM nodesInvolvedInCycle whoCreatedEventSubscribed

2056+ throwIO (EventLoopException stacks)

2057+#else

2058+ throwIO EventLoopException

2059+#endif

2060+

2061+

1893−mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => Merge x k v s -> EventM x (k a) -> Subscriber x (v a)

2062+mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => EventSubscribed x -> Merge x k v s -> EventM x (k a) -> Subscriber x (v a)

1894−mergeSubscriber m getKey = Subscriber

2063+mergeSubscriber subscribed m getKey = Subscriber

1895 { subscriberPropagate = \a -> do

2064 { subscriberPropagate = \a -> do

1896 oldM <- liftIO $ readIORef $ _merge_accumRef m

2065 oldM <- liftIO $ readIORef $ _merge_accumRef m

1897 k <- getKey

2066 k <- getKey

1898− let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k a oldM

2067+ let newM = DMap.insertWith (error "Same key fired multiple times for Merge") k a oldM

1899 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)

2068 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)

1900 liftIO $ writeIORef (_merge_accumRef m) $! newM

2069 liftIO $ writeIORef (_merge_accumRef m) $! newM

1901 when (DMap.null oldM) $ do -- Only schedule the firing once

2070 when (DMap.null oldM) $ do -- Only schedule the firing once

1902 height <- liftIO $ readIORef $ _merge_heightRef m

2071 height <- liftIO $ readIORef $ _merge_heightRef m

1903− --TODO: assertions about height

2072+ checkCycle subscribed

1904− currentHeight <- getCurrentHeight

2073+

1905− when (height <= currentHeight) $ do

1906− if height /= invalidHeight

1907− then do

1908− myStack <- liftIO $ whoCreatedIORef undefined --TODO

1909− error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)

1910− else liftIO $ do

1911−#ifdef DEBUG_CYCLES

1912− nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed

1913− stacks <- forM nodesInvolvedInCycle $ \(Some es) -> whoCreatedEventSubscribed es

1914− let cycleInfo = ":\n" <> drawForest (listsToForest stacks)

1915−#else

1916− let cycleInfo = ""

1917−#endif

1918− error $ "Causality loop found" <> cycleInfo

1919 scheduleMergeSelf m height

2074 scheduleMergeSelf m height

1920 , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating

2075 , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating

1921 modifyIORef' (_merge_heightBagRef m) $ heightBagRemove old

2076 modifyIORef' (_merge_heightBagRef m) $ heightBagRemove old

@@ -1926,31 +2081,45 @@ mergeSubscriber m getKey = Subscriber

1926 }

2081 }

1927

2082

1928--TODO: Be able to run as much of this as possible promptly

2083--TODO: Be able to run as much of this as possible promptly

1929−updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x

2084+updateMerge :: (HasSpiderTimeline x, GCompare k) => EventSubscribed x -> Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x

1930−updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)

2085+updateMerge subscribed m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)

1931 where updateMe = do

2086 where updateMe = do

1932 oldParents <- liftIO $ readIORef $ _merge_parentsRef m

2087 oldParents <- liftIO $ readIORef $ _merge_parentsRef m

1933− (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber m) (_merge_heightBagRef m) oldParents p

2088+ (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber subscribed m) (_merge_heightBagRef m) oldParents p

1934 liftIO $ writeIORef (_merge_parentsRef m) $! newParents

2089 liftIO $ writeIORef (_merge_parentsRef m) $! newParents

1935 return subscriptionsToKill

2090 return subscriptionsToKill

1936

2091

1937{-# INLINE mergeGCheap' #-}

2092{-# INLINE mergeGCheap' #-}

1938mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)

2093mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)

1939− => MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> DynamicS x p -> Event x (DMap k v)

2094+ => MergeGetSubscription x s -> MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> DynamicS x p -> Event x (DMap k v)

1940−mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do

2095+mergeGCheap' getParent getInitialSubscribers updateFunc destroy d = Event $ \sub -> do

1941 initialParents <- readBehaviorUntracked $ dynamicCurrent d

2096 initialParents <- readBehaviorUntracked $ dynamicCurrent d

1942 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"

2097 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"

1943 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"

2098 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"

1944 heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"

2099 heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"

1945 parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"

2100 parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"

2101+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"

2102+

2103+ let subscribed = EventSubscribed

2104+ { eventSubscribedHeightRef = heightRef

2105+ , eventSubscribedRetained = toAny (parentsRef, changeSubdRef)

2106+#ifdef DEBUG_CYCLES

2107+ , eventSubscribedGetParents = do

2108+ let getParent' (_ :=> v) = _eventSubscription_subscribed (getParent v)

2109+ fmap getParent' . DMap.toList <$> readIORef parentsRef

2110+ , eventSubscribedHasOwnHeightRef = False

2111+ , eventSubscribedWhoCreated = whoCreatedIORef heightRef

2112+#endif

2113+ }

2114+

1946− let m = Merge

2115+ m = Merge

1947 { _merge_parentsRef = parentsRef

2116 { _merge_parentsRef = parentsRef

1948 , _merge_heightBagRef = heightBagRef

2117 , _merge_heightBagRef = heightBagRef

1949 , _merge_heightRef = heightRef

2118 , _merge_heightRef = heightRef

1950 , _merge_sub = sub

2119 , _merge_sub = sub

1951 , _merge_accumRef = accumRef

2120 , _merge_accumRef = accumRef

1952 }

2121 }

1953− (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber m

2122+ (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber subscribed m

1954 let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights

2123 let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights

1955 myHeight = if invalidHeight `elem` heights

2124 myHeight = if invalidHeight `elem` heights

1956 then invalidHeight

2125 then invalidHeight

@@ -1959,31 +2128,29 @@ mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do

1959 let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now

2128 let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now

1960 then (if DMap.null dm then Nothing else Just dm, DMap.empty)

2129 then (if DMap.null dm then Nothing else Just dm, DMap.empty)

1961 else (Nothing, dm)

2130 else (Nothing, dm)

1962− unless (DMap.null accum) $ do

1963− scheduleMergeSelf m myHeight

2131+ unless (DMap.null accum) $ scheduleMergeSelf m myHeight

1964 liftIO $ writeIORef accumRef $! accum

2132 liftIO $ writeIORef accumRef $! accum

1965 liftIO $ writeIORef heightRef $! myHeight

2133 liftIO $ writeIORef heightRef $! myHeight

1966 liftIO $ writeIORef heightBagRef $! myHeightBag

2134 liftIO $ writeIORef heightBagRef $! myHeightBag

1967− changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"

1968 liftIO $ writeIORef parentsRef $! initialParentState

2135 liftIO $ writeIORef parentsRef $! initialParentState

1969 defer $ SomeMergeInit $ do

2136 defer $ SomeMergeInit $ do

1970− let s = Subscriber

2137+ let changeSubscriber = Subscriber

1971 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

2138 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

1972− tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change"

2139+ tracePropagate (Proxy :: Proxy x) "SubscriberMerge/Change"

1973− defer $ updateMerge m updateFunc a

2140+ defer $ updateMerge subscribed m updateFunc a

1974 , subscriberInvalidateHeight = \_ -> return ()

2141 , subscriberInvalidateHeight = \_ -> return ()

1975 , subscriberRecalculateHeight = \_ -> return ()

2142 , subscriberRecalculateHeight = \_ -> return ()

1976 }

2143 }

1977− (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s

2144+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) changeSubscriber

1978− forM_ change $ \c -> defer $ updateMerge m updateFunc c

2145+ forM_ change $ \c -> defer $ updateMerge subscribed m updateFunc c

1979 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.

2146 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.

1980 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain

2147 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain

1981 -- its subscription.

2148 -- its subscription.

1982− liftIO $ writeIORef changeSubdRef (s, changeSubscription)

2149+ liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)

1983 let unsubscribeAll = destroy =<< readIORef parentsRef

2150 let unsubscribeAll = destroy =<< readIORef parentsRef

2151+

1984− return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parentsRef, changeSubdRef)

2152+ return (EventSubscription unsubscribeAll subscribed, occ)

1985− , occ

2153+

1986− )

1987

2154

1988mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)

2155mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)

1989mergeInt = cacheEvent . mergeIntCheap

2156mergeInt = cacheEvent . mergeIntCheap

@@ -1996,13 +2163,22 @@ mergeIntCheap d = Event $ \sub -> do

1996 heightRef <- liftIO $ newIORef zeroHeight

2163 heightRef <- liftIO $ newIORef zeroHeight

1997 heightBagRef <- liftIO $ newIORef heightBagEmpty

2164 heightBagRef <- liftIO $ newIORef heightBagEmpty

1998 parents <- liftIO $ FastMutableIntMap.newEmpty

2165 parents <- liftIO $ FastMutableIntMap.newEmpty

2166+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"

2167+ let subscribed = EventSubscribed

2168+ { eventSubscribedHeightRef = heightRef

2169+ , eventSubscribedRetained = toAny (parents, changeSubdRef)

2170+#ifdef DEBUG_CYCLES

2171+ , eventSubscribedGetParents = fmap (_eventSubscription_subscribed . snd) <$> FastMutableIntMap.toList parents

2172+ , eventSubscribedHasOwnHeightRef = False

2173+ , eventSubscribedWhoCreated = whoCreatedIORef heightRef

2174+#endif

2175+ }

1999 let scheduleSelf = do

2176 let scheduleSelf = do

2000 height <- liftIO $ readIORef $ heightRef

2177 height <- liftIO $ readIORef $ heightRef

2001 scheduleMerge' height heightRef $ do

2178 scheduleMerge' height heightRef $ do

2002 vals <- liftIO $ FastMutableIntMap.getFrozenAndClear accum

2179 vals <- liftIO $ FastMutableIntMap.getFrozenAndClear accum

2003 subscriberPropagate sub vals

2180 subscriberPropagate sub vals

2004− invalidateMyHeight = do

2005− invalidateMergeHeight' heightRef sub

2181+ invalidateMyHeight = invalidateMergeHeight' heightRef sub

2006 recalculateMyHeight = do

2182 recalculateMyHeight = do

2007 currentHeight <- readIORef heightRef

2183 currentHeight <- readIORef heightRef

2008 when (currentHeight == invalidHeight) $ do --TODO: This will almost always be true; can we get rid of this check and just proceed to the next one always?

2184 when (currentHeight == invalidHeight) $ do --TODO: This will almost always be true; can we get rid of this check and just proceed to the next one always?

@@ -2012,12 +2188,14 @@ mergeIntCheap d = Event $ \sub -> do

2012 LT -> return ()

2188 LT -> return ()

2013 EQ -> do

2189 EQ -> do

2014 let height = succHeight $ heightBagMax heights

2190 let height = succHeight $ heightBagMax heights

2015− when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height

2191+ traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height

2016 writeIORef heightRef $! height

2192 writeIORef heightRef $! height

2017 subscriberRecalculateHeight sub height

2193 subscriberRecalculateHeight sub height

2018 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"

2194 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"

2019 mySubscriber k = Subscriber

2195 mySubscriber k = Subscriber

2020 { subscriberPropagate = \a -> do

2196 { subscriberPropagate = \a -> do

2197+ checkCycle subscribed

2198+

2021 wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum

2199 wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum

2022 liftIO $ FastMutableIntMap.insert accum k a

2200 liftIO $ FastMutableIntMap.insert accum k a

2023 when wasEmpty scheduleSelf

2201 when wasEmpty scheduleSelf

@@ -2051,7 +2229,6 @@ mergeIntCheap d = Event $ \sub -> do

2051 else liftIO $ Just <$> FastMutableIntMap.getFrozenAndClear accum

2229 else liftIO $ Just <$> FastMutableIntMap.getFrozenAndClear accum

2052 else do when (not isEmpty) scheduleSelf -- We have things accumulated, but we shouldn't have fired them yet

2230 else do when (not isEmpty) scheduleSelf -- We have things accumulated, but we shouldn't have fired them yet

2053 return Nothing

2231 return Nothing

2054− changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"

2055 defer $ SomeMergeInit $ do

2232 defer $ SomeMergeInit $ do

2056 let updateMe a = SomeMergeUpdate u invalidateMyHeight recalculateMyHeight

2233 let updateMe a = SomeMergeUpdate u invalidateMyHeight recalculateMyHeight

2057 where

2234 where

@@ -2065,25 +2242,27 @@ mergeIntCheap d = Event $ \sub -> do

2065 oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions

2242 oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions

2066 liftIO $ for_ oldParents $ \oldParent -> do

2243 liftIO $ for_ oldParents $ \oldParent -> do

2067 oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent

2244 oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent

2245+

2246+ print ("updateMe", oldParentHeight)

2068 modifyIORef' heightBagRef $ heightBagRemove oldParentHeight

2247 modifyIORef' heightBagRef $ heightBagRemove oldParentHeight

2069 return $ IntMap.elems oldParents

2248 return $ IntMap.elems oldParents

2070− let s = Subscriber

2249+ let changeSubscriber = Subscriber

2071 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

2250 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

2072 tracePropagate (Proxy :: Proxy x) $ "SubscriberMergeInt/Change"

2251 tracePropagate (Proxy :: Proxy x) $ "SubscriberMergeInt/Change"

2073 defer $ updateMe a

2252 defer $ updateMe a

2074 , subscriberInvalidateHeight = \_ -> return ()

2253 , subscriberInvalidateHeight = \_ -> return ()

2075 , subscriberRecalculateHeight = \_ -> return ()

2254 , subscriberRecalculateHeight = \_ -> return ()

2076 }

2255 }

2077− (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s

2256+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) changeSubscriber

2078 forM_ change $ \c -> defer $ updateMe c

2257 forM_ change $ \c -> defer $ updateMe c

2079 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.

2258 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.

2080 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain

2259 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain

2081 -- its subscription.

2260 -- its subscription.

2082− liftIO $ writeIORef changeSubdRef (s, changeSubscription)

2261+ liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)

2083 let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents

2262 let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents

2263+

2264+

2084− return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parents, changeSubdRef)

2265+ return (EventSubscription unsubscribeAll subscribed, occ)

2085− , occ

2086− )

2087

2266

2088newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }

2267newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }

2089newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) }

2268newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) }

@@ -2166,19 +2345,19 @@ runFrame a = SpiderHost $ do

2166 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env

2345 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env

2167 forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do

2346 forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do

2168 writeIORef vRef v

2347 writeIORef vRef v

2169− when debugInvalidate $ putStrLn $ "Invalidating Hold"

2348+ traceInvalidate $ "Invalidating Hold"

2170 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef

2349 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef

2171 mergeUpdates <- readIORef $ eventEnvMergeUpdates env

2350 mergeUpdates <- readIORef $ eventEnvMergeUpdates env

2172 writeIORef (eventEnvMergeUpdates env) []

2351 writeIORef (eventEnvMergeUpdates env) []

2173− when debugPropagate $ putStrLn "Updating merges"

2352+ tracePropagate (Proxy::Proxy x) $ "Updating merges"

2174 mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates

2353 mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates

2175− when debugPropagate $ putStrLn "Updating merges done"

2354+ tracePropagate (Proxy::Proxy x) $ "Updating merges done"

2176 toReconnect <- readIORef toReconnectRef

2355 toReconnect <- readIORef toReconnectRef

2177 clearEventEnv env

2356 clearEventEnv env

2178 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do

2357 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do

2179 oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed

2358 oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed

2180 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed

2359 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed

2181− when debugInvalidate $ putStrLn $ "Finalizing invalidator for Switch" <> showNodeId subscribed

2360+ traceInvalidate $ "Finalizing invalidator for Switch" <> showNodeId subscribed

2182 finalize wi

2361 finalize wi

2183 i <- evaluate $ switchSubscribedOwnInvalidator subscribed

2362 i <- evaluate $ switchSubscribedOwnInvalidator subscribed

2184 wi' <- mkWeakPtrWithDebug i "wi'"

2363 wi' <- mkWeakPtrWithDebug i "wi'"

@@ -2192,7 +2371,7 @@ runFrame a = SpiderHost $ do

2192 subscription <- unSpiderHost $ runFrame $ {-# SCC "subscribeSwitch" #-} subscribe e sub --TODO: Assert that the event isn't firing --TODO: This should not loop because none of the events should be firing, but still, it is inefficient

2371 subscription <- unSpiderHost $ runFrame $ {-# SCC "subscribeSwitch" #-} subscribe e sub --TODO: Assert that the event isn't firing --TODO: This should not loop because none of the events should be firing, but still, it is inefficient

2193 {-

2372 {-

2194 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)

2373 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)

2195− liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of

2374+ liftIO $ debugStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of

2196 EventRoot _ -> "EventRoot"

2375 EventRoot _ -> "EventRoot"

2197 EventNever -> "EventNever"

2376 EventNever -> "EventNever"

2198 _ -> "something else"

2377 _ -> "something else"

@@ -2207,7 +2386,7 @@ runFrame a = SpiderHost $ do

2207 myHeight <- readIORef $ switchSubscribedHeight subscribed

2386 myHeight <- readIORef $ switchSubscribedHeight subscribed

2208 when (parentHeight /= myHeight) $ do

2387 when (parentHeight /= myHeight) $ do

2209 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight

2388 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight

2210− WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight

2389+ WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight

2211 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

2390 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 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do

2391 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do

2213 unsubscribe subscription

2392 unsubscribe subscription

@@ -2248,7 +2427,7 @@ invalidateCoincidenceHeight subscribed = do

2248 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed

2427 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed

2249 when (oldHeight /= invalidHeight) $ do

2428 when (oldHeight /= invalidHeight) $ do

2250 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight

2429 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight

2251− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

2430+ WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

2252

2431

2253updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()

2432updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()

2254updateSwitchHeight new subscribed = do

2433updateSwitchHeight new subscribed = do

@@ -2256,7 +2435,7 @@ updateSwitchHeight new subscribed = do

2256 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion

2435 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion

2257 when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion

2436 when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion

2258 writeIORef (switchSubscribedHeight subscribed) $! new

2437 writeIORef (switchSubscribedHeight subscribed) $! new

2259− WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new

2438+ WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new

2260

2439

2261recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()

2440recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()

2262recalculateCoincidenceHeight subscribed = do

2441recalculateCoincidenceHeight subscribed = do

@@ -2265,7 +2444,7 @@ recalculateCoincidenceHeight subscribed = do

2265 height <- calculateCoincidenceHeight subscribed

2444 height <- calculateCoincidenceHeight subscribed

2266 when (height /= invalidHeight) $ do

2445 when (height /= invalidHeight) $ do

2267 writeIORef (coincidenceSubscribedHeight subscribed) $! height

2446 writeIORef (coincidenceSubscribedHeight subscribed) $! height

2268− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height

2447+ WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height

2269

2448

2270calculateSwitchHeight :: SwitchSubscribed x a -> IO Height

2449calculateSwitchHeight :: SwitchSubscribed x a -> IO Height

2271calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)

2450calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)

@@ -2356,8 +2535,10 @@ instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x))

2356 x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x

2535 x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x

2357 {-# INLINE (>>) #-}

2536 {-# INLINE (>>) #-}

2358 (>>) = (*>)

2537 (>>) = (*>)

2538+#if !MIN_VERSION_base(4,13,0)

2359 {-# INLINE fail #-}

2539 {-# INLINE fail #-}

2360 fail _ = error "Dynamic does not support 'fail'"

2540 fail _ = error "Dynamic does not support 'fail'"

2541+#endif

2361

2542

2362{-# INLINABLE newJoinDyn #-}

2543{-# INLINABLE newJoinDyn #-}

2363newJoinDyn :: HasSpiderTimeline x => DynamicS x (Identity (DynamicS x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)

2544newJoinDyn :: HasSpiderTimeline x => DynamicS x (Identity (DynamicS x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)

@@ -2482,13 +2663,13 @@ instance HasSpiderTimeline x => Reflex.Host.Class.MonadReadEvent (SpiderTimeline

2482 touch h

2663 touch h

2483 return result

2664 return result

2484

2665

2485−instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where

2666+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where

2486 newEventWithTrigger = SpiderHost . fmap SpiderEvent . newEventWithTriggerIO

2667 newEventWithTrigger = SpiderHost . fmap SpiderEvent . newEventWithTriggerIO

2487 newFanEventWithTrigger f = SpiderHost $ do

2668 newFanEventWithTrigger f = SpiderHost $ do

2488 es <- newFanEventWithTriggerIO f

2669 es <- newFanEventWithTriggerIO f

2489 return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es

2670 return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es

2490

2671

2491−instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where

2672+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where

2492 newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO

2673 newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO

2493 newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do

2674 newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do

2494 es <- newFanEventWithTriggerIO f

2675 es <- newFanEventWithTriggerIO f

@@ -2636,8 +2817,14 @@ instance Monad (SpiderHost x) where

2636 SpiderHost x >> SpiderHost y = SpiderHost $ x >> y

2817 SpiderHost x >> SpiderHost y = SpiderHost $ x >> y

2637 {-# INLINABLE return #-}

2818 {-# INLINABLE return #-}

2638 return x = SpiderHost $ return x

2819 return x = SpiderHost $ return x

2820+#if !MIN_VERSION_base(4,13,0)

2821+ {-# INLINABLE fail #-}

2822+ fail = MonadFail.fail

2823+#endif

2824+

2825+instance MonadFail (SpiderHost x) where

2639 {-# INLINABLE fail #-}

2826 {-# INLINABLE fail #-}

2640− fail s = SpiderHost $ fail s

2827+ fail s = SpiderHost $ MonadFail.fail s

2641

2828

2642-- | Run an action affecting the global Spider timeline; this will be guarded by

2829-- | Run an action affecting the global Spider timeline; this will be guarded by

2643-- a mutex for that timeline

2830-- a mutex for that timeline

@@ -2659,19 +2846,21 @@ instance Monad (SpiderHostFrame x) where

2659 SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y

2846 SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y

2660 {-# INLINABLE return #-}

2847 {-# INLINABLE return #-}

2661 return x = SpiderHostFrame $ return x

2848 return x = SpiderHostFrame $ return x

2849+#if !MIN_VERSION_base(4,13,0)

2662 {-# INLINABLE fail #-}

2850 {-# INLINABLE fail #-}

2663 fail s = SpiderHostFrame $ fail s

2851 fail s = SpiderHostFrame $ fail s

2852+#endif

2664

2853

2665instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where

2854instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where

2666 notReadyUntil _ = pure ()

2855 notReadyUntil _ = pure ()

2667 notReady = pure ()

2856 notReady = pure ()

2668

2857

2669−newEventWithTriggerIO :: (RootTrigger x a -> IO (IO ())) -> IO (Event x a)

2858+newEventWithTriggerIO :: forall x a. HasSpiderTimeline x => (RootTrigger x a -> IO (IO ())) -> IO (Event x a)

2670newEventWithTriggerIO f = do

2859newEventWithTriggerIO f = do

2671 es <- newFanEventWithTriggerIO $ \Refl -> f

2860 es <- newFanEventWithTriggerIO $ \Refl -> f

2672 return $ select es Refl

2861 return $ select es Refl

2673

2862

2674−newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)

2863+newFanEventWithTriggerIO :: (HasSpiderTimeline x, GCompare k) => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)

2675newFanEventWithTriggerIO f = do

2864newFanEventWithTriggerIO f = do

2676 occRef <- newIORef DMap.empty

2865 occRef <- newIORef DMap.empty

2677 subscribedRef <- newIORef DMap.empty

2866 subscribedRef <- newIORef DMap.empty

@@ -2705,3 +2894,11 @@ instance MonadAtomicRef (SpiderHostFrame x) where

2705instance PrimMonad (SpiderHostFrame x) where

2894instance PrimMonad (SpiderHostFrame x) where

2706 type PrimState (SpiderHostFrame x) = PrimState IO

2895 type PrimState (SpiderHostFrame x) = PrimState IO

2707 primitive = SpiderHostFrame . EventM . primitive

2896 primitive = SpiderHostFrame . EventM . primitive

2897+

2898+instance NotReady (SpiderTimeline x) (SpiderHost x) where

2899+ notReadyUntil _ = return ()

2900+ notReady = return ()

2901+

2902+instance HasSpiderTimeline x => NotReady (SpiderTimeline x) (PerformEventT (SpiderTimeline x) (SpiderHost x)) where

2903+ notReadyUntil _ = return ()

2904+ notReady = return ()

src/Reflex/Widget/Basic.hs+1−1

@@ -13,7 +13,7 @@ import Data.Map (Map)

14import Reflex.Class

15import Reflex.Adjustable.Class

16−import Reflex.Patch.MapWithMove

16+import Data.Patch.MapWithMove

19-- | Build sortable content in such a way that re-sorting it can cause minimal

src/Reflex/Workflow.hs+1−1

@@ -34,7 +34,7 @@ workflow w0 = do

34 rec eResult <- networkHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult

35 return $ fmap fst eResult

37−-- | Similar to 'workflow', but outputs an 'Event' that fires whenever the current 'Workflow' is replaced by the next 'Workflow'.

37+-- | Similar to 'workflow', but outputs an 'Event' that fires at post-build time and whenever the current 'Workflow' is replaced by the next 'Workflow'.

38workflowView :: forall t m a. (Reflex t, NotReady t m, Adjustable t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a)

39workflowView w0 = do

40 rec eResult <- networkView . fmap unWorkflow =<< holdDyn w0 eReplace

test/Adjustable.hsnew file+62

@@ -0,0 +1,62 @@

1+{-# LANGUAGE BangPatterns #-}

2+{-# LANGUAGE LambdaCase #-}

3+{-# LANGUAGE RankNTypes #-}

4+{-# LANGUAGE RecursiveDo #-}

6+module Main where

8+import Control.Monad.Fix

9+import Data.Maybe

10+import qualified Data.Map as Map

11+

12+import Reflex

13+import Reflex.EventWriter.Base

14+import Reflex.Network

15+import Reflex.Patch.MapWithMove

16+import Test.Run

17+

18+main :: IO ()

19+main = do

20+ let actions = [ Increment, Update0th, Increment, Swap, Increment, Increment ]

21+ os <- runAppB testPatchMapWithMove $ map Just actions

22+ -- If the final counter value in the adjusted widgets corresponds to the number of times it has

23+ -- been incremented, we know that the networks haven't broken.

24+ let expectedCount = length $ ffilter (== Increment) actions

25+ -- let !True = last (last os) == [expectedCount,expectedCount] -- TODO re-enable this test after issue #369 has been resolved

26+ return ()

27+

28+data PatchMapTestAction

29+ = Increment

30+ | Swap

31+ | Update0th

32+ deriving Eq

33+

34+-- See https://github.com/reflex-frp/reflex/issues/369 for the bug that this is testing.

35+testPatchMapWithMove

36+ :: forall t m

37+ . ( Reflex t

38+ , Adjustable t m

39+ , MonadHold t m

40+ , MonadFix m

41+ )

42+ => Event t PatchMapTestAction

43+ -> m (Behavior t [Int])

44+testPatchMapWithMove pulse = do

45+ let pulseAction = ffor pulse $ \case

46+ Increment -> Nothing

47+ Swap -> patchMapWithMove $ Map.fromList

48+ [ (0, NodeInfo (From_Move 1) (Just 1))

49+ , (1, NodeInfo (From_Move 0) (Just 0))

50+ ]

51+ Update0th -> patchMapWithMove $ Map.fromList

52+ [ (0, NodeInfo (From_Insert 'z') Nothing) ]

53+ (_, result) <- runBehaviorWriterT $ mdo

54+ counter <- foldDyn (+) 1 $ fmapMaybe (\e -> if isNothing e then Just 1 else Nothing) pulseAction

55+ _ <- mapMapWithAdjustWithMove

56+ (\_ _ -> networkHold

57+ (tellBehavior $ constant [])

58+ ((\t -> tellBehavior $ constant [t]) <$> updated counter))

59+ (Map.fromList $ zip [0..] "ab")

60+ (fmapMaybe id pulseAction)

61+ return ()

62+ return result

test/DebugCycles.hsnew file+171

@@ -0,0 +1,171 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ConstraintKinds #-}

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE GADTs #-}

5+{-# LANGUAGE RecursiveDo #-}

6+{-# LANGUAGE ScopedTypeVariables #-}

7+{-# LANGUAGE PatternSynonyms #-}

8+{-# LANGUAGE RankNTypes #-}

10+module Main where

11+

12+import Data.Foldable

13+import Control.Lens

14+import Control.Applicative

15+import Control.Monad

16+import Control.Monad.Fix

17+import Control.Exception

18+import System.Timeout

19+import Data.Maybe (isJust)

20+import Data.Functor.Misc

21+import qualified Data.Map as Map

22+import Data.Map (Map)

23+import qualified Data.IntMap as IntMap

24+import Data.IntMap (IntMap)

25+import Data.These

26+import Data.Align

27+import Reflex

28+import Reflex.EventWriter.Base

29+import Test.Run

30+import Test.Hspec

31+import Reflex.Spider.Internal (EventLoopException)

32+import Data.Witherable (Filterable)

33+

34+#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))

35+import Data.These.Lens

36+#endif

37+

38+type Widget t m = (MonadHold t m, Reflex t, MonadFix m)

39+

40+connectDyn :: Widget t m => Event t () -> (Dynamic t a, Dynamic t a) -> m (Dynamic t a)

41+connectDyn e (d, d') = do

42+ dd <- holdDyn d (d' <$ e)

43+ return $ join dd

44+

45+dynLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

46+dynLoop (e1, e2) = do

47+ -- "heightBagRemove: Height 2 not present in bag HeightBag {_heightBag_size = 2, _heightBag_contents = fromList [(0,1)]}"

48+ rec

49+ d <- count e1

50+ d' <- connectDyn e2 (d, liftA2 (+) d d')

51+ return $ updated d'

52+

53+connectOnCoincidence :: Widget t m => Event t () -> Event t a -> m (Event t a)

54+connectOnCoincidence click e = do

55+ d <- holdDyn never (e <$ click)

56+ return $ coincidence (updated d)

57+

58+coincidenceLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

59+coincidenceLoop (e1, e2) = do

60+-- "heightBagRemove: Height 1 not present in bag HeightBag {_heightBag_size = 1, _heightBag_contents = fromList [(0,0)]}"

61+-- (simpler version of dynLoop)

62+ rec

63+ e' <- connectOnCoincidence e2 (updated d)

64+ d <- count (align e' e1)

65+ return $ updated d

66+

67+addHeight :: Reflex t => Event t a -> Event t a

68+addHeight e = leftmost [e4, e4] where

69+ e1 = leftmost [e, e]

70+ e2 = leftmost [e1, e1]

71+ e3 = leftmost [e2, e2]

72+ e4 = leftmost [e3, e3]

73+

74+-- Take an existing test and build it inside a

75+buildLoop :: Widget t m => (forall t m. Widget t m => (Event t Int, Event t ()) -> m (Event t Int)) -> (Event t Int, Event t ()) -> m (Event t Int)

76+buildLoop test (e1, e2) = switchHold never buildLoop

77+ where buildLoop = pushAlways (const $ test (e1, e2)) e2

78+

79+connectButtonPromptly :: Widget t m => Event t () -> Event t a -> m (Event t a)

80+connectButtonPromptly click e = do

81+ d <- holdDyn never (e <$ click)

82+ return (switchDyn d)

83+

84+connectButton :: Widget t m => Event t () -> Event t a -> m (Event t a)

85+connectButton click e = do

86+ d <- hold never (e <$ click)

87+ return (switch d)

88+

89+switchLoop01 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

90+switchLoop01 (e1, e2) = do

91+ rec

92+ e' <- connectButton e2 (updated d)

93+ d <- count (align e' e1)

94+ return $ updated d

95+

96+mergeLoop :: forall t m. (Adjustable t m, Widget t m) => (Event t Int, Event t ()) -> m (Event t Int)

97+mergeLoop (e1, e2) = do

98+ rec

99+ (_, e) <- runEventWriterT $

100+ runWithReplace w (leftmost [w <$ e1])

101+ return (sum <$> e)

102+ where

103+ w = do

104+ c <- count e1

105+ tellEvent (updated ((pure <$> c) :: Dynamic t [Int]))

106+

107+switchLoop02 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

108+switchLoop02 (e1, e2) = do

109+ rec

110+ e' <- connectButton e2 (updated d)

111+ d <- count (leftmost [e', e1])

112+ return $ updated d

113+

114+switchLoop03 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

115+switchLoop03 (e1, e2) = do

116+ rec

117+ e' <- connectButton e2 (addHeight $ updated d)

118+ d <- count (align e' e1)

119+ return $ updated d

120+

121+staticLoop01 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

122+staticLoop01 (e1, e2) = do

123+ rec

124+ d <- foldDyn (+) (0 :: Int) (1 <$ align e1 (updated d))

125+ return $ updated d

126+

127+staticLoop02 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

128+staticLoop02 (e1, e2) = do

129+ rec

130+ d <- foldDyn (+) (0 :: Int) (leftmost [e1, updated d])

131+ return $ updated d

132+

133+buildStaticLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

134+buildStaticLoop (e1, e2) = switchHold never buildLoop

135+ where buildLoop = pushAlways (const $ staticLoop01 (e1, e2)) e2

136+

137+splitThese :: Filterable f => f (These a b) -> (f a, f b)

138+splitThese f = (mapMaybe (preview here) f, mapMaybe (preview there) f)

139+

140+main :: IO ()

141+main = hspec $ do

142+ describe "DebugCycles" $ do

143+ it "throws EventLoopException on switchLoop01" $ do

144+ check switchLoop01

145+ it "throws EventLoopException on switchLoop02" $ do

146+ check switchLoop02

147+ it "throws EventLoopException on switchLoop03" $ do

148+ check switchLoop03

149+ it "throws EventLoopException on buildSwitchLoop" $ do

150+ check $ buildLoop switchLoop01

151+ xit "throws EventLoopException on mergeLoop" $ do

152+ check mergeLoop

153+ xit "throws EventLoopException on staticLoop01" $ do

154+ check staticLoop01

155+ xit "throws EventLoopException on staticLoop02" $ do

156+ check staticLoop02

157+ xit "throws EventLoopException on buildStaticLoop" $ do

158+ check buildStaticLoop

159+ xit "throws EventLoopException on coincidenceLoop" $ do

160+ check coincidenceLoop

161+ xit "throws EventLoopException on dynLoop" $ do

162+ check dynLoop

163+ xit "throws EventLoopException on buildCoincidenceLoop" $ do

164+ check $ buildLoop coincidenceLoop

165+ where

166+ milliseconds = (*1000)

167+ occs = [ This 1, This 2, That (), This 3, That (), This 1 ]

168+ check test = do

169+ let action = timeout (milliseconds 50) $ do

170+ runApp' (test . splitThese) (Just <$> occs)

171+ action `shouldThrow` (const True :: Selector EventLoopException)

test/GC.hs+1−2

@@ -20,7 +20,7 @@ import Data.Semigroup

20import Data.These

22import Data.Functor.Misc

23−import Reflex.Patch

23+import Data.Patch

25import qualified Reflex.Host.Class as Host

26import qualified Reflex.Spider.Internal as S

@@ -83,7 +83,6 @@ hostPerf ref = S.runSpiderHost $ do

83 Nothing -> []

84 Host.fireEventsAndRead followupEventTriggers $ return ()

85 return ()

86− return ()

88data Tell a where

87data Tell a where

89 Action :: Tell ()

88 Action :: Tell ()

test/QueryT.hs+1−1

@@ -24,7 +24,7 @@ import Data.These.Lens

24#endif

26import Reflex

27−import Reflex.Patch.MapWithMove

27+import Data.Patch.MapWithMove

28import Test.Run

30newtype MyQuery = MyQuery SelectedCount

test/Reflex/Bench/Focused.hs+1−1

@@ -134,7 +134,7 @@ holdDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynami

134holdDynChain = iterM (\d -> sample (current d) >>= flip holdDyn (updated d))

135

136buildDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

137−buildDynChain = iterM (\d -> do

137+buildDynChain = iterM (\d -> do

138 let b = fmap (+1) (current d)

139 e = fmap (*2) (updated d)

140 buildDynamic (sample b) e)

test/Reflex/Test/CrossImpl.hs+12−7

@@ -21,6 +21,7 @@ import Reflex.Dynamic

21import Reflex.Host.Class

22import qualified Reflex.Pure as P

23import qualified Reflex.Spider.Internal as S

24+import qualified Reflex.Profiled as Prof

25import Control.Arrow (second, (&&&))

26import Control.Arrow (second, (&&&))

26import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

27import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

@@ -35,8 +36,6 @@ import Data.Traversable

35import System.Exit

36import System.Exit

36import System.Mem

37import System.Mem

38−import System.IO.Unsafe

39−

40mapToPureBehavior :: Map Int a -> Behavior PureReflexDomain a

39mapToPureBehavior :: Map Int a -> Behavior PureReflexDomain a

41mapToPureBehavior m = P.Behavior $ \t -> case Map.lookupLE t m of

40mapToPureBehavior m = P.Behavior $ \t -> case Map.lookupLE t m of

42 Nothing -> error $ "mapToPureBehavior: no value for time " <> show t

41 Nothing -> error $ "mapToPureBehavior: no value for time " <> show t

@@ -73,11 +72,14 @@ instance MapMSignals (Event t a) (Event t' a) t t' where

73instance (MapMSignals a a' t t', MapMSignals b b' t t') => MapMSignals (a, b) (a', b') t t' where

72instance (MapMSignals a a' t t', MapMSignals b b' t t') => MapMSignals (a, b) (a', b') t t' where

74 mapMSignals fb fe (a, b) = liftM2 (,) (mapMSignals fb fe a) (mapMSignals fb fe b)

73 mapMSignals fb fe (a, b) = liftM2 (,) (mapMSignals fb fe a) (mapMSignals fb fe b)

75+testTimeline

76−testSpider :: (forall m t. TestCaseConstraint t m => (Behavior t a, Event t b) -> m (Behavior t c, Event t d)) -> (Map Int a, Map Int b) -> (Map Int c, Map Int d)

76+ :: (forall m t. TestCaseConstraint t m => (Behavior t a, Event t b) -> m (Behavior t c, Event t d))

77+ -> (Map Int a, Map Int b)

78+ -> (forall m t. (MonadReflexHost t m, MonadIO m, MonadRef m, Ref m ~ Ref IO, MonadSample t m) => m (Map Int c, Map Int d))

77−testSpider builder (bMap, eMap) = unsafePerformIO $ S.runSpiderHost $ do

79+testTimeline builder (bMap, eMap) = do

78 (re, reTrigger) <- newEventWithTriggerRef

80 (re, reTrigger) <- newEventWithTriggerRef

79 (rb, rbTrigger) <- newEventWithTriggerRef

81 (rb, rbTrigger) <- newEventWithTriggerRef

80− b <- runHostFrame $ hold (error "testSpider: No value for input behavior yet") rb

82+ b <- runHostFrame $ hold (error "testTimeline: No value for input behavior yet") rb

81 (b', e') <- runHostFrame $ builder (b, re)

83 (b', e') <- runHostFrame $ builder (b, re)

82 e'Handle <- subscribeEvent e' --TODO: This should be unnecessary

84 e'Handle <- subscribeEvent e' --TODO: This should be unnecessary

83 let times = relevantTestingTimes (bMap, eMap)

85 let times = relevantTestingTimes (bMap, eMap)

@@ -102,9 +104,11 @@ testAgreement :: (Eq c, Eq d, Show c, Show d) => (forall m t. TestCaseConstraint

102testAgreement builder inputs = do

104testAgreement builder inputs = do

103 let identityResult = testPure builder inputs

105 let identityResult = testPure builder inputs

104 tracePerf "---------" $ return ()

106 tracePerf "---------" $ return ()

105− let spiderResult = testSpider builder inputs

107+ spiderResult <- S.runSpiderHost $ testTimeline builder inputs

108+ tracePerf "---------" $ return ()

109+ profiledResult <- S.runSpiderHost $ Prof.runProfiledM $ testTimeline builder inputs

106 tracePerf "---------" $ return ()

110 tracePerf "---------" $ return ()

107− let resultsAgree = identityResult == spiderResult

111+ let resultsAgree = identityResult == spiderResult && identityResult == profiledResult

108 if resultsAgree

112 if resultsAgree

109 then do --putStrLn "Success:"

113 then do --putStrLn "Success:"

110 --print identityResult

114 --print identityResult

@@ -112,6 +116,7 @@ testAgreement builder inputs = do

112 else do putStrLn "Failure:"

116 else do putStrLn "Failure:"

113 putStrLn $ "Pure result: " <> show identityResult

117 putStrLn $ "Pure result: " <> show identityResult

114 putStrLn $ "Spider result: " <> show spiderResult

118 putStrLn $ "Spider result: " <> show spiderResult

119+ putStrLn $ "Profiled result: " <> show profiledResult

115 return resultsAgree

120 return resultsAgree

116

121

117type TestCaseConstraint t m = (Reflex t, MonadSample t m, MonadHold t m, MonadFix m, MonadFix (PushM t))

122type TestCaseConstraint t m = (Reflex t, MonadSample t m, MonadHold t m, MonadFix m, MonadFix (PushM t))

test/RequesterT.hs+63−2

@@ -1,20 +1,36 @@

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE BangPatterns #-}

3{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE GADTs #-}

5{-# LANGUAGE GADTs #-}

5−{-# LANGUAGE RankNTypes #-}

6+{-# LANGUAGE LambdaCase #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE RecursiveDo #-}

8{-# LANGUAGE RecursiveDo #-}

7{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE TemplateHaskell #-}

11+{-# LANGUAGE TypeApplications #-}

12+{-# LANGUAGE TypeFamilies #-}

8module Main where

13module Main where

10−import Control.Lens

15+import Control.Lens hiding (has)

11import Control.Monad

16import Control.Monad

12import Control.Monad.Fix

17import Control.Monad.Fix

18+import Control.Monad.IO.Class (MonadIO)

19+import Data.Constraint.Extras

20+import Data.Constraint.Extras.TH

21+import Data.Constraint.Forall

13import qualified Data.Dependent.Map as DMap

22import qualified Data.Dependent.Map as DMap

14import Data.Dependent.Sum

23import Data.Dependent.Sum

15import Data.Functor.Misc

24import Data.Functor.Misc

25+import Data.List (words)

26+import Data.Map (Map)

16import qualified Data.Map as M

27import qualified Data.Map as M

28+#if !MIN_VERSION_these(4,11,0)

29+import Data.Semigroup ((<>))

30+#endif

31+import Data.Text (Text)

17import Data.These

32import Data.These

33+import Text.Read (readMaybe)

19#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))

35#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))

20import Data.These.Lens

36import Data.These.Lens

@@ -49,12 +65,19 @@ main = do

49 print os5

65 print os5

50 os6 <- runApp' (unwrapApp delayedPulse) [Just ()]

66 os6 <- runApp' (unwrapApp delayedPulse) [Just ()]

51 print os6

67 print os6

68+ os7 <- runApp' testMatchRequestsWithResponses [ Just $ TestRequest_Increment 1 ]

69+ print os7

70+ os8 <- runApp' testMatchRequestsWithResponses [ Just $ TestRequest_Reverse "yoyo" ]

71+ print os8

52 let ![[Just [1,2,3,4,5,6,7,8,9,10]]] = os1 -- The order is reversed here: see the documentation for 'runRequesterT'

72 let ![[Just [1,2,3,4,5,6,7,8,9,10]]] = os1 -- The order is reversed here: see the documentation for 'runRequesterT'

53 let ![[Just [9,7,5,3,1]],[Nothing,Nothing],[Just [10,8,6,4,2]],[Just [10,8,6,4,2],Nothing]] = os2

73 let ![[Just [9,7,5,3,1]],[Nothing,Nothing],[Just [10,8,6,4,2]],[Just [10,8,6,4,2],Nothing]] = os2

54 let ![[Nothing, Just [2]]] = os3

74 let ![[Nothing, Just [2]]] = os3

55 let ![[Nothing, Just [2]]] = os4

75 let ![[Nothing, Just [2]]] = os4

56 let ![[Nothing, Just [1, 2]]] = os5

76 let ![[Nothing, Just [1, 2]]] = os5

57 -- let ![[Nothing, Nothing]] = os6 -- TODO re-enable this test after issue #233 has been resolved

77 -- let ![[Nothing, Nothing]] = os6 -- TODO re-enable this test after issue #233 has been resolved

78+ let !(Just [(1,"2")]) = M.toList <$> head (head os7)

79+ let !(Just [(1,"oyoy")]) = M.toList <$> head (head os8)

80+

58 return ()

81 return ()

60unwrapRequest :: DSum tag RequestInt -> Int

83unwrapRequest :: DSum tag RequestInt -> Int

@@ -172,3 +195,41 @@ delayedPulse pulse = void $ flip runWithReplace (pure () <$ pulse) $ do

172 -- This has the effect of delaying pulse' from pulse

195 -- This has the effect of delaying pulse' from pulse

173 (_, pulse') <- runWithReplace (pure ()) $ pure (RequestInt 1) <$ pulse

196 (_, pulse') <- runWithReplace (pure ()) $ pure (RequestInt 1) <$ pulse

174 requestingIdentity pulse'

197 requestingIdentity pulse'

198+

199+data TestRequest a where

200+ TestRequest_Reverse :: String -> TestRequest String

201+ TestRequest_Increment :: Int -> TestRequest Int

202+

203+testMatchRequestsWithResponses

204+ :: forall m t req a

205+ . ( MonadFix m

206+ , MonadHold t m

207+ , Reflex t

208+ , PerformEvent t m

209+ , MonadIO (Performable m)

210+ , ForallF Show req

211+ , Has Read req

212+ )

213+ => Event t (req a) -> m (Event t (Map Int String))

214+testMatchRequestsWithResponses pulse = mdo

215+ (_, requests) <- runRequesterT (requesting pulse) responses

216+ let rawResponses = M.map (\v ->

217+ case words v of

218+ ["reverse", str] -> reverse str

219+ ["increment", i] -> show $ succ $ (read i :: Int)

220+ ) <$> rawRequestMap

221+ (rawRequestMap, responses) <- matchResponsesWithRequests reqEncoder requests (head . M.toList <$> rawResponses)

222+ pure rawResponses

223+ where

224+ reqEncoder :: forall a. req a -> (String, String -> Maybe a)

225+ reqEncoder r =

226+ ( whichever @Show @req @a $ show r

227+ , \x -> has @Read r $ readMaybe x

228+ )

229+

230+deriveArgDict ''TestRequest

231+

232+instance Show (TestRequest a) where

233+ show = \case

234+ TestRequest_Reverse str -> "reverse " <> str

235+ TestRequest_Increment i -> "increment " <> show i

test/hlint.hs−7

@@ -30,16 +30,9 @@ main = do

30 ]

31 matchFile = and <$> sequence

32 [ extension ==? ".hs"

33− , let notElem' = liftOp notElem

34− in filePath `notElem'` filePathExceptions pwd

35 ]

33 ]

36 files <- find recurseInto matchFile (pwd </> "src") --TODO: Someday fix all hints in tests, etc.

34 files <- find recurseInto matchFile (pwd </> "src") --TODO: Someday fix all hints in tests, etc.

37 ideas <- fmap concat $ forM files $ \f -> do

35 ideas <- fmap concat $ forM files $ \f -> do

38 putStr $ "linting file " ++ drop (length pwd + 1) f ++ "... "

36 putStr $ "linting file " ++ drop (length pwd + 1) f ++ "... "

39 runHlint f

37 runHlint f

40 if null ideas then exitSuccess else exitFailure

38 if null ideas then exitSuccess else exitFailure

41−

42−filePathExceptions :: FilePath -> [FilePath]

43−filePathExceptions pwd = map (pwd </>) $

44− [ "src/Data/AppendMap.hs" -- parse error when hlint runs

45− ]