ea67b1d · patch · git.iko.soy

git.iko.soy/patch

Merge remote-tracking branch 'origin/develop' into patchmapwithmove2

commitea67b1d5ce737ae1cd56c9662018b0d5de9ccbc8 authorRyan Trinkle <ryan.trinkle@gmail.com> dateWed 11 Sep 2019, 16:08 (7 years ago) parent3c5d146 55a1e29

41 files changed+788−302

compare with develop

unifiedsplit

.travis.ymlnew file+171

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

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

2+#

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

4+#

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

6+#

7+# version: 0.3.20190814

8+#

9+language: c

10+dist: xenial

11+sudo: required

12+git:

13+ # whether to recursively clone submodules

14+ submodules: false

15+cache:

16+ directories:

17+ - $HOME/.cabal/packages

18+ - $HOME/.cabal/store

19+before_cache:

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

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

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

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

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

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

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

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

28+matrix:

29+ include:

30+ - compiler: ghcjs-8.4

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

32+ - compiler: ghc-8.6.5

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

34+ - compiler: ghc-8.4.4

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

36+ - compiler: ghc-8.2.2

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

38+ - compiler: ghc-8.0.2

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

40+before_install:

41+ - |

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

43+ sudo add-apt-repository -y ppa:hvr/ghcjs;

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

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

46+ sudo apt-get update;

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

48+ fi

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

50+ - WITHCOMPILER="-w $HC"

51+ - |

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

53+ GHCJS=true

54+ HC=${HC}js

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

56+ else

57+ GHCJS=false;

58+ fi

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

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

61+ - HCPKG="$HC-pkg"

62+ - unset CC

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

64+ - CABALHOME=$HOME/.cabal

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

66+ - TOP=$(pwd)

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

68+ - echo $HCNUMVER

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

70+ - set -o pipefail

71+ - |

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

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

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

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

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

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

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

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

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

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

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

83+ - cat .colorful.awk

84+ - |

85+ color_cabal_output () {

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

87+ }

88+ - echo text | color_cabal_output

89+install:

90+ - ${CABAL} --version

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

92+ - node --version

93+ - echo $GHCJS

94+ - TEST=--enable-tests

95+ - BENCH=--enable-benchmarks

96+ - BENCH=--disable-benchmarks

97+ - HEADHACKAGE=false

98+ - rm -f $CABALHOME/config

99+ - |

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

115+ - cat $CABALHOME/config

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

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

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

119+ # Generate cabal.project

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

121+ - touch cabal.project

122+ - |

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

124+ - |

125+ - cat cabal.project || true

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

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

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

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

130+ - rm cabal.project.freeze

131+script:

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

133+ # Packaging...

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

135+ # Unpacking...

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

137+ - cd ${DISTDIR} || false

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

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

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

141+ # Generate cabal.project

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

143+ - touch cabal.project

144+ - |

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

146+ - |

147+ - cat cabal.project || true

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

149+ # Building...

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

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

152+ # Building with tests and benchmarks...

153+ # build & run tests, build benchmarks

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

155+ # Testing...

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

157+ # cabal check...

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

159+ # haddock...

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

161+ # Constraint sets

162+ - rm -rf cabal.project.local

163+ # Constraint set no-th

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

165+ # Constraint set old-these

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

167+ # Constraint set old-witherable

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

169+

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

171+# EOF

CONTRIBUTING.md+9

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

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

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

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

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

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

910 - [Documentation](#documentation)

1011

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

3031#### Body

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

3233

34+### Guidelines for Pull Requests

35+

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

37+

3338### Code Quality

3439

3540#### Warnings

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

4045

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

4247

48+#### Dependencies

49+

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

51+

4352### Documentation

4453

4554#### In the code

ChangeLog.md+33

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

11# Revision history for reflex

3+## 0.6.2.4

5+* Update to monoidal-containers 0.6

7+## 0.6.2.3

9+* Add an upper-bound to witherable

10+

11+## 0.6.2.2

12+

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

14+* Update version bounds to fix some CI failures

15+* Add travis CI configuration

16+

17+## 0.6.2.1

18+

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

20+ functor:

21+ * `fan` to `fanG`

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

23+

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

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

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

27+

28+* Generalize merging functions:

29+ `merge` to `mergeG`,

30+ `mergeIncremental` to `mergeIncrementalG`,

31+ `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`.

32+

33+* Generalize distribute function:

34+ `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`,

35+

336## 0.6.2.0

437

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

cabal.haskell-cinew file+16

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

1+distribution: xenial

2+benchmarks: False

3+unconstrained: False

4+installed: -all

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

7+install-dependencies: False

9+constraint-set no-th

10+ constraints: reflex -use-template-haskell

11+

12+constraint-set old-these

13+ constraints: these <1

14+

15+constraint-set old-witherable

16+ constraints: witherable <0.3.2

cabal.projectnew file+1

@@ -0,0 +1 @@

1+packages: .

cabal.project.freezenew file+1

@@ -0,0 +1 @@

1+constraints: any.text < 1.2.4.0

default.nix+10−7

@@ -6,12 +6,13 @@

66, template-haskell , these, time, transformers

77, transformers-compat, unbounded-delays, prim-uniq

88, data-default, filepath, directory, filemanip, ghcjs-base

9−, monoidal-containers, witherable, constraints-extras

9+, monoidal-containers, witherable, constraints-extras, profunctors

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

1011, useTemplateHaskell ? true

1112}:

1213mkDerivation {

1314 pname = "reflex";

14− version = "0.6.2.0";

15+ version = "0.6.2.4";

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

1617 libraryHaskellDepends = [

1718 base bifunctors containers dependent-map dependent-sum

@@ -22,18 +23,20 @@ mkDerivation {

2223 base bifunctors containers deepseq dependent-map dependent-sum

2324 mtl ref-tf split transformers data-default

2425 random time unbounded-delays monoidal-containers witherable

25− constraints-extras

26+ constraints-extras profunctors

2627 ] ++ (if ghc.isGhcjs or false then [

2728 ghcjs-base

2829 ] else []) ++ (if !useTemplateHaskell then [] else [

2930 haskell-src-exts haskell-src-meta

30− ]);

31+ ]) ++ (if splitThese then [

32+ semialign

33+ ] else []);

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

3235 hlint filepath directory filemanip

3336 ];

34− configureFlags = if useTemplateHaskell then [] else [

35− "-f-use-template-haskell"

36− ];

37+ configureFlags =

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

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

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

3841 description = "Higher-order Functional Reactive Programming";

3942 license = stdenv.lib.licenses.bsd3;

reflex.cabal+62−31

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

11Name: reflex

2−Version: 0.6.2.0

2+Version: 0.6.2.4

33Synopsis: Higher-order Functional Reactive Programming

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

55License: BSD3

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

1717 Quickref.md

1818 ChangeLog.md

1919

20+tested-with:

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

22+ GHCJS ==8.4

23+

2024flag use-reflex-optimizer

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

2226 default: False

@@ -37,39 +41,51 @@ flag fast-weak

3741 default: False

3842 manual: True

3943

44+flag split-these

45+ description: Use split these/semialign packages

46+ manual: False

47+ default: True

48+

4049library

4150 hs-source-dirs: src

4251 build-depends:

4352 MemoTrie == 0.6.*,

4453 base >= 4.9 && < 4.13,

4554 bifunctors >= 5.2 && < 5.6,

46− comonad,

47− constraints-extras >= 0.2,

48− containers >= 0.5 && < 0.7,

55+ comonad >= 5.0.4 && < 5.1,

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

57+ containers >= 0.6 && < 0.7,

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

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

5160 exception-transformers == 0.4.*,

61+ profunctors >= 5.3 && < 5.5,

5262 lens >= 4.7 && < 5,

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

54− monoidal-containers == 0.4.*,

5564 mtl >= 2.1 && < 2.3,

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

57− primitive >= 0.5 && < 0.7,

66+ primitive >= 0.5 && < 0.8,

67+ profunctors,

5868 random == 1.1.*,

5969 ref-tf == 0.4.*,

6070 reflection == 2.1.*,

6171 semigroupoids >= 4.0 && < 6,

62− semigroups >= 0.16 && < 0.19,

6372 stm >= 2.4 && < 2.6,

6473 syb >= 0.5 && < 0.8,

65− these >= 0.4 && < 0.9,

6674 time >= 1.4 && < 1.9,

67− transformers >= 0.2,

68− transformers-compat >= 0.3,

75+ transformers >= 0.5.6.0 && < 0.6,

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

70− witherable >= 0.2 && < 0.4

77+ witherable >= 0.3 && < 0.3.2

78+

79+ if flag(split-these)

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

81+ semialign >=1 && <1.1,

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

83+ else

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

85+ monoidal-containers == 0.4.0.0

7186

7287 exposed-modules:

88+ Control.Monad.ReaderIO

7389 Data.AppendMap,

7490 Data.FastMutableIntMap,

7591 Data.FastWeakBag,

@@ -144,7 +160,7 @@ library

144160 other-extensions: TemplateHaskell

145161 else

146162 build-depends:

147− dependent-sum == 0.6.*

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

148164

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

150166 cpp-options: -DGHCJS_FAST_WEAK

@@ -161,14 +177,14 @@ test-suite semantics

161177 base,

162178 bifunctors,

163179 containers,

164− deepseq >= 1.3 && < 1.5,

180+ deepseq,

165181 dependent-map,

166182 dependent-sum,

167183 mtl,

168184 ref-tf,

169185 reflex,

170186 split,

171− transformers >= 0.3

187+ transformers

172188 other-modules:

173189 Reflex.Bench.Focused

174190 Reflex.Plan.Pure

@@ -187,7 +203,7 @@ test-suite CrossImpl

187203 containers,

188204 dependent-map,

189205 dependent-sum,

190− deepseq >= 1.3 && < 1.5,

206+ deepseq,

191207 mtl,

192208 transformers,

193209 ref-tf,

@@ -206,7 +222,7 @@ test-suite hlint

206222 , directory

207223 , filepath

208224 , filemanip

209− , hlint

225+ , hlint < 2.1 || >= 2.2.2

210226 if impl(ghcjs)

211227 buildable: False

212228

@@ -216,7 +232,7 @@ test-suite EventWriterT

216232 hs-source-dirs: test

217233 build-depends: base

218234 , containers

219− , deepseq >= 1.3 && < 1.5

235+ , deepseq

220236 , dependent-map

221237 , dependent-sum

222238 , lens

@@ -225,6 +241,10 @@ test-suite EventWriterT

225241 , transformers

226242 , reflex

227243 , ref-tf

244+

245+ if flag(split-these)

246+ build-depends: these-lens

247+

228248 other-modules:

229249 Reflex.Test

230250 Reflex.TestPlan

@@ -232,13 +252,14 @@ test-suite EventWriterT

232252 Reflex.Plan.Pure

233253 Test.Run

234254

255+

235256test-suite RequesterT

236257 type: exitcode-stdio-1.0

237258 main-is: RequesterT.hs

238259 hs-source-dirs: test

239260 build-depends: base

240261 , containers

241− , deepseq >= 1.3 && < 1.5

262+ , deepseq

242263 , dependent-sum

243264 , dependent-map

244265 , lens

@@ -247,9 +268,14 @@ test-suite RequesterT

247268 , transformers

248269 , reflex

249270 , ref-tf

271+

272+ if flag(split-these)

273+ build-depends: these-lens

274+

250275 other-modules:

251276 Reflex.TestPlan

252277 Reflex.Plan.Pure

278+ Test.Run

253279

254280test-suite QueryT

255281 type: exitcode-stdio-1.0

@@ -259,15 +285,18 @@ test-suite QueryT

259285 , containers

260286 , dependent-map

261287 , dependent-sum

262− , deepseq >= 1.3 && < 1.5

288+ , deepseq

263289 , lens

264290 , monoidal-containers

265291 , mtl

266292 , ref-tf

267293 , reflex

268− , semigroups

269294 , these

270295 , transformers

296+

297+ if flag(split-these)

298+ build-depends: semialign, these-lens

299+

271300 other-modules:

272301 Test.Run

273302 Reflex.TestPlan

@@ -282,14 +311,16 @@ test-suite GC-Semantics

282311 , containers

283312 , dependent-sum

284313 , dependent-map

285− , deepseq >= 1.3 && < 1.5

314+ , deepseq

286315 , mtl

287316 , these

288317 , transformers

289318 , reflex

290319 , ref-tf

291− if impl(ghc < 8)

292− build-depends: semigroups

320+

321+ if flag(split-these)

322+ build-depends: semialign

323+

293324 other-modules:

294325 Reflex.Plan.Pure

295326 Reflex.Plan.Reflex

@@ -302,7 +333,7 @@ test-suite rootCleanup

302333 hs-source-dirs: test

303334 build-depends: base

304335 , containers

305− , deepseq >= 1.3 && < 1.5

336+ , deepseq

306337 , dependent-sum

307338 , mtl

308339 , reflex

@@ -321,8 +352,8 @@ benchmark spider-bench

321352 build-depends:

322353 base,

323354 containers,

324− criterion >= 1.1 && < 1.6,

325− deepseq >= 1.3 && < 1.5,

355+ criterion,

356+ deepseq,

326357 dependent-map,

327358 dependent-sum,

328359 ref-tf,

@@ -331,7 +362,7 @@ benchmark spider-bench

331362 reflex,

332363 split,

333364 stm,

334− transformers >= 0.3

365+ transformers

335366 other-modules:

336367 Reflex.TestPlan

337368 Reflex.Plan.Reflex

@@ -345,9 +376,9 @@ benchmark saulzar-bench

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

346377 build-depends:

347378 base,

348− containers >= 0.5 && < 0.7,

349− criterion >= 1.1 && < 1.6,

350− deepseq >= 1.3 && < 1.5,

379+ containers,

380+ criterion,

381+ deepseq,

351382 dependent-map,

352383 dependent-sum,

353384 loch-th,

@@ -359,7 +390,7 @@ benchmark saulzar-bench

359390 split,

360391 stm,

361392 time,

362− transformers >= 0.3

393+ transformers

363394 other-modules:

364395 Reflex.TestPlan

365396 Reflex.Plan.Reflex

release.nix+4−4

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

33let

44 inherit (rp.nixpkgs) lib;

55 compilers = ["ghc8_4" "ghc8_0" "ghcjs8_4" "ghcjs8_0"];

6−in lib.genAttrs compilers (ghc: {

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

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

9−})

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

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

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

9+}))

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

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

1+{-# language RoleAnnotations #-}

2+{-# language MultiParamTypeClasses #-}

3+{-# language FlexibleInstances #-}

4+{-# language CPP #-}

5+module Control.Monad.ReaderIO

6+ (

7+ ReaderIO (..)

8+ )

9+ where

10+

11+import Control.Monad.Fix

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

13+import Control.Applicative

14+#endif

15+import Control.Monad

16+import Control.Monad.Reader.Class

17+import Control.Monad.IO.Class

18+

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

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

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

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

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

24+type role ReaderIO representational representational

25+

26+instance Functor (ReaderIO e) where

27+ fmap = liftM

28+ {-# INLINE fmap #-}

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

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

31+

32+instance Applicative (ReaderIO e) where

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

34+ {-# INLINE pure #-}

35+ (<*>) = ap

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

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

38+ liftA2 = liftM2

39+ {-# INLINE liftA2 #-}

40+#endif

41+ (*>) = (>>)

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

43+

44+instance Monad (ReaderIO e) where

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

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

47+

48+instance MonadFix (ReaderIO e) where

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

50+ {-# INLINE mfix #-}

51+

52+instance MonadIO (ReaderIO e) where

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

54+ {-# INLINE liftIO #-}

55+

56+instance MonadReader e (ReaderIO e) where

57+ ask = ReaderIO pure

58+ {-# INLINE ask #-}

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

60+ {-# INLINE local #-}

src/Data/AppendMap.hs+5−1

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

3232#endif

3333import qualified Data.Witherable as W

3434import Data.Map.Monoidal

35+import qualified Data.Map.Monoidal as MonoidalMap

36+

3537

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

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

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

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

4749pattern AppendMap m = MonoidalMap m

4850

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

4952instance W.Filterable (MonoidalMap k) where

50− mapMaybe = mapMaybe

53+ mapMaybe = MonoidalMap.mapMaybe

54+#endif

5155

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

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

src/Data/Functor/Misc.hs−1

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

44{-# LANGUAGE FlexibleContexts #-}

55{-# LANGUAGE FlexibleInstances #-}

66{-# LANGUAGE GADTs #-}

7−{-# LANGUAGE KindSignatures #-}

87{-# LANGUAGE LambdaCase #-}

98{-# LANGUAGE MultiParamTypeClasses #-}

109{-# LANGUAGE PatternSynonyms #-}

src/Reflex/Adjustable/Class.hs−1

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

33{-# LANGUAGE FlexibleInstances #-}

44{-# LANGUAGE FunctionalDependencies #-}

55{-# LANGUAGE LambdaCase #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

76{-# LANGUAGE RankNTypes #-}

87{-# LANGUAGE ScopedTypeVariables #-}

98{-# LANGUAGE TypeFamilies #-}

src/Reflex/BehaviorWriter/Class.hs−1

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

55{-# LANGUAGE CPP #-}

66{-# LANGUAGE FlexibleInstances #-}

77{-# LANGUAGE FunctionalDependencies #-}

8−{-# LANGUAGE MultiParamTypeClasses #-}

98{-# LANGUAGE UndecidableInstances #-}

109#ifdef USE_REFLEX_OPTIMIZER

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

src/Reflex/Class.hs+103−24

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

77{-# LANGUAGE FunctionalDependencies #-}

88{-# LANGUAGE GADTs #-}

99{-# LANGUAGE LambdaCase #-}

10−{-# LANGUAGE MultiParamTypeClasses #-}

1110{-# LANGUAGE NoMonomorphismRestriction #-}

1211{-# LANGUAGE PolyKinds #-}

1312{-# LANGUAGE RankNTypes #-}

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

1716{-# LANGUAGE TypeFamilies #-}

1817{-# LANGUAGE TypeOperators #-}

1918{-# LANGUAGE UndecidableInstances #-}

19+{-# LANGUAGE Trustworthy #-}

2020#ifdef USE_REFLEX_OPTIMIZER

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

2222#endif

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

3636 , coerceBehavior

3737 , coerceEvent

3838 , coerceDynamic

39+ , coerceIncremental

3940 , MonadSample (..)

4041 , MonadHold (..)

4142 -- ** 'fan' related types

4243 , EventSelector (..)

44+ , EventSelectorG (..)

4345 , EventSelectorInt (..)

4446 -- * Convenience functions

4547 , constDyn

4648 , pushAlways

4749 -- ** Combining 'Event's

4850 , leftmost

51+ , merge

52+ , mergeIncremental

53+ , mergeIncrementalWithMove

4954 , mergeMap

5055 , mergeIntMap

5156 , mergeMapIncremental

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

6065 , alignEventWithMaybe

6166 -- ** Breaking up 'Event's

6267 , splitE

68+ , fan

6369 , fanEither

6470 , fanThese

6571 , fanMap

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

8490 , gate

8591 -- ** Combining 'Dynamic's

8692 , distributeDMapOverDynPure

93+ , distributeDMapOverDynPureG

8794 , distributeListOverDyn

8895 , distributeListOverDynWith

8996 , zipDyn

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

166173 , slowHeadE

167174 ) where

168175

176+#if defined(MIN_VERSION_semialign)

177+import Prelude hiding (zip, zipWith)

178+

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

180+import Data.These.Combinators (justThese)

181+#endif

182+#endif

183+

169184import Control.Applicative

170185import Control.Monad.Identity

171186import Control.Monad.Reader

@@ -255,11 +270,16 @@ class ( MonadHold t (PushM t)

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

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

257272 -- that are occurring simultaneously

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

273+

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

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

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

277+

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

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

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

261280 -- create child events

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

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

282+

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

264284 -- 'Event' occurs

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

@@ -277,9 +297,14 @@ class ( MonadHold t (PushM t)

277297 -- that value.

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

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

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

300+ mergeIncrementalG :: GCompare k

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

302+ -> Incremental t (PatchDMap k q)

303+ -> Event t (DMap k v)

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

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

305+ mergeIncrementalWithMoveG :: GCompare k

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

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

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

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

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

@@ -295,9 +320,25 @@ class ( MonadHold t (PushM t)

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

296321 -- occurrence type

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

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

324+ -- patch target and patch types.

325+ incrementalCoercion

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

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

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

300329

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

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

332+-- create child events

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

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

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

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

337+ where

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

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

340+ Coercion -> coerce

341+

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

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

303344-- keys simultaneously.

@@ -316,6 +357,12 @@ coerceEvent = coerceWith $ eventCoercion Coercion

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

317358coerceDynamic = coerceWith $ dynamicCoercion Coercion

318359

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

361+coerceIncremental

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

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

364+coerceIncremental = coerceWith $ incrementalCoercion Coercion Coercion

365+

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

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

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

@@ -485,6 +532,17 @@ newtype EventSelector t k = EventSelector

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

486533 }

487534

535+newtype EventSelectorG t k v = EventSelectorG

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

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

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

539+ --

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

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

542+ -- occurrences of an 'Event'.

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

544+ }

545+

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

489547-- filtering by key.

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

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

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

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

631689 sconcat = pull . fmap sconcat . mapM sample

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

633690 stimes n = fmap $ stimes n

634−#else

635− times1p n = fmap $ times1p n

636−#endif

637691

638692-- | Alias for 'mapMaybe'

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

@@ -660,9 +714,12 @@ filterRight = mapMaybe (either (const Nothing) Just)

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

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

662716

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

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

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

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

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

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

721+ f _ = Nothing

722+

666723

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

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

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

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

832889 (<>) = alignWith (mergeThese (<>))

833890 sconcat = fmap sconcat . mergeList . toList

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

835891 stimes n = fmap $ stimes n

836−#else

837− times1p n = fmap $ times1p n

838−#endif

839892

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

841894 mempty = never

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

10241077#endif

10251078 align = alignEventWithMaybe Just

10261079

1080+#if defined(MIN_VERSION_semialign)

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

1082+#endif

1083+

10271084

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

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

@@ -1064,11 +1121,7 @@ zipDynWith f da db =

10641121

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

10661123 (<>) = zipDynWith (<>)

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

10681124 stimes n = fmap $ stimes n

1069−#else

1070− times1p n = fmap $ times1p n

1071−#endif

10721125

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

10741127 mconcat = distributeListOverDynWith mconcat

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

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

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

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

1082−distributeDMapOverDynPure dm = case DMap.toList dm of

1135+distributeDMapOverDynPure = distributeDMapOverDynPureG coerceDynamic

1136+

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

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

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

1140+distributeDMapOverDynPureG

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

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

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

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

10831145 [] -> constDyn DMap.empty

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

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

10851147 _ ->

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

1087− edmPre = merge $ DMap.map updated dm

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

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

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

10891151 olds <- sample $ current result

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

@@ -1557,6 +1619,23 @@ fmapCheap f = pushCheap $ return . Just . f

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

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

15591621

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

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

1624+-- that are occurring simultaneously

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

1626+merge = mergeG coerceEvent

1627+{-# INLINE merge #-}

1628+

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

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

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

1632+mergeIncremental = mergeIncrementalG coerceEvent

1633+

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

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

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

1637+mergeIncrementalWithMove = mergeIncrementalWithMoveG coerceEvent

1638+

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

15611640{-# INLINE mergeWithCheap #-}

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

src/Reflex/Collection.hs+4

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

2727 , simpleList

2828 ) where

2929

30+#if defined(MIN_VERSION_semialign)

31+import Prelude hiding (zip, zipWith)

32+#endif

33+

3034import Control.Monad.Identity

3135import Data.Align

3236import Data.Functor.Misc

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

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

8181 }

8282

8383mkDynExp :: String -> Q Exp

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

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

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

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

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

src/Reflex/DynamicWriter/Class.hs−1

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

33{-# LANGUAGE CPP #-}

44{-# LANGUAGE FlexibleInstances #-}

55{-# LANGUAGE FunctionalDependencies #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

76{-# LANGUAGE UndecidableInstances #-}

87#ifdef USE_REFLEX_OPTIMIZER

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

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

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

5252import Data.Semigroup

5353import Data.Some (Some)

5454import Data.Tuple

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

55+import Data.Type.Equality

5656

5757import Unsafe.Coerce

5858

src/Reflex/EventWriter/Class.hs−1

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

22{-# LANGUAGE CPP #-}

33{-# LANGUAGE FlexibleInstances #-}

44{-# LANGUAGE FunctionalDependencies #-}

5−{-# LANGUAGE MultiParamTypeClasses #-}

65{-# LANGUAGE UndecidableInstances #-}

76#ifdef USE_REFLEX_OPTIMIZER

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

src/Reflex/Host/Class.hs−1

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

44{-# LANGUAGE FlexibleInstances #-}

55{-# LANGUAGE FunctionalDependencies #-}

66{-# LANGUAGE GADTs #-}

7−{-# LANGUAGE MultiParamTypeClasses #-}

87{-# LANGUAGE RankNTypes #-}

98{-# LANGUAGE RoleAnnotations #-}

109{-# LANGUAGE ScopedTypeVariables #-}

src/Reflex/NotReady/Class.hs−1

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

33{-# LANGUAGE FlexibleContexts #-}

44{-# LANGUAGE FlexibleInstances #-}

55{-# LANGUAGE FunctionalDependencies #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

76{-# LANGUAGE TypeFamilies #-}

87{-# LANGUAGE UndecidableInstances #-}

98#ifdef USE_REFLEX_OPTIMIZER

src/Reflex/Patch/IntMap.hs−8

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

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE DeriveFoldable #-}

32{-# LANGUAGE DeriveFunctor #-}

43{-# LANGUAGE DeriveTraversable #-}

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

3332instance Semigroup (PatchIntMap v) where

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

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

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

3735 stimes = stimesIdempotentMonoid

38−#else

39− times1p n x = case compare n 0 of

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

41− EQ -> mempty

42− GT -> x

43−#endif

4436

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

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

src/Reflex/Patch/Map.hs−8

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

1−{-# LANGUAGE CPP #-}

21{-# LANGUAGE LambdaCase #-}

32{-# LANGUAGE TypeFamilies #-}

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

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

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

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

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

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

3937 stimes = stimesIdempotentMonoid

40−#else

41− times1p n x = case compare n 0 of

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

43− EQ -> mempty

44− GT -> x

45−#endif

4638

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

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

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

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

141141 case mToPerform of

142142 Nothing -> return [result']

143143 Just toPerform -> do

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

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

145145 mrt <- readRef responseTrigger

146146 let followupEventTriggers = case mrt of

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

src/Reflex/PerformEvent/Class.hs−1

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

55{-# LANGUAGE FlexibleContexts #-}

66{-# LANGUAGE FlexibleInstances #-}

77{-# LANGUAGE FunctionalDependencies #-}

8−{-# LANGUAGE MultiParamTypeClasses #-}

98{-# LANGUAGE RankNTypes #-}

109{-# LANGUAGE ScopedTypeVariables #-}

1110{-# LANGUAGE TypeFamilies #-}

src/Reflex/PostBuild/Class.hs−1

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

44{-# LANGUAGE DataKinds #-}

55{-# LANGUAGE FlexibleInstances #-}

66{-# LANGUAGE FunctionalDependencies #-}

7−{-# LANGUAGE MultiParamTypeClasses #-}

87{-# LANGUAGE ScopedTypeVariables #-}

98{-# LANGUAGE TypeFamilies #-}

109{-# LANGUAGE TypeOperators #-}

src/Reflex/Profiled.hs+24−16

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

88{-# LANGUAGE StandaloneDeriving #-}

99{-# LANGUAGE TypeFamilies #-}

1010{-# LANGUAGE UndecidableInstances #-}

11+{-# LANGUAGE PolyKinds #-}

12+{-# LANGUAGE TypeApplications #-}

13+{-# LANGUAGE RankNTypes #-}

1114-- |

1215-- Module:

1316-- Reflex.Profiled

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

1619-- profiling/cost-center information.

1720module Reflex.Profiled where

1821

19−import Control.Lens hiding (children)

2022import Control.Monad

2123import Control.Monad.Exception

2224import Control.Monad.Fix

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

3335import qualified Data.Map.Strict as Map

3436import Data.Monoid ((<>))

3537import Data.Ord

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

3639import qualified Data.Semigroup as S

3740import Data.Type.Coercion

3841import Foreign.Ptr

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

7780 go (cc : l) parent

7881

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

80−toCostCentreTree ccs n = do

81− ccList <- getCostCentreStack ccs

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

83+toCostCentreTree ccs n =

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

85+ <$> getCostCentreStack ccs

8386

8487getCostCentreTree :: IO CostCentreTree

8588getCostCentreTree = do

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

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

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

135138 pull = Behavior_Profiled . pull . coerce

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

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

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

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

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

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

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

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

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

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

141146 current (Dynamic_Profiled d) = coerce $ current d

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

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

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

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

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

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

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

147152 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i

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

149154 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i

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

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

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

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

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

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

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

155+ behaviorCoercion c =

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

157+ eventCoercion c =

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

159+ dynamicCoercion c =

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

161+ incrementalCoercion c d =

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

163+ mergeIntIncremental = Event_Profiled . mergeIntIncremental .

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

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

158166

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

src/Reflex/Pure.hs+21−17

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

55{-# LANGUAGE MultiParamTypeClasses #-}

66{-# LANGUAGE ScopedTypeVariables #-}

77{-# LANGUAGE TypeFamilies #-}

8+{-# LANGUAGE RankNTypes #-}

9+{-# LANGUAGE PolyKinds #-}

10+

811#ifdef USE_REFLEX_OPTIMIZER

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

1013#endif

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

2831 , Incremental (..)

2932 ) where

3033

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

32−import Control.Applicative

33−#endif

34−

3534import Control.Monad

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

3736import qualified Data.Dependent.Map as DMap

38−import Data.Functor.Identity

3937import Data.IntMap (IntMap)

4038import qualified Data.IntMap as IntMap

4139import Data.Maybe

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

4341import Data.Monoid

4442import Data.Type.Coercion

4543import Reflex.Class

44+import Data.Kind (Type)

4645

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

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

49−data Pure t

48+data Pure (t :: Type)

5049

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

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

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

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

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

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

82− -- being present in the original class definition

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

8382

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

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

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

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

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

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

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

8787 in if DMap.null currentOccurrences

8888 then Nothing

8989 else Just currentOccurrences

9090

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

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

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

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

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

9394

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

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

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

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

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

114115

115− mergeIncremental = mergeIncrementalImpl

116− mergeIncrementalWithMove = mergeIncrementalImpl

116+ mergeIncrementalG = mergeIncrementalImpl

117+ mergeIncrementalWithMoveG = mergeIncrementalImpl

117118

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

119120

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

128129 behaviorCoercion Coercion = Coercion

129130 eventCoercion Coercion = Coercion

130131 dynamicCoercion Coercion = Coercion

132+ incrementalCoercion Coercion Coercion = Coercion

131133

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

133135

134136 mergeIntIncremental = mergeIntIncrementalImpl

135137

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

137−mergeIncrementalImpl i = Event $ \t ->

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

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

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

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

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

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

139143 in if DMap.null results

140144 then Nothing

141145 else Just results

src/Reflex/Query/Base.hs−1

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

11{-# LANGUAGE FlexibleInstances #-}

22{-# LANGUAGE GeneralizedNewtypeDeriving #-}

33{-# LANGUAGE InstanceSigs #-}

4−{-# LANGUAGE KindSignatures #-}

54{-# LANGUAGE LambdaCase #-}

65{-# LANGUAGE MultiParamTypeClasses #-}

76{-# LANGUAGE RankNTypes #-}

src/Reflex/Query/Class.hs−1

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

33{-# LANGUAGE FlexibleInstances #-}

44{-# LANGUAGE FunctionalDependencies #-}

55{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

76{-# LANGUAGE TypeFamilies #-}

87{-# LANGUAGE UndecidableInstances #-}

98-- |

src/Reflex/Requester/Class.hs−1

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

66{-# LANGUAGE CPP #-}

77{-# LANGUAGE FlexibleInstances #-}

88{-# LANGUAGE FunctionalDependencies #-}

9−{-# LANGUAGE MultiParamTypeClasses #-}

109{-# LANGUAGE RecursiveDo #-}

1110{-# LANGUAGE TypeFamilies #-}

1211{-# LANGUAGE UndecidableInstances #-}

src/Reflex/Spider/Internal.hs+224−163

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

99{-# LANGUAGE GADTs #-}

1010{-# LANGUAGE GeneralizedNewtypeDeriving #-}

1111{-# LANGUAGE LambdaCase #-}

12−{-# LANGUAGE MultiParamTypeClasses #-}

1312{-# LANGUAGE MultiWayIf #-}

1413{-# LANGUAGE RankNTypes #-}

1514{-# LANGUAGE RoleAnnotations #-}

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

1716{-# LANGUAGE TypeFamilies #-}

1817{-# LANGUAGE TypeOperators #-}

1918{-# LANGUAGE UndecidableInstances #-}

19+{-# LANGUAGE PolyKinds #-}

20+{-# LANGUAGE DeriveFunctor #-}

21+{-# LANGUAGE StandaloneDeriving #-}

22+{-# LANGUAGE InstanceSigs #-}

23+

2024#ifdef USE_REFLEX_OPTIMIZER

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

2226#endif

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

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

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

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

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

3338import Control.Monad.Exception

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

3540import Control.Monad.Primitive

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

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

42+import Control.Monad.Reader.Class

43+import Control.Monad.IO.Class

44+import Control.Monad.ReaderIO

3745import Control.Monad.Ref

3846import Data.Align

3947import Data.Coerce

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

4957import Data.IntMap.Strict (IntMap)

5058import qualified Data.IntMap.Strict as IntMap

5159import Data.IORef

60+import Data.Kind (Type)

5261import Data.Maybe hiding (mapMaybe)

5362import Data.Monoid ((<>))

5463import Data.Proxy

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

6372import System.Mem.Weak

6473import Unsafe.Coerce

6574

75+#if defined(MIN_VERSION_semialign)

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

77+import Data.These.Combinators (justThese)

78+#endif

79+#endif

80+

6681#ifdef DEBUG_CYCLES

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

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

@@ -76,6 +91,7 @@ import qualified Data.FastWeakBag as FastWeakBag

7691import Data.Reflection

7792import Data.Some (Some(Some))

7893import Data.Type.Coercion

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

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

8096import qualified Data.WeakBag as WeakBag

8197import qualified Reflex.Class

@@ -192,12 +208,6 @@ nextNodeIdRef = unsafePerformIO $ newIORef 1

192208

193209newNodeId :: IO Int

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

195−

196−{-# NOINLINE unsafeNodeId #-}

197−unsafeNodeId :: a -> Int

198−unsafeNodeId a = unsafePerformIO $ do

199− touch a

200− newNodeId

201211#endif

202212

203213--------------------------------------------------------------------------------

@@ -301,9 +311,10 @@ cacheEvent e =

301311#else

302312 Event $

303313#endif

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

305− !mSubscribedRef = unsafeNewIORef e emptyFastWeak

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

314+ unsafePerformIO $ do

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

316+ <- newIORef emptyFastWeak

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

307318#ifdef DEBUG_TRACE_EVENTS

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

309320#endif

@@ -369,7 +380,7 @@ eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed

369380eventNever :: Event x a

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

371382

372−eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k -> Event x a

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

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

374385

375386eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a

@@ -421,14 +432,14 @@ newSubscriberHold h = return $ Subscriber

421432 , subscriberRecalculateHeight = \_ -> return ()

422433 }

423434

424−newSubscriberFan :: forall x k. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k -> IO (Subscriber x (DMap k Identity))

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

425436newSubscriberFan subscribed = return $ Subscriber

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

427438 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed

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

429440 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a

430441 scheduleClear $ fanSubscribedOccurrence subscribed

431− let f _ (Pair (Identity v) subsubs) = do

442+ let f _ (Pair v subsubs) = do

432443 propagate v $ _fanSubscribedChildren_list subsubs

433444 return $ Constant ()

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

@@ -544,6 +555,11 @@ propagateFast a subscribers = withIncreasedDepth $ do

544555toAny :: a -> Any

545556toAny = unsafeCoerce

546557

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

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

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

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

562+-- perfectly safe.

547563data EventSubscribed x = EventSubscribed

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

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

@@ -576,7 +592,7 @@ eventSubscribedNever = EventSubscribed

576592#endif

577593 }

578594

579−eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x

595+eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x

580596eventSubscribedFan !subscribed = EventSubscribed

581597 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed

582598 , eventSubscribedRetained = toAny subscribed

@@ -667,7 +683,7 @@ behaviorPull !p = Behavior $ do

667683 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"

668684 parentsRef <- liftIO $ newIORef []

669685 holdInits <- askBehaviorHoldInits

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

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

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

672688 parents <- liftIO $ readIORef parentsRef

673689 let subscribed = PullSubscribed

@@ -702,42 +718,46 @@ readBehaviorUntracked b = do

702718-- Dynamic

703719--------------------------------------------------------------------------------

704720

705−data Dynamic x p = Dynamic

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

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

722+

723+data Dynamic x target p = Dynamic

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

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

708726 }

709727

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

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

729+

730+

731+

732+

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

711734dynamicHold !h = Dynamic

712735 { dynamicCurrent = behaviorHold h

713736 , dynamicUpdated = eventHold h

714737 }

715738

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

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

717740dynamicHoldIdentity = dynamicHold

718741

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

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

720743dynamicConst !a = Dynamic

721744 { dynamicCurrent = behaviorConst a

722745 , dynamicUpdated = eventNever

723746 }

724747

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

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

726749dynamicDyn !d = Dynamic

727750 { dynamicCurrent = behaviorDyn d

728751 , dynamicUpdated = eventDyn d

729752 }

730753

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

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

732755dynamicDynIdentity = dynamicDyn

733756

734757--------------------------------------------------------------------------------

735758-- Combinators

736759--------------------------------------------------------------------------------

737760

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

739−--representational so we can use coerce

740−

741761--type role Hold representational

742762data Hold x p

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

@@ -758,20 +778,25 @@ globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv

758778

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

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

761−data SpiderTimelineEnv x = SpiderTimelineEnv

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

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

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

784+type role SpiderTimelineEnv nominal

785+

786+data SpiderTimelineEnv' x = SpiderTimelineEnv

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

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

764789#ifdef DEBUG

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

766791#endif

767792 }

768−type role SpiderTimelineEnv nominal

793+type role SpiderTimelineEnv' phantom

769794

770795instance Eq (SpiderTimelineEnv x) where

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

772797

773798instance GEq SpiderTimelineEnv where

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

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

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

776801 else Nothing

777802

@@ -794,7 +819,7 @@ runEventM :: EventM x a -> IO a

794819runEventM = unEventM

795820

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

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

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

798823

799824class MonadIO m => Defer a m where

800825 getDeferralQueue :: m (IORef [a])

@@ -932,9 +957,9 @@ getHoldEventSubscription h = do

932957

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

934959

935−--type role BehaviorM representational

936960-- BehaviorM can sample behaviors

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

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

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

938963

939964instance Monad (BehaviorM x) where

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

@@ -985,7 +1010,7 @@ data RootSubscribed x a = forall k. GCompare k => RootSubscribed

9851010#endif

9861011 }

9871012

988−data Root x (k :: * -> *)

1013+data Root x k

9891014 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event

9901015 , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))

9911016 , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))

@@ -1055,25 +1080,25 @@ heightBagVerify b@(HeightBag s c) = if

10551080heightBagVerify = id

10561081#endif

10571082

1058−data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren

1059− { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a))

1060− , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k)

1061− , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k)))

1083+data FanSubscribedChildren x k v a = FanSubscribedChildren

1084+ { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x (v a)))

1085+ , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k v)

1086+ , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k v)))

10621087 }

10631088

1064−data FanSubscribed (x :: *) k

1065− = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k)))

1066− , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))

1067− , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty

1089+data FanSubscribed x k v

1090+ = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))

1091+ , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k v)))

1092+ , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k v))) -- This DMap should never be empty

10681093 , fanSubscribedParent :: !(EventSubscription x)

10691094#ifdef DEBUG_NODEIDS

10701095 , fanSubscribedNodeId :: Int

10711096#endif

10721097 }

10731098

1074−data Fan x k

1075− = Fan { fanParent :: !(Event x (DMap k Identity))

1076− , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k)))

1099+data Fan x k v

1100+ = Fan { fanParent :: !(Event x (DMap k v))

1101+ , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))

10771102 }

10781103

10791104data SwitchSubscribed x a

@@ -1135,19 +1160,24 @@ instance HasSpiderTimeline x => Align (Event x) where

11351160#if MIN_VERSION_these(0, 8, 0)

11361161instance HasSpiderTimeline x => Semialign (Event x) where

11371162#endif

1138− align ea eb = mapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]

1163+ align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $

1164+ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]

1165+

1166+#if defined(MIN_VERSION_semialign)

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

1168+#endif

11391169

11401170data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)

11411171 | BuildDyn !(EventM x (PatchTarget p), Event x p)

11421172 | HoldDyn !(Hold x p)

11431173

1144−newtype Dyn x p = Dyn { unDyn :: IORef (DynType x p) }

1174+newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }

11451175

1146−newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)

1176+newMapDyn :: HasSpiderTimeline x => (a -> b) -> DynamicS x (Identity a) -> DynamicS x (Identity b)

11471177newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)

11481178

11491179--TODO: Avoid the duplication between this and R.zipDynWith

1150−zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c)

1180+zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> DynamicS x (Identity a) -> DynamicS x (Identity b) -> DynamicS x (Identity c)

11511181zipDynWith f da db =

11521182 let eab = align (dynamicUpdated da) (dynamicUpdated db)

11531183 ec = flip push eab $ \o -> do

@@ -1170,18 +1200,12 @@ buildDynamic readV0 v' = do

11701200 return d

11711201

11721202unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p

1173−unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ UnsafeDyn x

1174− where x = (readV0, v')

1203+unsafeBuildDynamic readV0 v' =

1204+ Dyn $ unsafePerformIO $ newIORef $ UnsafeDyn (readV0, v')

11751205

11761206-- ResultM can read behaviors and events

11771207type ResultM = EventM

11781208

1179−{-# NOINLINE unsafeNewIORef #-}

1180−unsafeNewIORef :: a -> b -> IORef b

1181−unsafeNewIORef a b = unsafePerformIO $ do

1182− touch a

1183− newIORef b

1184−

11851209instance HasSpiderTimeline x => Functor (Event x) where

11861210 fmap f = push $ return . Just . f

11871211

@@ -1194,33 +1218,42 @@ push f e = cacheEvent (pushCheap f e)

11941218

11951219{-# INLINABLE pull #-}

11961220pull :: BehaviorM x a -> Behavior x a

1197−pull a = behaviorPull $ Pull

1198− { pullCompute = a

1199− , pullValue = unsafeNewIORef a Nothing

1221+pull a = unsafePerformIO $ do

1222+ ref <- newIORef Nothing

12001223#ifdef DEBUG_NODEIDS

1201− , pullNodeId = unsafeNodeId a

1224+ nid <- newNodeId

12021225#endif

1203− }

1226+ pure $ behaviorPull $ Pull

1227+ { pullCompute = a

1228+ , pullValue = ref

1229+#ifdef DEBUG_NODEIDS

1230+ , pullNodeId = nid

1231+#endif

1232+ }

12041233

12051234{-# INLINABLE switch #-}

12061235switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a

1207−switch a = eventSwitch $ Switch

1208− { switchParent = a

1209− , switchSubscribed = unsafeNewIORef a Nothing

1210− }

1236+switch a = unsafePerformIO $ do

1237+ ref <- newIORef Nothing

1238+ pure $ eventSwitch $ Switch

1239+ { switchParent = a

1240+ , switchSubscribed = ref

1241+ }

12111242

12121243coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a

1213−coincidence a = eventCoincidence $ Coincidence

1214− { coincidenceParent = a

1215− , coincidenceSubscribed = unsafeNewIORef a Nothing

1216− }

1244+coincidence a = unsafePerformIO $ do

1245+ ref <- newIORef Nothing

1246+ pure $ eventCoincidence $ Coincidence

1247+ { coincidenceParent = a

1248+ , coincidenceSubscribed = ref

1249+ }

12171250

12181251-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors

12191252run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b

12201253run roots after = do

12211254 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"

12221255 let t = spiderTimeline :: SpiderTimelineEnv x

1223− result <- SpiderHost $ withMVar (_spiderTimeline_lock t) $ \_ -> unSpiderHost $ runFrame $ do

1256+ result <- SpiderHost $ withMVar (_spiderTimeline_lock (unSTE t)) $ \_ -> unSpiderHost $ runFrame $ do

12241257 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do

12251258 occBefore <- liftIO $ do

12261259 occBefore <- readIORef occRef

@@ -1284,9 +1317,9 @@ type WeakList a = [Weak a]

12841317withIncreasedDepth :: CanTrace x m => m a -> m a

12851318withIncreasedDepth a = do

12861319 spiderTimeline <- askSpiderTimelineEnv

1287− liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ

1320+ liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) succ

12881321 result <- a

1289− liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred

1322+ liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) pred

12901323 return result

12911324#else

12921325withIncreasedDepth :: m a -> m a

@@ -1313,7 +1346,7 @@ traceMWhen _ b getMessage = when b $ do

13131346 message <- getMessage

13141347#ifdef DEBUG

13151348 spiderTimeline <- askSpiderTimelineEnv

1316− d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline

1349+ d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE spiderTimeline

13171350#else

13181351 let d = 0

13191352#endif

@@ -1354,25 +1387,25 @@ propagateSubscriberHold h a = do

13541387data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset

13551388

13561389runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a

1357−runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)

1390+runBehaviorM a mwi holdInits = runReaderIO (unBehaviorM a) (mwi, holdInits)

13581391

13591392askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))

13601393askInvalidator = do

1361− (!m, _) <- BehaviorM ask

1394+ (!m, _) <- ask

13621395 case m of

13631396 Nothing -> return Nothing

13641397 Just (!wi, _) -> return $ Just wi

13651398

13661399askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))

13671400askParentsRef = do

1368− (!m, _) <- BehaviorM ask

1401+ (!m, _) <- ask

13691402 case m of

13701403 Nothing -> return Nothing

13711404 Just (_, !p) -> return $ Just p

13721405

13731406askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])

13741407askBehaviorHoldInits = do

1375− (_, !his) <- BehaviorM ask

1408+ (_, !his) <- ask

13761409 return his

13771410

13781411{-# INLINE getDynHold #-}

@@ -1417,6 +1450,9 @@ getRootSubscribed k r sub = do

14171450 when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"

14181451 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)

14191452 writeIORef uninitRef $! uninit

1453+#ifdef DEBUG_NODEIDS

1454+ nid <- newNodeId

1455+#endif

14201456 let !subscribed = RootSubscribed

14211457 { rootSubscribedKey = k

14221458 , rootSubscribedCachedSubscribed = cached

@@ -1425,7 +1461,7 @@ getRootSubscribed k r sub = do

14251461 , rootSubscribedUninit = uninit

14261462 , rootSubscribedWeakSelf = weakSelf

14271463#ifdef DEBUG_NODEIDS

1428− , rootSubscribedNodeId = unsafeNodeId (k, r, subs)

1464+ , rootSubscribedNodeId = nid

14291465#endif

14301466 }

14311467 -- If we die at the same moment that all our children die, they will

@@ -1474,16 +1510,10 @@ newFanInt = do

14741510 , _fanInt_occRef = occRef

14751511 }

14761512

1477−{-# NOINLINE unsafeNewFanInt #-}

1478−unsafeNewFanInt :: b -> FanInt x a

1479−unsafeNewFanInt b = unsafePerformIO $ do

1480− touch b

1481− newFanInt

1482−

14831513fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a

1484−fanInt p =

1485− let self = unsafeNewFanInt p

1486− in EventSelectorInt $ \k -> Event $ \sub -> do

1514+fanInt p = unsafePerformIO $ do

1515+ self <- newFanInt

1516+ pure $ EventSelectorInt $ \k -> Event $ \sub -> do

14871517 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)

14881518 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input

14891519 (subscription, parentOcc) <- subscribeAndRead p $ Subscriber

@@ -1519,7 +1549,7 @@ fanInt p =

15191549 return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)

15201550

15211551{-# INLINABLE getFanSubscribed #-}

1522−getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket, FanSubscribed x k, Maybe a)

1552+getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k v -> Subscriber x (v a) -> EventM x (WeakBagTicket, FanSubscribed x k v, Maybe (v a))

15231553getFanSubscribed k f sub = do

15241554 mSubscribed <- liftIO $ readIORef $ fanSubscribed f

15251555 case mSubscribed of

@@ -1537,13 +1567,16 @@ getFanSubscribed k f sub = do

15371567 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"

15381568 occRef <- liftIO $ newIORef parentOcc

15391569 when (isJust parentOcc) $ scheduleClear occRef

1570+#ifdef DEBUG_NODEIDS

1571+ nid <- liftIO newNodeId

1572+#endif

15401573 let subscribed = FanSubscribed

15411574 { fanSubscribedCachedSubscribed = fanSubscribed f

15421575 , fanSubscribedOccurrence = occRef

15431576 , fanSubscribedParent = subscription

15441577 , fanSubscribedSubscribers = subscribersRef

15451578#ifdef DEBUG_NODEIDS

1546− , fanSubscribedNodeId = unsafeNodeId f

1579+ , fanSubscribedNodeId = nid

15471580#endif

15481581 }

15491582 let !self = (k, subscribed)

@@ -1553,7 +1586,7 @@ getFanSubscribed k f sub = do

15531586 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed

15541587 return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)

15551588

1556−cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO ()

1589+cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k v) -> IO ()

15571590cleanupFanSubscribed (k, subscribed) = do

15581591 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

15591592 let reducedSubscribers = DMap.delete k subscribers

@@ -1565,7 +1598,7 @@ cleanupFanSubscribed (k, subscribed) = do

15651598 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers

15661599

15671600{-# INLINE subscribeFanSubscribed #-}

1568−subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO WeakBagTicket

1601+subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k v -> Subscriber x (v a) -> IO WeakBagTicket

15691602subscribeFanSubscribed k subscribed sub = do

15701603 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

15711604 case DMap.lookup k subscribers of

@@ -1603,6 +1636,9 @@ getSwitchSubscribed s sub = do

16031636 when (isJust parentOcc) $ scheduleClear occRef

16041637 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"

16051638 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed

1639+#ifdef DEBUG_NODEIDS

1640+ nid <- liftIO newNodeId

1641+#endif

16061642 let !subscribed = SwitchSubscribed

16071643 { switchSubscribedCachedSubscribed = switchSubscribed s

16081644 , switchSubscribedOccurrence = occRef

@@ -1615,7 +1651,7 @@ getSwitchSubscribed s sub = do

16151651 , switchSubscribedCurrentParent = subscriptionRef

16161652 , switchSubscribedWeakSelf = weakSelf

16171653#ifdef DEBUG_NODEIDS

1618− , switchSubscribedNodeId = unsafeNodeId s

1654+ , switchSubscribedNodeId = nid

16191655#endif

16201656 }

16211657 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"

@@ -1660,6 +1696,9 @@ getCoincidenceSubscribed c sub = do

16601696 scheduleClear innerSubdRef

16611697 weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"

16621698 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed

1699+#ifdef DEBUG_NODEIDS

1700+ nid <- liftIO newNodeId

1701+#endif

16631702 let subscribed = CoincidenceSubscribed

16641703 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c

16651704 , coincidenceSubscribedOccurrence = occRef

@@ -1670,7 +1709,7 @@ getCoincidenceSubscribed c sub = do

16701709 , coincidenceSubscribedInnerParent = innerSubdRef

16711710 , coincidenceSubscribedWeakSelf = weakSelf

16721711#ifdef DEBUG_NODEIDS

1673− , coincidenceSubscribedNodeId = unsafeNodeId c

1712+ , coincidenceSubscribedNodeId = nid

16741713#endif

16751714 }

16761715 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"

@@ -1687,26 +1726,34 @@ cleanupCoincidenceSubscribed subscribed = do

16871726subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket

16881727subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed

16891728

1690−{-# INLINE merge #-}

1691−merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)

1692−merge d = cacheEvent (mergeCheap d)

1729+{-# INLINE mergeG #-}

1730+mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k)

1731+ => (forall a. q a -> Event x (v a))

1732+ -> DynamicS x (PatchDMap k q) -> Event x (DMap k v)

1733+mergeG nt d = cacheEvent (mergeCheap nt d)

16931734

16941735{-# INLINE mergeWithMove #-}

1695−mergeWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)

1696−mergeWithMove d = cacheEvent (mergeCheapWithMove d)

1736+mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k)

1737+ => (forall a. q a -> Event x (v a))

1738+ -> DynamicS x (PatchDMapWithMove k q) -> Event x (DMap k v)

1739+mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)

16971740

16981741{-# INLINE [1] mergeCheap #-}

1699−mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)

1700−mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy

1742+mergeCheap

1743+ :: forall k x q v. (HasSpiderTimeline x, GCompare k)

1744+ => (forall a. q a -> Event x (v a))

1745+ -> DynamicS x (PatchDMap k q)

1746+ -> Event x (DMap k v)

1747+mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy

17011748 where

1702− updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)

1749+ updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)

17031750 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do

17041751 let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do

17051752 (mOldSubd, newPs) <- case me of

17061753 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps

17071754 Just e -> do

17081755 let s = subscriber $ return k

1709− subscription@(EventSubscription _ subd) <- subscribe e s

1756+ subscription@(EventSubscription _ subd) <- subscribe (nt e) s

17101757 newParentHeight <- liftIO $ getEventSubscribedHeight subd

17111758 let newParent = MergeSubscribedParent subscription

17121759 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight

@@ -1716,28 +1763,33 @@ mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy

17161763 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

17171764 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)

17181765 foldM f ([], oldParents) $ DMap.toList p

1719− getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParent x)

1766+

1767+ getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParent x)

17201768 getInitialSubscribers initialParents subscriber = do

17211769 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do

17221770 let s = subscriber $ return k

1723− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s

1771+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s

17241772 height <- liftIO $ getEventSubscribedHeight parentSubd

1725− return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription)

1773+ return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParent subscription)

17261774 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers

17271775 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here

17281776 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers

17291777 )

1778+

17301779 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)

17311780 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub

17321781

17331782{-# INLINE [1] mergeCheapWithMove #-}

1734−mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)

1735−mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy

1783+mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)

1784+ => (forall a. q a -> Event x (v a))

1785+ -> DynamicS x (PatchDMapWithMove k q)

1786+ -> Event x (DMap k v)

1787+mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy

17361788 where

1737− updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)

1789+ updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)

17381790 updateMe subscriber heightBagRef oldParents p = do

17391791 -- Prepare new parents for insertion

1740− let subscribeParent :: forall a. k a -> Event x a -> EventM x (MergeSubscribedParentWithMove x k a)

1792+ let subscribeParent :: forall a. k a -> Event x (v a) -> EventM x (MergeSubscribedParentWithMove x k a)

17411793 subscribeParent k e = do

17421794 keyRef <- liftIO $ newIORef k

17431795 let s = subscriber $ liftIO $ readIORef keyRef

@@ -1746,9 +1798,9 @@ mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy

17461798 newParentHeight <- getEventSubscribedHeight subd

17471799 modifyIORef' heightBagRef $ heightBagAdd newParentHeight

17481800 return $ MergeSubscribedParentWithMove subscription keyRef

1749− p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey subscribeParent p

1801+ p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey (\k q -> subscribeParent k (nt q)) p

17501802 -- Collect old parents for deletion and update the keys of moved parents

1751− let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Event x) a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a

1803+ let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a

17521804 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of

17531805 Nothing -> do

17541806 oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent

@@ -1759,46 +1811,47 @@ mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy

17591811 return Nothing

17601812 toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents

17611813 return (toDelete, applyAlways p' oldParents)

1762− getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k)

1814+ getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)

17631815 getInitialSubscribers initialParents subscriber = do

17641816 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do

17651817 keyRef <- liftIO $ newIORef k

17661818 let s = subscriber $ liftIO $ readIORef keyRef

1767− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s

1819+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s

17681820 height <- liftIO $ getEventSubscribedHeight parentSubd

1769− return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)

1821+ return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)

17701822 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers

17711823 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here

17721824 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers

17731825 )

1826+

17741827 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)

17751828 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub

17761829

1777−type MergeUpdateFunc k x p s

1778− = (forall a. EventM x (k a) -> Subscriber x a)

1830+type MergeUpdateFunc k v x p s

1831+ = (forall a. EventM x (k a) -> Subscriber x (v a))

17791832 -> IORef HeightBag

17801833 -> DMap k s

17811834 -> p

17821835 -> EventM x ([EventSubscription x], DMap k s)

17831836

1784−type MergeInitFunc k x s

1785− = DMap k (Event x)

1786− -> (forall a. EventM x (k a) -> Subscriber x a)

1787− -> EventM x (DMap k Identity, [Height], DMap k s)

1837+type MergeInitFunc k v q x s

1838+ = DMap k q

1839+ -> (forall a. EventM x (k a) -> Subscriber x (v a))

1840+ -> EventM x (DMap k v, [Height], DMap k s)

17881841

17891842type MergeDestroyFunc k s

17901843 = DMap k s

17911844 -> IO ()

17921845

1793−data Merge x k s = Merge

1846+data Merge x k v s = Merge

17941847 { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))

17951848 , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)

17961849 , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)

1797− , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k Identity))

1798− , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k Identity))

1850+ , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k v))

1851+ , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k v))

17991852 }

18001853

1801−invalidateMergeHeight :: Merge x k s -> IO ()

1854+invalidateMergeHeight :: Merge x k v s -> IO ()

18021855invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)

18031856

18041857invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()

@@ -1808,8 +1861,7 @@ invalidateMergeHeight' heightRef sub = do

18081861 writeIORef heightRef $! invalidHeight

18091862 subscriberInvalidateHeight sub oldHeight

18101863

1811−

1812−revalidateMergeHeight :: Merge x k s -> IO ()

1864+revalidateMergeHeight :: Merge x k v s -> IO ()

18131865revalidateMergeHeight m = do

18141866 currentHeight <- readIORef $ _merge_heightRef m

18151867 when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check

@@ -1825,19 +1877,19 @@ revalidateMergeHeight m = do

18251877 subscriberRecalculateHeight (_merge_sub m) height

18261878 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"

18271879

1828−scheduleMergeSelf :: HasSpiderTimeline x => Merge x k s -> Height -> EventM x ()

1880+scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()

18291881scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do

18301882 vals <- liftIO $ readIORef $ _merge_accumRef m

18311883 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

18321884 --TODO: Assert that m is not empty

18331885 subscriberPropagate (_merge_sub m) vals

18341886

1835−mergeSubscriber :: forall x k s a. (HasSpiderTimeline x, GCompare k) => Merge x k s -> EventM x (k a) -> Subscriber x a

1887+mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => Merge x k v s -> EventM x (k a) -> Subscriber x (v a)

18361888mergeSubscriber m getKey = Subscriber

18371889 { subscriberPropagate = \a -> do

18381890 oldM <- liftIO $ readIORef $ _merge_accumRef m

18391891 k <- getKey

1840− let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM

1892+ let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k a oldM

18411893 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)

18421894 liftIO $ writeIORef (_merge_accumRef m) $! newM

18431895 when (DMap.null oldM) $ do -- Only schedule the firing once

@@ -1868,7 +1920,7 @@ mergeSubscriber m getKey = Subscriber

18681920 }

18691921

18701922--TODO: Be able to run as much of this as possible promptly

1871−updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k s -> MergeUpdateFunc k x p s -> p -> SomeMergeUpdate x

1923+updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x

18721924updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)

18731925 where updateMe = do

18741926 oldParents <- liftIO $ readIORef $ _merge_parentsRef m

@@ -1876,9 +1928,10 @@ updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m)

18761928 liftIO $ writeIORef (_merge_parentsRef m) $! newParents

18771929 return subscriptionsToKill

18781930

1879−{-# INLINE mergeCheap' #-}

1880−mergeCheap' :: forall k x p s. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k (Event x)) => MergeInitFunc k x s -> MergeUpdateFunc k x p s -> MergeDestroyFunc k s -> Dynamic x p -> Event x (DMap k Identity)

1881−mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do

1931+{-# INLINE mergeGCheap' #-}

1932+mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)

1933+ => MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> DynamicS x p -> Event x (DMap k v)

1934+mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do

18821935 initialParents <- readBehaviorUntracked $ dynamicCurrent d

18831936 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"

18841937 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"

@@ -1926,11 +1979,11 @@ mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do

19261979 , occ

19271980 )

19281981

1929−mergeInt :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)

1982+mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)

19301983mergeInt = cacheEvent . mergeIntCheap

19311984

19321985{-# INLINABLE mergeIntCheap #-}

1933−mergeIntCheap :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)

1986+mergeIntCheap :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)

19341987mergeIntCheap d = Event $ \sub -> do

19351988 initialParents <- readBehaviorUntracked $ dynamicCurrent d

19361989 accum <- liftIO $ FastMutableIntMap.newEmpty

@@ -2027,14 +2080,16 @@ mergeIntCheap d = Event $ \sub -> do

20272080 )

20282081

20292082newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }

2083+newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) }

20302084

2031−fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k

2032−fan e =

2085+fanG :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k v) -> EventSelectorG x k v

2086+fanG e = unsafePerformIO $ do

2087+ ref <- newIORef Nothing

20332088 let f = Fan

20342089 { fanParent = e

2035− , fanSubscribed = unsafeNewIORef e Nothing

2090+ , fanSubscribed = ref

20362091 }

2037− in EventSelector $ \k -> eventFan k f

2092+ pure $ EventSelectorG $ \k -> eventFan k f

20382093

20392094runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()

20402095runHoldInits holdInitRef dynInitRef mergeInitRef = do

@@ -2088,7 +2143,7 @@ clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeI

20882143-- | Run an event action outside of a frame

20892144runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex

20902145runFrame a = SpiderHost $ do

2091− let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)

2146+ let env = _spiderTimeline_eventEnv $ unSTE (spiderTimeline :: SpiderTimelineEnv x)

20922147 let go = do

20932148 result <- a

20942149 runHoldInits (eventEnvHoldInits env) (eventEnvDynInits env) (eventEnvMergeInits env) -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events

@@ -2299,7 +2354,7 @@ instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x))

22992354 fail _ = error "Dynamic does not support 'fail'"

23002355

23012356{-# INLINABLE newJoinDyn #-}

2302−newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)

2357+newJoinDyn :: HasSpiderTimeline x => DynamicS x (Identity (DynamicS x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)

23032358newJoinDyn d =

23042359 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)

23052360 eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d

@@ -2449,7 +2504,7 @@ unsafeNewSpiderTimelineEnv = do

24492504#ifdef DEBUG

24502505 depthRef <- newIORef 0

24512506#endif

2452− return $ SpiderTimelineEnv

2507+ return $ STE $ SpiderTimelineEnv

24532508 { _spiderTimeline_lock = lock

24542509 , _spiderTimeline_eventEnv = env

24552510#ifdef DEBUG

@@ -2461,17 +2516,17 @@ unsafeNewSpiderTimelineEnv = do

24612516newSpiderTimeline :: IO (Some SpiderTimelineEnv)

24622517newSpiderTimeline = withSpiderTimeline (pure . Some)

24632518

2464−data LocalSpiderTimeline x s

2519+data LocalSpiderTimeline (x :: Type) s

24652520

24662521instance Reifies s (SpiderTimelineEnv x) =>

24672522 HasSpiderTimeline (LocalSpiderTimeline x s) where

2468− spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s)

2523+ spiderTimeline = localSpiderTimeline Proxy $ reflect (Proxy :: Proxy s)

24692524

24702525localSpiderTimeline

2471− :: Proxy s

2526+ :: proxy s

24722527 -> SpiderTimelineEnv x

24732528 -> SpiderTimelineEnv (LocalSpiderTimeline x s)

2474−localSpiderTimeline _ = unsafeCoerce

2529+localSpiderTimeline _ = coerce

24752530

24762531-- | Pass a new timeline to the given function.

24772532withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r

@@ -2479,18 +2534,18 @@ withSpiderTimeline k = do

24792534 env <- unsafeNewSpiderTimelineEnv

24802535 reify env $ \s -> k $ localSpiderTimeline s env

24812536

2482−newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2537+newtype SpiderPullM (x :: Type) a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

24832538

24842539type ComputeM = EventM

24852540

2486−newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2541+newtype SpiderPushM (x :: Type) a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

24872542

24882543instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

24892544 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}

24902545 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }

24912546 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }

2492− newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad)

2493− newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }

2547+ newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: DynamicS x (Identity a) } -- deriving (Functor, Applicative, Monad)

2548+ newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: DynamicS x p }

24942549 type PullM (SpiderTimeline x) = SpiderPullM x

24952550 type PushM (SpiderTimeline x) = SpiderPushM x

24962551 {-# INLINABLE never #-}

@@ -2503,10 +2558,15 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

25032558 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent

25042559 {-# INLINABLE pull #-}

25052560 pull = SpiderBehavior . pull . coerce

2506− {-# INLINABLE merge #-}

2507− merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x))

2508− {-# INLINABLE fan #-}

2509− fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))

2561+ {-# INLINABLE fanG #-}

2562+ fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))

2563+ {-# INLINABLE mergeG #-}

2564+ mergeG

2565+ :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k

2566+ => (forall a. q a -> R.Event (SpiderTimeline x) (v a))

2567+ -> DMap k q

2568+ -> R.Event (SpiderTimeline x) (DMap k v)

2569+ mergeG nt = SpiderEvent . mergeG (unSpiderEvent #. nt) . dynamicConst

25102570 {-# INLINABLE switch #-}

25112571 switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior

25122572 {-# INLINABLE coincidence #-}

@@ -2514,15 +2574,15 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

25142574 {-# INLINABLE current #-}

25152575 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic

25162576 {-# INLINABLE updated #-}

2517− updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic

2577+ updated = SpiderEvent #. dynamicUpdated .# fmap coerce . unSpiderDynamic

25182578 {-# INLINABLE unsafeBuildDynamic #-}

25192579 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'

25202580 {-# INLINABLE unsafeBuildIncremental #-}

25212581 unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv

2522− {-# INLINABLE mergeIncremental #-}

2523− mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental

2524− {-# INLINABLE mergeIncrementalWithMove #-}

2525− mergeIncrementalWithMove = SpiderEvent . mergeWithMove . (unsafeCoerce :: Dynamic x (PatchDMapWithMove k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMapWithMove k (Event x))) . unSpiderIncremental

2582+ {-# INLINABLE mergeIncrementalG #-}

2583+ mergeIncrementalG nt = SpiderEvent #. mergeG (coerce #. nt) .# unSpiderIncremental

2584+ {-# INLINABLE mergeIncrementalWithMoveG #-}

2585+ mergeIncrementalWithMoveG nt = SpiderEvent #. mergeWithMove (coerce #. nt) .# unSpiderIncremental

25262586 {-# INLINABLE currentIncremental #-}

25272587 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental

25282588 {-# INLINABLE updatedIncremental #-}

@@ -2533,9 +2593,10 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

25332593 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'

25342594 eventCoercion Coercion = Coercion

25352595 behaviorCoercion Coercion = Coercion

2536− dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance

2596+ dynamicCoercion Coercion = Coercion

2597+ incrementalCoercion Coercion Coercion = Coercion

25372598 {-# INLINABLE mergeIntIncremental #-}

2538− mergeIntIncremental = SpiderEvent . mergeInt . (unsafeCoerce :: Dynamic x (PatchIntMap (R.Event (SpiderTimeline x) a)) -> Dynamic x (PatchIntMap (Event x a))) . unSpiderIncremental

2599+ mergeIntIncremental = SpiderEvent . mergeInt . coerce

25392600 {-# INLINABLE fanInt #-}

25402601 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))

25412602

@@ -2560,7 +2621,7 @@ instance MonadAtomicRef (EventM x) where

25602621 atomicModifyRef r f = liftIO $ atomicModifyRef r f

25612622

25622623-- | The monad for actions that manipulate a Spider timeline identified by @x@

2563−newtype SpiderHost x a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

2624+newtype SpiderHost (x :: Type) a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

25642625

25652626instance Monad (SpiderHost x) where

25662627 {-# INLINABLE (>>=) #-}

@@ -2582,7 +2643,7 @@ runSpiderHost (SpiderHost a) = a

25822643runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a

25832644runSpiderHostForTimeline (SpiderHost a) _ = a

25842645

2585−newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }

2646+newtype SpiderHostFrame (x :: Type) a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }

25862647 deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

25872648

25882649instance Monad (SpiderHostFrame x) where

src/Reflex/TriggerEvent/Class.hs−1

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

22-- new 'Event's that can be triggered from 'IO'.

33{-# LANGUAGE FlexibleInstances #-}

44{-# LANGUAGE FunctionalDependencies #-}

5−{-# LANGUAGE MultiParamTypeClasses #-}

65{-# LANGUAGE UndecidableInstances #-}

76module Reflex.TriggerEvent.Class

87 ( TriggerEvent (..)

test/EventWriterT.hs+6−4

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE BangPatterns #-}

23{-# LANGUAGE FlexibleContexts #-}

34{-# LANGUAGE GADTs #-}

@@ -13,6 +14,10 @@ import Data.Functor.Misc

1314import qualified Data.Map as M

1415import Data.These

1516

17+#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))

18+import Data.These.Lens

19+#endif

20+

1621import Reflex

1722import Reflex.EventWriter.Base

1823import Test.Run

@@ -48,16 +53,13 @@ unwrapApp x appIn = do

4853 return e

4954

5055testOrdering :: (Reflex t, Monad m) => Event t () -> EventWriterT t [Int] m ()

51−testOrdering pulse = do

52− forM_ [10,9..1] $ \i -> tellEvent ([i] <$ pulse)

53− return ()

56+testOrdering pulse = forM_ [10,9..1] $ \i -> tellEvent ([i] <$ pulse)

5457

5558testSimultaneous :: (Reflex t, Adjustable t m, MonadHold t m) => Event t (These () ()) -> EventWriterT t [Int] m ()

5659testSimultaneous pulse = do

5760 let e0 = fmapMaybe (^? here) pulse

5861 e1 = fmapMaybe (^? there) pulse

5962 forM_ [1,3..9] $ \i -> runWithReplace (tellEvent ([i] <$ e0)) $ ffor e1 $ \_ -> tellEvent ([i+1] <$ e0)

60− return ()

6163

6264-- | Test that a widget telling and event which fires at the same time it has been replaced

6365-- doesn't count along with the new widget.

test/GC.hs+4−3

@@ -27,6 +27,7 @@ import qualified Reflex.Spider.Internal as S

2727

2828import System.Exit

2929import System.Mem

30+import Data.Coerce

3031

3132main :: IO ()

3233main = do

@@ -46,7 +47,7 @@ hostPerf ref = S.runSpiderHost $ do

4647 eventToPerform <- Host.runHostFrame $ do

4748 (reqMap :: S.Event S.Global (DMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) Identity))

4849 <- S.SpiderHostFrame

49− $ fmap ( S.merge

50+ $ fmap ( S.mergeG coerce

5051 . S.dynamicHold)

5152 $ S.hold DMap.empty

5253 -- Construct a new heap object for the subscriber, invalidating any weak references to the subscriber if they are not retained

@@ -55,8 +56,8 @@ hostPerf ref = S.runSpiderHost $ do

5556 { S.subscriberPropagate = S.subscriberPropagate sub

5657 }

5758 return (s, o))

58− $ runIdentity <$> S.select

59− (S.fan $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response)

59+ $ runIdentity . runIdentity <$> S.selectG

60+ (S.fanG $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response)

6061 (WrapArg Request)

6162 return $ alignWith (mergeThese (<>))

6263 (flip S.pushCheap eadd $ \_ -> return $ Just $ DMap.singleton Request $ do

test/QueryT.hs+4

@@ -19,6 +19,10 @@ import Data.Map.Monoidal (MonoidalMap)

1919import Data.Semigroup

2020import Data.These

2121

22+#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))

23+import Data.These.Lens

24+#endif

25+

2226import Reflex

2327import Reflex.Patch.MapWithMove

2428import Test.Run

test/Reflex/Bench/Focused.hs+12

@@ -130,6 +130,16 @@ mapDynChain = iterM (return . fmap (+1))

130130joinDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

131131joinDynChain = iterM (\d -> return $ join $ fmap (const d) d)

132132

133+holdDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

134+holdDynChain = iterM (\d -> sample (current d) >>= flip holdDyn (updated d))

135+

136+buildDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

137+buildDynChain = iterM (\d -> do

138+ let b = fmap (+1) (current d)

139+ e = fmap (*2) (updated d)

140+ buildDynamic (sample b) e)

141+

142+

133143combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

134144combineDynChain = iterM (\d -> return $ zipDynWith (+) d d)

135145

@@ -308,6 +318,8 @@ dynamics :: Word -> [(String, TestCase)]

308318dynamics n =

309319 [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d

310320 , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d

321+ , testE "holdDynChain" $ fmap updated $ holdDynChain n =<< d

322+ , testE "buildDynChain" $ fmap updated $ buildDynChain n =<< d

311323 , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d

312324 , testE "dense mergeTree" $ fmap (updated . mergeTreeDyn 8) dense

313325 , testE "sparse mergeTree" $ fmap (updated . mergeTreeDyn 8) sparse

test/Reflex/Test/CrossImpl.hs+5

@@ -218,6 +218,11 @@ testCases =

218218 bb <- hold b $ pushAlways (const $ hold "asdf" eo) eo

219219 let b' = pull $ sample =<< sample bb

220220 return (b', e)

221+ , (,) "foldDynWhileFiring" $ TestCase (Map.singleton 0 "zxc", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(_, e) -> do

222+ d <- foldDyn (:) [] $

223+ pushAlways (\a -> foldDyn (:) [a] e) e

224+ let b = current (join (fmap distributeListOverDynPure d))

225+ return (b, e)

221226 , (,) "joinDyn" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

222227 bb <- hold "b" e

223228 bd <- hold never . fmap (const e) =<< headE e

test/RequesterT.hs+5

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

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE BangPatterns #-}

23{-# LANGUAGE FlexibleContexts #-}

34{-# LANGUAGE GADTs #-}

@@ -15,6 +16,10 @@ import Data.Functor.Misc

1516import qualified Data.Map as M

1617import Data.These

1718

19+#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))

20+import Data.These.Lens

21+#endif

22+

1823import Reflex

1924import Reflex.Requester.Base

2025import Reflex.Requester.Class

test/hlint.hs+1

@@ -22,6 +22,7 @@ main = do

2222 , "--ignore=Use unless"

2323 , "--ignore=Reduce duplication"

2424 , "--cpp-define=USE_TEMPLATE_HASKELL"

25+ , "--ignore=Use tuple-section"

2526 ]

2627 recurseInto = and <$> sequence

2728 [ fileType ==? Directory