develop..db1dd70 · reflex

git.iko.soy/reflex

on db1dd70 help sign in

.github/workflows/haskell.ymldeleted−41

since splitsnapshots

unifiedsplit

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

1−name: github-action

2−

3−on: [push, pull_request]

4−

5−jobs:

6− build:

7− strategy:

8− matrix:

9− ghc: ['8.4.4', '8.6.5', '8.8.4', '8.10.2']

10− os: ['ubuntu-latest', 'macos-latest']

11− runs-on: ${{ matrix.os }}

12−

13− name: GHC ${{ matrix.ghc }} on ${{ matrix.os }}

14− steps:

15− - uses: actions/checkout@v2

16− - uses: actions/setup-haskell@v1

17− with:

18− ghc-version: ${{ matrix.ghc }}

19− - name: Cache

20− uses: actions/cache@v1

21− env:

22− cache-name: cache-cabal

23− with:

24− path: ~/.cabal

25− key: ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }}

26− restore-keys: |

27− ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-

28− ${{ runner.os }}-${{ matrix.ghc }}-build-

29− ${{ runner.os }}-${{ matrix.ghc }}-

30− ${{ runner.os }}

31−

32− - name: Install dependencies

33− run: |

34− cabal update

35− cabal build --only-dependencies --enable-tests --enable-benchmarks

36− - name: Build

37− run: cabal build --enable-tests --enable-benchmarks all

38− - name: Run tests

39− run: cabal test all

40− - name: Build Docs

41− run: cabal haddock

.stylish-haskell.yaml+3−2

@@ -149,5 +149,6 @@ columns: 110

149# needs to be aware of these, so it can parse the file correctly.

150#

151# No language extensions are enabled by default.

152−language_extensions:

152+# language_extensions:

153− - TemplateHaskell

153+ # - TemplateHaskell

154+ # - QuasiQuotes

.travis.ymlnew file+15

@@ -0,0 +1,15 @@

1+# Cache Buster: 0

2+language: nix

3+cache:

4+ directories:

5+ - /nix

6+matrix:

7+ include:

8+ - env: COMPILER=ghc7103

9+ - env: COMPILER=ghc801

10+ - env: COMPILER=ghcjs

11+script:

12+ - set -e

13+ - nix-build -E "with (import <nixpkgs> {}); pkgs.haskell.packages.$COMPILER.callPackage ./default.nix { }"

14+ - nix-collect-garbage -d # This is important to do right before 'script' ends so the cache gets GCed

15+

CONTRIBUTING.mddeleted−66

@@ -1,66 +0,0 @@

1−# Contribution Guide

2−

3−Contributions and issue reports are encouraged and appreciated!

4−

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

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

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

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

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

10− - [Documentation](#documentation)

11−

12−## Opening Issues

13−

14−Before opening an issue, please check whether your issue has already been reported. Assuming it has not:

15−

16−* Describe the issue you're encountering or the suggestion you're making

17−* Include any relevant steps to reproduce or code samples you can. It's always easier for us to debug if we have something that demonstrates the error.

18−* Let us know what version of reflex you were using. If you're using a github checkout, provide the git hash.

19−* Describe how you're building reflex (i.e., via reflex-platform, cabal install, stack, obelisk, etc.). If you're using reflex-platform or obelisk, provide the git hash of your checkout.

20−

21−## Submitting Changes

22−

23−### Guidelines for Commit Messages

24−

25−#### Summary Line

26−The summary line of your commit message should summarize the changes being made. Commit messages should be written in the imperative mood and should describe what happens when the commit is applied.

27−

28−One way to think about it is that your commit message should be able to complete the sentence:

29−"When applied, this commit will..."

30−

31−#### Body

32−For 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.

33−

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−

38−### Code Quality

39−

40−#### Warnings

41−

42−Your pull request should add no new warnings to the project. It should also generally not disable any warnings.

43−

44−#### Build and Test

45−

46−Make 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!

47−

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−

52−### Documentation

53−

54−#### In the code

55−We're always striving to improve documentation. Please include [haddock](https://haskell-haddock.readthedocs.io/en/latest/index.html) documentation for any added code, and update the documentation for any code you modify.

56−

57−#### In the [Changelog](ChangeLog.md)

58−Add an entry to the changelog when your PR:

59−* Adds a feature

60−* Deprecates something

61−* Includes a breaking change

62−* Makes any other change that will impact users

63−

64−#### In the [Readme](README.md)

65−The readme is the first place a lot of people look for information about the repository. Update any parts of the readme that are affected by your PR.

66−

ChangeLog.mddeleted−151

@@ -1,151 +0,0 @@

1−# Revision history for reflex

2−

3−## 0.8.2.0

4−

5−* Add `matchResponseMapWithRequests`, which it similar to `matchResponsesWithRequests` but allows processing of multiple responses at once.

6−

7−## 0.8.1.1

8−

9−* Allow newer hlint for older GHCs, and add upper bound for newer GHCs

10−

11−## 0.8.1.0

12−

13−* Add support for GHC 8.10

14−* Drop support for GHC < 8.4

15−

16−## 0.8.0.0

17−

18−* Replace 0.7.2.0 with 0.8.0.0 to reflect the `MonadHold` interface change. Deprecates 0.7.2.0.

19−

20−## 0.7.2.0 -- *Deprecated*

21−

22−* ([#416](https://github.com/reflex-frp/reflex/pull/416)) Add `now :: m (Event t ())` to `MonadHold`.

23−* Extend some dependency version bounds

24−* Fix HLint 3 test

25−

26−## 0.7.1.1

27−

28−*Backport release*.

29−Changes do not carry forward to 0.7.2.0.

30−

31−* Add support for GHC 8.10

32−* Drop support for GHC < 8.4

33−* Extend some dependency version bounds

34−* Fix HLint 3 test

35−

36−## 0.7.1.0

37−

38−* ([#413](https://github.com/reflex-frp/reflex/pull/413), [#417](https://github.com/reflex-frp/reflex/pull/417)) Add `Reflex.Host.Headless` module which provides `runHeadlessApp` as an easy way to run a Reflex network in a "headless" environment.

39−* ([#420](https://github.com/reflex-frp/reflex/pull/420)) Add a [`Data.Zip.Unzip`](https://hackage.haskell.org/package/semialign-1.1/docs/Data-Zip.html#t:Unzip) instance for `Event`.

40−* ([#419](https://github.com/reflex-frp/reflex/pull/419)) Add `distributeIntMapOverDynPure` and `joinDynThroughIntMap` as convenience functions for working with `Dynamic` `IntMap`s.

41−

42−

43−## 0.7.0.0

44−

45−* Add lifting instances for most classes to `Reflex.Profiled.Profiled`. ([#398](https://github.com/reflex-frp/reflex/pull/398))

46−* Class `MonadQuery t q m` now has a `Monad m` superclass constraint. ([#400](https://github.com/reflex-frp/reflex/pull/400))

47−* **(Breaking change)** Rename class `MonadBehaviorWriter` -> `BehaviorWriter` for consistency with `EventWriter`/`DynamicWriter`. ([#401](https://github.com/reflex-frp/reflex/pull/401))

48−* Introduce deprecated alias `MonadBehaviorWriter = BehaviorWriter`. ([#401](https://github.com/reflex-frp/reflex/pull/401))

49−* Fix bug in spider where event subscriptions would be prematurely finalized due to over-aggressive inlining. ([#409](https://github.com/reflex-frp/reflex/pull/409))

50−* Add instances of `PerformEvent` and `TriggerEvent` for `MaybeT`. ([#395](https://github.com/reflex-frp/reflex/pull/395))

51−

52−## 0.6.4.1

53−

54−* Fix a bug in the Reflex Profiled transformer where

55− `Reflex.Class.mergeIncrementalG` and

56− `Reflex.Class.mergeIncrementalWithMoveG` implementations referenced

57− itself instead of the inner transformed timeline, causing an

58− infinite loop.

59−

60−## 0.6.4

61−

62−* Support GHC 8.8

63−

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

65−

66−* The `Reflex.Patch.*` modules were moved to the `patch` library.

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

68−

69−* Additional instances for `Query` classes for basic types.

70−

71−* Add cabal flags `debug-propagation` and `debug-event-cycles` to build in debugging

72− code for performance and for cyclic dependencies between events

73−

74−## 0.6.3

75−

76−* `Data.WeakBag.traverse` and `Data.FastWeakBag.traverse` have been deprecated.

77− They are replaced with `Data.WeakBag.traverse_` and `Data.FastWeakBag.traverse_`, respectively.

78−

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

80−

81−* Add missing `NotReady` instances:

82− - `instance NotReady (SpiderTimeline x) (SpiderHost x)`

83− - `instance HasSpiderTimeline x => NotReady (SpiderTimeline x) (PerformEventT (SpiderTimeline x) (SpiderHost x))`

84−

85−## 0.6.2.4

86−

87−* Update to monoidal-containers 0.6

88−

89−## 0.6.2.3

90−

91−* Add an upper-bound to witherable

92−

93−## 0.6.2.2

94−

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

96−

97−* Update version bounds to fix some CI failures

98−

99−* Add travis CI configuration

100−

101−## 0.6.2.1

102−

103−* Generalize `fan` to `fanG` to take a `DMap` with non-`Identity`

104− functor:

105− * `fan` to `fanG`

106− * `EventSelectorG` for `fanG` result selector.

107−

108−* Reduce the amount of unsafeCoerce in coercing newtypes under Event/Dynamic/Behavior.

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

110− * Add incrementalCoercion/coerceIncremental to go with dynamicCoercion/coerceDynamic

111−

112−* Generalize merging functions:

113− `merge` to `mergeG`,

114− `mergeIncremental` to `mergeIncrementalG`,

115− `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`.

116−

117−* Generalize distribute function:

118− `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`,

119−

120−## 0.6.2.0

121−

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

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

124−

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

126−

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

128−

129−## 0.6.1.0

130−

131−* Re-export all of `Data.Map.Monoidal`

132−

133−* Fix `QueryT` and `RequesterT` tests

134−

135−## 0.6.0.0 -- 2019-03-20

136−

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

138−

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

140−

141−* Remove many deprecated functions.

142−

143−* Add a `Num` instance for `Dynamic`.

144−

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

146−

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

148−

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

150−

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

Quickref.md+11−143

@@ -13,6 +13,7 @@ Some of these functions are *pure*: They operate on Events, Behaviors, or Dynam

13[S] -- Function runs in any monad supporting MonadSample

14[H] -- Function runs in any monad supporting MonadHold

15```

16+

16Since MonadHold depends on MonadSample, any [S] function also runs in [H] context.

17Since MonadHold depends on MonadSample, any [S] function also runs in [H] context.

18## Functions producing Event

19## Functions producing Event

@@ -30,7 +31,6 @@ Since MonadHold depends on MonadSample, any [S] function also runs in [H] contex

30[ ] ffilter :: (a -> Bool) -> Event a -> Event a

31[ ] ffilter :: (a -> Bool) -> Event a -> Event a

31[ ] ffor :: Event a -> (a -> b) -> Event b

32[ ] ffor :: Event a -> (a -> b) -> Event b

32[ ] fforMaybe :: Event a -> (a -> Maybe b) -> Event b

33[ ] fforMaybe :: Event a -> (a -> Maybe b) -> Event b

33−[ ] <$ :: a -> Event b -> Event a

35-- Event to identical Event with debug trace. (Only prints if Event is ultimately used.)

36[ ] traceEvent :: Show a => String -> Event a -> Event a

@@ -46,27 +46,24 @@ Since MonadHold depends on MonadSample, any [S] function also runs in [H] contex

46[ ] attachPromptlyDynWith :: (a -> b -> c) -> Dynamic a -> Event b -> Event c

47[ ] attachWithMaybe :: (a -> b -> Maybe c) -> Behavior a -> Event b -> Event c

48[ ] attachPromptlyDynWithMaybe :: (a -> b -> Maybe c) -> Dynamic a -> Event b -> Event c

49−[ ] <@> :: Behavior (a -> b) -> Event a -> Event b

50−[ ] <@ :: Behavior a -> Event b -> Event a

52-- Combine multiple Events

50-- Combine multiple Events

53[ ] <> :: Semigroup a => Event a -> Event a -> Event a

51[ ] <> :: Semigroup a => Event a -> Event a -> Event a

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

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

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

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

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

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

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

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

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

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

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

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

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

61−[ ] merge :: GCompare k => DMap k Event -> Event (DMap k Identity)

58+[ ] merge :: GCompare k => DMap (WrapArg Event k) -> Event (DMap k)

62[ ] mergeMap :: Ord k => Map k (Event a) -> Event (Map k a)

59[ ] mergeMap :: Ord k => Map k (Event a) -> Event (Map k a)

64-- Efficient one-to-many fanout

61-- Efficient one-to-many fanout

65−[ ] fanMap :: Ord k => Event (Map k a) -> EventSelector (Const2 k a)

62+[ ] fanMap :: Ord k => Event (Map k a) -> EventSelector (Const2 k a)

66−[ ] fan :: GCompare k => Event (DMap k Identity) -> EventSelector k

63+[ ] fan :: GCompare k => Event (DMap k) -> EventSelector k

67−[ ] select :: EventSelector k -> k a -> Event a

64+[ ] select :: EventSelector k -> k a -> Event a

68−[ ] fanEither :: Event (Either a b) -> (Event a, Event b)

65+[ ] fanEither :: Event (Either a b) -> (Event a, Event b)

69−[ ] fanThese :: Event (These a b) -> (Event a, Event b)

66+[ ] fanThese :: Event (These a b) -> (Event a, Event b)

71-- Event to Event via function that can sample current values

68-- Event to Event via function that can sample current values

72[ ] push :: (a -> m (Maybe b)) -> Event a -> Event b

69[ ] push :: (a -> m (Maybe b)) -> Event a -> Event b

@@ -99,10 +96,6 @@ Since MonadHold depends on MonadSample, any [S] function also runs in [H] contex

99[ ] <> :: Monoid a => Behavior a -> Behavior a -> Behavior a

96[ ] <> :: Monoid a => Behavior a -> Behavior a -> Behavior a

100-- ... plus many more due to typeclass membership

97-- ... plus many more due to typeclass membership

101

102−-- Combine multiple behaviors via applicative instance

103−[ ] ffor2 :: Behavior a -> Behavior b -> (a -> b -> c) -> Behavior c

104−[ ] ffor3 :: Behavior a -> Behavior b -> Behavior c -> (a -> b -> c -> d) -> Behavior d

105−

106-- Behavior to Behavior by sampling current values

99-- Behavior to Behavior by sampling current values

107[S] sample :: Behavior a -> m a

100[S] sample :: Behavior a -> m a

108[ ] pull :: m a -> Behavior a

101[ ] pull :: m a -> Behavior a

@@ -140,17 +133,12 @@ Since MonadHold depends on MonadSample, any [S] function also runs in [H] contex

140[ ] >>= :: Dynamic a -> (a -> Dynamic b) -> Dynamic b

133[ ] >>= :: Dynamic a -> (a -> Dynamic b) -> Dynamic b

141[ ] zipDynWith :: (a -> b -> c) -> Dynamic a -> Dynamic b -> Dynamic c

134[ ] zipDynWith :: (a -> b -> c) -> Dynamic a -> Dynamic b -> Dynamic c

142

135

143−-- Combine multiple dynamics via applicative instance

144−[ ] ffor2 :: Dynamic a -> Dynamic b -> (a -> b -> c) -> Dynamic c

145−[ ] ffor3 :: Dynamic a -> Dynamic b -> Dynamic c -> (a -> b -> c -> d) -> Dynamic d

146−

147-- Efficient one-to-many fanout

136-- Efficient one-to-many fanout

148[ ] demux :: Ord k => Dynamic k -> Demux k

137[ ] demux :: Ord k => Dynamic k -> Demux k

149[ ] demuxed :: Eq k => Demux k -> k -> Dynamic Bool

138[ ] demuxed :: Eq k => Demux k -> k -> Dynamic Bool

150

139

151-- Dynamic to Dynamic, removing updates w/o value change

140-- Dynamic to Dynamic, removing updates w/o value change

152−[H] holdUniqDyn :: Eq a => Dynamic a -> m (Dynamic a)

141+[ ] uniqDyn :: Eq a => Dynamic a -> Dynamic a

153−[H] holdUniqDynBy :: (a -> a -> Bool) -> Dynamic t a -> m (Dynamic t a)

154

142

155-- Dynamic to identical Dynamic with debug trace. (Only prints if Dynamic is ultimately used.)

143-- Dynamic to identical Dynamic with debug trace. (Only prints if Dynamic is ultimately used.)

156[ ] traceDyn :: Show a => String -> Dynamic a -> Dynamic a

144[ ] traceDyn :: Show a => String -> Dynamic a -> Dynamic a

@@ -167,8 +155,8 @@ For Events, the returned Event fires whenever the latest Event supplied by the w

167-- Flatten Behavior-of-Event to Event. Old Event is used during switchover.

155-- Flatten Behavior-of-Event to Event. Old Event is used during switchover.

168[ ] switch :: Behavior (Event a) -> Event a

156[ ] switch :: Behavior (Event a) -> Event a

169

157

170−-- Flatten Dynamic-of-Event to Event. New Event is used immediately.

158+-- Flatten Dyanmic-of-Event to Event. New Event is used immediately.

171−[ ] switchDyn :: Dynamic (Event a) -> Event a

159+[ ] switchPromptlyDyn :: Dynamic (Event a) -> Event a

172

160

173-- Flatten Event-of-Event to Event that fires when both wrapper AND new Event fire.

161-- Flatten Event-of-Event to Event that fires when both wrapper AND new Event fire.

174[ ] coincidence :: Event (Event a) -> Event a

162[ ] coincidence :: Event (Event a) -> Event a

@@ -191,125 +179,5 @@ For Events, the returned Event fires whenever the latest Event supplied by the w

191

179

192-- Similar to above, for Events. Created Event initially tracks the first argument.

180-- Similar to above, for Events. Created Event initially tracks the first argument.

193-- At switchover, the output Event immediately tracks the new Event.

181-- At switchover, the output Event immediately tracks the new Event.

194−[H] switchHold :: Event a -> Event (Event a) -> m (Event a)

182+[H] switchPromptly :: Event a -> Event (Event a) -> m (Event a)

195−```

196−

197−## Typeclasses to introspect and modify an FRP network.

198−

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

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

201−

202−The typeclasses and their associated annotations include:

203−

204−- `PostBuild`

205− Fire an Event when an FRP network has been set up.

206− ```haskell

207− [B] -- Function runs in any monad supporting PostBuild

208− ```

209−

210−- `Adjustable`

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

212− ```haskell

213− [A] -- Function runs in any monad supporting Adjustable

214− ```

215−

216−- `TriggerEvent`

217− Create new externally-fired Events from within an FRP network.

218− ```haskell

219− [T] -- Function runs in any monad supporting TriggerEvent

220− ```

221−

222−- `PerformEvent`

223− Use Events to trigger IO actions and to collect their results.

224− ```haskell

225− [P] -- Function runs in any monad supporting PerformEvent

226− ```

227−

228−## Startup

229−

230−```haskell

231−-- One-shot Event that is triggered once the FRP network has been built

232−[B] getPostBuild :: m (Event ())

233−```

234−

235−## Collection management functions

236−

237−```haskell

238−-- Turn a Dynamic key/value map into a set of dynamically-changing widgets.

239−[H,A,B] listWithKey :: Ord k =>

240− Dynamic (Map k v) -> (k -> Dynamic v -> m a ) -> m (Dynamic (Map k a))

241−

242−-- Same as above where the widget constructor doesn't care about the key.

243−[H,A,B] list :: Ord k =>

244− Dynamic (Map k v) -> ( Dynamic v -> m a ) -> m (Dynamic (Map k a))

245−

246−-- Even simpler version where there are no keys and we just use a list.

247−[H,A,B] simpleList ::

248− Dynamic [v] -> ( Dynamic v -> m a ) -> m (Dynamic [a])

249−

250−-- Like listWithKey specialized for widgets returning (Event a).

251−[H,A,B] listViewWithKey :: Ord k =>

252− Dynamic (Map k v) -> (k -> Dynamic v -> m (Event a)) -> m (Event (Map k a))

253−

254−-- Create a dynamically-changing set of widgets, one of which is selected at any time.

255−[H,A,B] selectViewListWithKey_ :: Ord k => Dynamic k ->

256− Dynamic (Map k v) -> (k -> Dynamic v -> Dynamic Bool -> m (Event a)) -> m (Event k)

257−

258−-- Same as listWithKey, but takes initial values and an updates Event instead of a Dynamic.

259−[H,A] listWithKeyShallowDiff :: Ord k =>

260− Map k v -> Event (Map k (Maybe v)) -> (k -> v -> Event v -> m a) -> m (Dynamic (Map k a))

261−```

262−

263−## Creating new events from within an FRP network.

264−

265−```haskell

266−-- Create a new Event and a function that will cause the Event to fire, from within an FRP network

267−[T] newTriggerEvent :: m (Event a, a -> IO ())

268−```

269−

270−## Connecting to the real world (I/O)

271−

272−```haskell

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

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

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

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

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

278−

279−-- Just run side-effects; no return Event

280−[P] performEvent_ :: Event (Performable m ()) -> m ()

281−

282−-- Actions run asynchronously; actions are given a callback to send return values

283−[P,T] performEventAsync :: Event ((a -> IO ()) -> Performable m ()) -> m (Event a)

284−```

285−

286−### Time

287−

288−```haskell

289−-- Create Event at given interval with given basis time.

290−[P,T] tickLossy :: NominalDiffTime -> UTCTime -> m (Event t TickInfo)

291−

292−-- Delay an Event's occurrences by a given amount in seconds.

293−[P,T] delay :: NominalDiffTime -> Event t a -> m (Event t a)

294−```

295−

296−## Networks

297−

298−```haskell

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

300−

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

302−

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

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

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

306−[P,A] networkView :: Dynamic (m a) -> m (Event a)

307−

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

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

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

311−[H,A] networkHold :: m a -> Event (m a) -> m (Dynamic a)

312−

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

314−[P,A] untilReady :: m a -> m b -> m (a, Event b)

315```

183```

README.md+11−15

@@ -1,23 +1,19 @@

1−# [Reflex](https://reflex-frp.org/)

1+## Reflex

2+### Practical Functional Reactive Programming

3−[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/reflex.svg)](https://hackage.haskell.org/package/reflex) [![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/reflex/badge)](https://matrix.hackage.haskell.org/#/package/reflex) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](https://github.com/reflex-frp/reflex/blob/master/LICENSE)

4+Reflex is an fully-deterministic, higher-order Functional Reactive Programming (FRP) interface and an engine that efficiently implements that interface.

5−Interactive programs without callbacks or side-effects. Functional Reactive Programming (FRP) uses composable events and time-varying values to describe interactive systems as pure functions. Just like other pure functional code, functional reactive code is easier to get right on the first try, maintain, and reuse.

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

7−Reflex is a fully-deterministic, higher-order Functional Reactive Programming interface and an engine that efficiently implements that interface.

8+Comprehensive documentation is still a work in progress, but a tutorial for Reflex and Reflex-DOM is available at https://github.com/reflex-frp/reflex-platform and an introductory talk given at the New York Haskell Meetup is available here: [Part 1](https://www.youtube.com/watch?v=mYvkcskJbc4) / [Part 2](https://www.youtube.com/watch?v=3qfc9XFVo2c).

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

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

11−## Resources

12+### Additional resources

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

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

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

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

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

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

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

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

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

21−## Hacking

17+[hackage](https://hackage.haskell.org/package/reflex)

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

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

bench-cbits/checkCapability.c+12−11

@@ -42,7 +42,7 @@ typedef struct Task_ {

42 // or just continue immediately. It's a workaround for the fact

43 // that signalling a condition variable doesn't do anything if the

44 // thread is already running, but we want it to be sticky.

45− HsBool wakeup;

45+ rtsBool wakeup;

46#endif

48 // This points to the Capability that the Task "belongs" to. If

@@ -62,14 +62,14 @@ typedef struct Task_ {

62 // The current top-of-stack InCall

63 struct InCall_ *incall;

65− uint32_t n_spare_incalls;

65+ nat n_spare_incalls;

66 struct InCall_ *spare_incalls;

68− HsBool worker; // == rtsTrue if this is a worker Task

68+ rtsBool worker; // == rtsTrue if this is a worker Task

69− HsBool stopped; // this task has stopped or exited Haskell

69+ rtsBool stopped; // this task has stopped or exited Haskell

71 // So that we can detect when a finalizer illegally calls back into Haskell

72− HsBool running_finalizers;

72+ rtsBool running_finalizers;

74 // Links tasks on the returning_tasks queue of a Capability, and

75 // on spare_workers.

@@ -88,7 +88,7 @@ struct Capability_ {

88 StgFunTable f;

89 StgRegTable r;

91− uint32_t no; // capability number.

91+ nat no; // capability number.

93 // The Task currently holding this Capability. This task has

94 // exclusive access to the contents of this Capability (apart from

@@ -98,12 +98,12 @@ struct Capability_ {

99 // true if this Capability is running Haskell code, used for

100 // catching unsafe call-ins.

101− HsBool in_haskell;

101+ rtsBool in_haskell;

102

103 // Has there been any activity on this Capability since the last GC?

104− uint32_t idle;

104+ nat idle;

105

106− HsBool disabled;

106+ rtsBool disabled;

107

108 // The run queue. The Task owning this Capability has exclusive

109 // access to its run queue, so can wake up threads without

@@ -159,7 +159,7 @@ struct Capability_ {

159#if defined(THREADED_RTS)

160 // Worker Tasks waiting in the wings. Singly-linked.

161 Task *spare_workers;

162− uint32_t n_spare_workers; // count of above

162+ nat n_spare_workers; // count of above

163

164 // This lock protects:

165 // running_task

@@ -192,9 +192,10 @@ struct Capability_ {

192

193 // Per-capability STM-related data

194 StgTVarWatchQueue *free_tvar_watch_queues;

195+ StgInvariantCheckQueue *free_invariant_check_queues;

195 StgTRecChunk *free_trec_chunks;

196 StgTRecChunk *free_trec_chunks;

196 StgTRecHeader *free_trec_headers;

197 StgTRecHeader *free_trec_headers;

197− uint32_t transaction_tokens;

198+ nat transaction_tokens;

198} // typedef Capability is defined in RtsAPI.h

199} // typedef Capability is defined in RtsAPI.h

199 // We never want a Capability to overlap a cache line with anything

200 // We never want a Capability to overlap a cache line with anything

200 // else, so round it up to a cache line size:

201 // else, so round it up to a cache line size:

bench/Main.hs+6−7

@@ -20,7 +20,6 @@ import qualified Data.Dependent.Map as DMap

20import Data.Dependent.Sum

21import Data.Functor.Misc

22import Data.IORef

23−import Data.Maybe (fromJust)

24import Reflex

23import Reflex

25import Reflex.Host.Class

24import Reflex.Host.Class

@@ -71,7 +70,7 @@ micros =

71 , withSetupWHNF "fireEventsOnly"

70 , withSetupWHNF "fireEventsOnly"

72 (newEventWithTriggerRef >>= subscribePair)

71 (newEventWithTriggerRef >>= subscribePair)

73 (\(_, trigger) -> do

72 (\(_, trigger) -> do

74− key <- fromJust <$> liftIO (readIORef trigger)

73+ Just key <- liftIO $ readIORef trigger

75 fireEvents [key :=> Identity (42 :: Int)])

74 fireEvents [key :=> Identity (42 :: Int)])

76 , withSetupWHNF "fireEventsAndRead(head/merge1)"

75 , withSetupWHNF "fireEventsAndRead(head/merge1)"

77 (setupMerge 1 >>= subscribePair)

76 (setupMerge 1 >>= subscribePair)

@@ -85,14 +84,14 @@ micros =

85 , withSetupWHNF "fireEventsOnly(head/merge100)"

84 , withSetupWHNF "fireEventsOnly(head/merge100)"

86 (setupMerge 100 >>= subscribePair)

85 (setupMerge 100 >>= subscribePair)

87 (\(_, t:_) -> do

86 (\(_, t:_) -> do

88− key <- fromJust <$> liftIO (readIORef t)

87+ Just key <- liftIO $ readIORef t

89 fireEvents [key :=> Identity (42 :: Int)])

88 fireEvents [key :=> Identity (42 :: Int)])

90 , withSetupWHNF "hold" newEventWithTriggerRef $ \(ev, _) -> hold (42 :: Int) ev

89 , withSetupWHNF "hold" newEventWithTriggerRef $ \(ev, _) -> hold (42 :: Int) ev

91 , withSetupWHNF "sample" (newEventWithTriggerRef >>= hold (42 :: Int) . fst) sample

90 , withSetupWHNF "sample" (newEventWithTriggerRef >>= hold (42 :: Int) . fst) sample

92 ]

91 ]

94setupMerge :: Int

93setupMerge :: Int

95− -> SpiderHost Global ( Event (SpiderTimeline Global) (DMap (Const2 Int a) Identity)

94+ -> SpiderHost Global ( Event (SpiderEnv Global) (DMap (Const2 Int a) Identity)

96 , [IORef (Maybe (EventTrigger Spider a))]

95 , [IORef (Maybe (EventTrigger Spider a))]

97 )

96 )

98setupMerge num = do

97setupMerge num = do

@@ -100,11 +99,11 @@ setupMerge num = do

100 let !m = DMap.fromList [Const2 i :=> v | (i,v) <- zip [0..] evs]

99 let !m = DMap.fromList [Const2 i :=> v | (i,v) <- zip [0..] evs]

101 pure (merge m, triggers)

100 pure (merge m, triggers)

102

101

103−subscribePair :: (Event (SpiderTimeline Global) a, b) -> SpiderHost Global (EventHandle (SpiderTimeline Global) a, b)

102+subscribePair :: (Event (SpiderEnv Global) a, b) -> SpiderHost Global (EventHandle (SpiderEnv Global) a, b)

104subscribePair (ev, b) = (,b) <$> subscribeEvent ev

103subscribePair (ev, b) = (,b) <$> subscribeEvent ev

105

104

106−fireAndRead :: IORef (Maybe (EventTrigger (SpiderTimeline Global) a)) -> a -> EventHandle (SpiderTimeline Global) b

105+fireAndRead :: IORef (Maybe (EventTrigger (SpiderEnv Global) a)) -> a -> EventHandle (SpiderEnv Global) b

107 -> SpiderHost Global (Maybe b)

106 -> SpiderHost Global (Maybe b)

108fireAndRead trigger val subd = do

107fireAndRead trigger val subd = do

109− key <- fromJust <$> liftIO (readIORef trigger)

108+ Just key <- liftIO $ readIORef trigger

110 fireEventsAndRead [key :=> Identity val] $ readEvent subd >>= sequence

109 fireEventsAndRead [key :=> Identity val] $ readEvent subd >>= sequence

bench/RunAll.hs+1−1

@@ -136,7 +136,7 @@ benchmarks = implGroup "spider" runSpiderHost cases

136pattern RunTestCaseFlag = "--run-test-case"

137

138spawnBenchmark :: String -> Benchmark

139−spawnBenchmark name = bench name . toBenchmarkable $ \n -> do

139+spawnBenchmark name = Benchmark name $ Benchmarkable $ \n -> do

140 self <- getExecutablePath

141 callProcess self [RunTestCaseFlag, name, show n, "+RTS", "-N1"]

142

cabal.haskell-cideleted−23

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

1−distribution: xenial

2−benchmarks: False

3−unconstrained: False

4−installed: -all

5−

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

7−install-dependencies: False

8−

9−constraint-set no-th

10− constraints: reflex -use-template-haskell

11−

12−constraint-set old-these

13− ghc: <8.8

14− constraints: these <1

15−

16−constraint-set old-witherable

17− constraints: witherable <0.3.2

18−

19−constraint-set debug-propagation

20− constraints: reflex +debug-propagation

21−

22−constraint-set debug-cycles

23− constraints: reflex +debug-cycles

cabal.projectdeleted−1

@@ -1 +0,0 @@

1−packages: .

default.nixnew file+34

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

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

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

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

4+, monad-control, mtl, primitive, ref-tf, semigroupoids

5+, semigroups, split, stdenv, stm, syb, template-haskell

6+, these, transformers, transformers-compat, prim-uniq

7+, data-default

8+, useTemplateHaskell ? true

9+}:

10+mkDerivation {

11+ pname = "reflex";

12+ version = "0.5.0";

13+ src = builtins.filterSource (path: type: baseNameOf path != ".git") ./.;

14+ libraryHaskellDepends = [

15+ base bifunctors containers dependent-map dependent-sum

16+ exception-transformers lens

17+ MemoTrie monad-control mtl primitive ref-tf semigroupoids

18+ semigroups stm syb template-haskell these transformers

19+ transformers-compat prim-uniq

20+ base bifunctors containers deepseq dependent-map dependent-sum

21+ mtl ref-tf split transformers data-default

22+ ] ++ (if !useTemplateHaskell then [] else [

23+ haskell-src-exts haskell-src-meta

24+ ]);

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

26+ hlint

27+ ];

28+ configureFlags = if useTemplateHaskell then [] else [

29+ "-f-use-template-haskell"

30+ ];

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

32+ description = "Higher-order Functional Reactive Programming";

33+ license = stdenv.lib.licenses.bsd3;

34+}

dep/reflex-platform/default.nixdeleted−7

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

1−# DO NOT HAND-EDIT THIS FILE

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

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

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

5− private = json.private or false;

6− }

7−))

dep/reflex-platform/github.jsondeleted−7

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

1−{

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

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

4− "branch": "develop",

5− "rev": "f628398d076243a0851b27e625b37f65dff9b89b",

6− "sha256": "0sl0hf1glgyb1vmf2mhw4r9ipmcqk1y19d3wsic7dix2jwywzrh9"

7−}

reflex.cabal+61−324

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

1Name: reflex

2−Version: 0.8.2.0

2+Version: 0.5.0

3Synopsis: Higher-order Functional Reactive Programming

4−Description:

5− Interactive programs without callbacks or side-effects.

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

7− values to describe interactive systems as pure functions.

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

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

10− .

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

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

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

13− .

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

15License: BSD3

5License: BSD3

16License-file: LICENSE

6License-file: LICENSE

17Author: Ryan Trinkle

7Author: Ryan Trinkle

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

19Stability: Experimental

9Stability: Experimental

20Category: FRP

10Category: FRP

21Build-type: Simple

11Build-type: Simple

22−Cabal-version: 1.22

12+Cabal-version: >=1.9.2

23−homepage: https://reflex-frp.org

13+homepage: https://github.com/reflex-frp/reflex

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

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

25−extra-source-files:

26− README.md

27− Quickref.md

28− ChangeLog.md

30−tested-with:

16+flag specialize-to-spidertimeline-global

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

17+ description: Specialize all Reflex functions to the SpiderTimeline Global implementation. This may improve performance, but will disable all other implementations.

32− GHCJS ==8.6

18+ default: False

19+ manual: True

34flag use-reflex-optimizer

21flag use-reflex-optimizer

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

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

@@ -41,168 +28,99 @@ flag use-template-haskell

41 default: True

28 default: True

42 manual: True

29 manual: True

44−flag debug-trace-events

31+flag expose-all-unfoldings

45− description: Add instrumentation that outputs the stack trace of the definition of an event whenever it is subscribed to. Warning: It is very slow!

32+ description: Build the library with -fexpose-all-unfoldings which can help client code specialize better

46 default: False

33 default: False

47 manual: True

34 manual: True

49−flag fast-weak

36+flag debug-trace-events

50− description: Use the primitive implementation of FastWeak in GHCJS; note that this requires GHCJS to be built with FastWeak and FastWeakBag present in the RTS, which is not the default

37+ description: add instrumentation that outputs the stack trace of the definition of an event whenever it is subscribed to. Warning: It is very slow!

51− default: False

52− manual: True

53−

54−flag debug-propagation

55− description: Enable debugging of spider internals

56− default: False

57− manual: True

58−

59−flag debug-cycles

60− description: Enable debugging of event cycles

61 default: False

38 default: False

62 manual: True

39 manual: True

64−flag split-these

65− description: Use split these/semialign packages

66− manual: False

67− default: True

68−

69library

41library

70− default-language: Haskell2010

71 hs-source-dirs: src

42 hs-source-dirs: src

72 build-depends:

43 build-depends:

73 MemoTrie == 0.6.*,

44 MemoTrie == 0.6.*,

74− base >= 4.11 && < 4.15,

45+ base >= 4.7 && < 4.11,

75− bifunctors >= 5.2 && < 5.6,

46+ bifunctors >= 5.2 && < 5.5,

76− comonad >= 5.0.4 && < 5.1,

77− constraints >= 0.10 && <0.14,

78− constraints-extras >= 0.3 && < 0.4,

79− containers >= 0.6 && < 0.7,

47+ containers == 0.5.*,

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

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

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

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

82 exception-transformers == 0.4.*,

50 exception-transformers == 0.4.*,

83 lens >= 4.7 && < 5,

51 lens >= 4.7 && < 5,

84− mmorph >= 1.0 && < 1.2,

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

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

86 mtl >= 2.1 && < 2.3,

53 mtl >= 2.1 && < 2.3,

87− patch >= 0.0.1 && < 0.1,

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

54+ prim-uniq >= 0.1.0.1 && < 0.2,

89− primitive >= 0.5 && < 0.8,

55+ primitive >= 0.5 && < 0.7,

90− profunctors >= 5.3 && < 5.7,

91− random == 1.1.*,

92 ref-tf == 0.4.*,

56 ref-tf == 0.4.*,

93 reflection == 2.1.*,

57 reflection == 2.1.*,

94 semigroupoids >= 4.0 && < 6,

58 semigroupoids >= 4.0 && < 6,

59+ semigroups >= 0.16 && < 0.19,

95− stm >= 2.4 && < 2.6,

60+ stm == 2.4.*,

96− syb >= 0.5 && < 0.8,

61+ syb >= 0.5 && < 0.7,

97− time >= 1.4 && < 1.10,

62+ these >= 0.4 && < 0.8,

98− transformers >= 0.5.6.0 && < 0.6,

63+ transformers >= 0.2,

99− unbounded-delays >= 0.1.0.0 && < 0.2,

64+ transformers-compat >= 0.3

100− witherable >= 0.3 && < 0.5

101−

102− if flag(split-these)

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

104− semialign >=1 && <1.2,

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

106− else

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

108− monoidal-containers == 0.4.0.0

109

110 exposed-modules:

66 exposed-modules:

111− Control.Monad.ReaderIO

67+ Data.Functor.Misc,

112− Data.AppendMap,

113− Data.FastMutableIntMap,

114− Data.FastWeakBag,

115− Data.Map.Misc,

116 Data.WeakBag,

68 Data.WeakBag,

117 Reflex,

69 Reflex,

118 Reflex.Class,

70 Reflex.Class,

119− Reflex.Adjustable.Class,

71+ Reflex.EventWriter,

120− Reflex.BehaviorWriter.Base,

121− Reflex.BehaviorWriter.Class,

122− Reflex.Collection,

123 Reflex.Dynamic,

72 Reflex.Dynamic,

124 Reflex.Dynamic.Uniq,

73 Reflex.Dynamic.Uniq,

125 Reflex.DynamicWriter,

74 Reflex.DynamicWriter,

126− Reflex.DynamicWriter.Base,

127− Reflex.DynamicWriter.Class,

128− Reflex.EventWriter,

129− Reflex.EventWriter.Base,

130− Reflex.EventWriter.Class,

131− Reflex.FastWeak,

132 Reflex.FunctorMaybe,

75 Reflex.FunctorMaybe,

133 Reflex.Host.Class,

76 Reflex.Host.Class,

134− Reflex.Host.Headless,

77+ Reflex.Patch,

135− Reflex.Network,

78+ Reflex.TriggerEvent.Base,

136− Reflex.NotReady.Class,

79+ Reflex.TriggerEvent.Class,

137 Reflex.PerformEvent.Base,

80 Reflex.PerformEvent.Base,

138 Reflex.PerformEvent.Class,

81 Reflex.PerformEvent.Class,

139 Reflex.PostBuild.Base,

82 Reflex.PostBuild.Base,

140 Reflex.PostBuild.Class,

83 Reflex.PostBuild.Class,

141− Reflex.Profiled,

142− Reflex.Pure,

143− Reflex.Query.Base,

144− Reflex.Query.Class,

145 Reflex.Requester.Base,

84 Reflex.Requester.Base,

146 Reflex.Requester.Class,

85 Reflex.Requester.Class,

147 Reflex.Spider,

86 Reflex.Spider,

148− Reflex.Spider.Internal,

87+ Reflex.Spider.Internal

149− Reflex.Time,

150− Reflex.TriggerEvent.Base,

151− Reflex.TriggerEvent.Class,

152− Reflex.Widget.Basic,

153− Reflex.Workflow

154

155− reexported-modules:

89+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2

156− patch:Data.Functor.Misc,

90+ ghc-prof-options: -fprof-auto

157− patch:Data.Patch as Reflex.Patch,

158− patch:Data.Patch.Class as Reflex.Patch.Class,

159− patch:Data.Patch.DMap as Reflex.Patch.DMap,

160− patch:Data.Patch.DMapWithMove as Reflex.Patch.DMapWithMove,

161− patch:Data.Patch.IntMap as Reflex.Patch.IntMap,

162− patch:Data.Patch.Map as Reflex.Patch.Map,

163− patch:Data.Patch.MapWithMove as Reflex.Patch.MapWithMove

164

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

92+ if flag(specialize-to-spidertimeline-global)

93+ cpp-options: -DSPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

94+ else

95+ exposed-modules: Reflex.Pure

166

167 if flag(debug-trace-events)

97 if flag(debug-trace-events)

168 cpp-options: -DDEBUG_TRACE_EVENTS

98 cpp-options: -DDEBUG_TRACE_EVENTS

169− build-depends:

99+ build-depends: bytestring

170− bytestring >= 0.10.8 && < 0.11

171

100

172 if flag(use-reflex-optimizer)

101 if flag(use-reflex-optimizer)

173 cpp-options: -DUSE_REFLEX_OPTIMIZER

102 cpp-options: -DUSE_REFLEX_OPTIMIZER

174 build-depends: ghc

103 build-depends: ghc

175 exposed-modules: Reflex.Optimizer

104 exposed-modules: Reflex.Optimizer

176

105

177− if flag(debug-propagation)

178− cpp-options: -DDEBUG -DDEBUG_TRACE_PROPAGATION -DDEBUG_TRACE_INVALIDATION

179−

180− if flag(debug-cycles)

181− cpp-options: -DDEBUG_CYCLES

182−

183 if flag(use-template-haskell)

106 if flag(use-template-haskell)

184 cpp-options: -DUSE_TEMPLATE_HASKELL

107 cpp-options: -DUSE_TEMPLATE_HASKELL

185 build-depends:

108 build-depends:

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

109+ dependent-sum >= 0.3 && < 0.5,

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

110+ haskell-src-exts >= 1.16 && < 1.18,

188− haskell-src-meta >= 0.6 && < 0.9,

111+ haskell-src-meta == 0.6.*,

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

112+ template-haskell >= 2.9 && < 2.12

190 exposed-modules:

113 exposed-modules:

191 Reflex.Dynamic.TH

114 Reflex.Dynamic.TH

192 other-extensions: TemplateHaskell

115 other-extensions: TemplateHaskell

193 else

116 else

194 build-depends:

117 build-depends:

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

118+ dependent-sum == 0.4.*

196

119

197− if flag(fast-weak) && impl(ghcjs)

120+ if flag(expose-all-unfoldings)

198− cpp-options: -DGHCJS_FAST_WEAK

121+ ghc-options: -fexpose-all-unfoldings

199−

200− if impl(ghcjs)

201− build-depends:

202− ghcjs-base == 0.2.*

203

122

204test-suite semantics

123test-suite semantics

205− default-language: Haskell2010

206 type: exitcode-stdio-1.0

124 type: exitcode-stdio-1.0

207 main-is: semantics.hs

125 main-is: semantics.hs

208 hs-source-dirs: test

126 hs-source-dirs: test

@@ -211,273 +129,96 @@ test-suite semantics

211 base,

129 base,

212 bifunctors,

130 bifunctors,

213 containers,

131 containers,

214− deepseq,

132+ deepseq >= 1.3 && < 1.5,

215 dependent-map,

133 dependent-map,

216 dependent-sum,

134 dependent-sum,

217 mtl,

135 mtl,

218 ref-tf,

136 ref-tf,

219 reflex,

137 reflex,

220 split,

138 split,

221− transformers

139+ transformers >= 0.3

222− other-modules:

140+ if flag(specialize-to-spidertimeline-global)

223− Reflex.Bench.Focused

141+ buildable: False

224− Reflex.Plan.Pure

225− Reflex.Plan.Reflex

226− Reflex.Test

227− Reflex.Test.Micro

228− Reflex.TestPlan

229−

230−test-suite CrossImpl

231− default-language: Haskell2010

232− type: exitcode-stdio-1.0

233− main-is: Reflex/Test/CrossImpl.hs

234− hs-source-dirs: test

235− ghc-options: -O2 -Wall -rtsopts

236− build-depends:

237− base,

238− containers,

239− dependent-map,

240− dependent-sum,

241− deepseq,

242− mtl,

243− transformers,

244− ref-tf,

245− reflex

246− other-modules:

247− Reflex.Test

248− Reflex.TestPlan

249− Reflex.Plan.Reflex

250− Reflex.Plan.Pure

251

142

252test-suite hlint

143test-suite hlint

253− default-language: Haskell2010

254 type: exitcode-stdio-1.0

144 type: exitcode-stdio-1.0

255 main-is: hlint.hs

145 main-is: hlint.hs

256 hs-source-dirs: test

146 hs-source-dirs: test

257− build-depends: base

147+ build-depends: base, hlint == 1.9.*

258− , directory

259− , filepath

260− , filemanip

261− if impl(ghc >= 8.8)

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

263− else

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

265 if impl(ghcjs)

148 if impl(ghcjs)

266 buildable: False

149 buildable: False

267

150

268test-suite EventWriterT

151test-suite EventWriterT

269− default-language: Haskell2010

270 type: exitcode-stdio-1.0

152 type: exitcode-stdio-1.0

271 main-is: EventWriterT.hs

153 main-is: EventWriterT.hs

272 hs-source-dirs: test

154 hs-source-dirs: test

273 build-depends: base

155 build-depends: base

274− , containers

275− , deepseq

276− , dependent-map

277 , dependent-sum

156 , dependent-sum

278− , lens

279− , mtl

280− , these

281 , transformers

157 , transformers

282 , reflex

158 , reflex

283 , ref-tf

159 , ref-tf

284

160

285− if flag(split-these)

286− build-depends: these-lens

287−

288− other-modules:

289− Test.Run

290−

291−

292−test-suite DebugCycles

293− default-language: Haskell2010

294− type: exitcode-stdio-1.0

295− main-is: DebugCycles.hs

296− hs-source-dirs: test

297− ghc-options: -threaded

298− build-depends: base

299− , containers

300− , deepseq

301− , dependent-map

302− , dependent-sum

303− , hspec

304− , lens

305− , mtl

306− , these

307− , transformers

308− , reflex

309− , ref-tf

310− , witherable

311− , proctest

312−

313−

314− if flag(split-these)

315− build-depends: these-lens, semialign

316−

317− other-modules:

318− Test.Run

319−

320−

321test-suite RequesterT

161test-suite RequesterT

322− default-language: Haskell2010

323 type: exitcode-stdio-1.0

162 type: exitcode-stdio-1.0

324 main-is: RequesterT.hs

163 main-is: RequesterT.hs

325 hs-source-dirs: test

164 hs-source-dirs: test

326 build-depends: base

165 build-depends: base

327− , constraints

328− , constraints-extras

329− , containers

330− , deepseq

331− , dependent-map

332 , dependent-sum

166 , dependent-sum

333− , lens

167+ , dependent-map

334− , mtl

335− , ref-tf

336− , reflex

337− , text

338− , these

339 , transformers

168 , transformers

340−

341− if flag(split-these)

342− build-depends: these-lens

343−

344− other-modules:

345− Reflex.TestPlan

346− Reflex.Plan.Pure

347− Test.Run

348−

349−test-suite Headless

350− default-language: Haskell2010

351− type: exitcode-stdio-1.0

352− main-is: Headless.hs

353− hs-source-dirs: test

354− build-depends: base

355− , reflex

356−

357−test-suite Adjustable

358− default-language: Haskell2010

359− type: exitcode-stdio-1.0

360− main-is: Adjustable.hs

361− hs-source-dirs: test

362− build-depends: base

363− , containers

364− , dependent-sum

365 , reflex

169 , reflex

366 , ref-tf

170 , ref-tf

367− , these

368−

369− other-modules:

370− Test.Run

371−

372−test-suite QueryT

373− default-language: Haskell2010

374− type: exitcode-stdio-1.0

375− main-is: QueryT.hs

376− hs-source-dirs: test

377− build-depends: base

378− , containers

379− , dependent-map

380− , dependent-sum

381− , deepseq

382− , lens

383− , monoidal-containers

384− , mtl

385− , patch

386− , ref-tf

387− , reflex

388− , these

389− , transformers

390−

391− if flag(split-these)

392− build-depends: semialign, these-lens

393−

394− other-modules:

395− Test.Run

396− Reflex.TestPlan

397− Reflex.Plan.Reflex

398− Reflex.Plan.Pure

399

171

400test-suite GC-Semantics

172test-suite GC-Semantics

401− default-language: Haskell2010

402 type: exitcode-stdio-1.0

173 type: exitcode-stdio-1.0

403 main-is: GC.hs

174 main-is: GC.hs

404 hs-source-dirs: test

175 hs-source-dirs: test

176+ if flag(specialize-to-spidertimeline-global)

177+ buildable: False

405 build-depends: base

178 build-depends: base

406− , containers

407 , dependent-sum

179 , dependent-sum

408 , dependent-map

180 , dependent-map

409− , deepseq

410− , mtl

411− , patch

412 , these

181 , these

413 , transformers

182 , transformers

414 , reflex

183 , reflex

415 , ref-tf

184 , ref-tf

416

185

417− if flag(split-these)

418− build-depends: semialign

419−

420− other-modules:

421− Reflex.Plan.Pure

422− Reflex.Plan.Reflex

423− Reflex.TestPlan

424− Test.Run

425−

426test-suite rootCleanup

186test-suite rootCleanup

427− default-language: Haskell2010

428 type: exitcode-stdio-1.0

187 type: exitcode-stdio-1.0

429 main-is: rootCleanup.hs

188 main-is: rootCleanup.hs

430 hs-source-dirs: test

189 hs-source-dirs: test

431 build-depends: base

190 build-depends: base

432− , containers

433− , deepseq

434− , dependent-sum

435− , mtl

436 , reflex

191 , reflex

437− , ref-tf

438− , these

439− other-modules:

440− Reflex.Plan.Pure

441− Reflex.TestPlan

442− Test.Run

443

192

444benchmark spider-bench

193benchmark spider-bench

445− default-language: Haskell2010

446 type: exitcode-stdio-1.0

194 type: exitcode-stdio-1.0

447− hs-source-dirs: bench test

195+ hs-source-dirs: bench

448 main-is: Main.hs

196 main-is: Main.hs

449 ghc-options: -Wall -O2 -rtsopts

197 ghc-options: -Wall -O2 -rtsopts

450 build-depends:

198 build-depends:

451 base,

199 base,

452− containers,

453− criterion,

200+ criterion == 1.1.*,

454− deepseq,

201+ deepseq >= 1.3 && < 1.5,

455 dependent-map,

202 dependent-map,

456 dependent-sum,

203 dependent-sum,

457− ref-tf,

458 mtl,

204 mtl,

459 primitive,

205 primitive,

460 reflex,

206 reflex,

461− split,

462 stm,

207 stm,

463− transformers

208+ transformers >= 0.3

464− other-modules:

465− Reflex.TestPlan

466− Reflex.Plan.Reflex

467− Reflex.Bench.Focused

468

209

469benchmark saulzar-bench

210benchmark saulzar-bench

470− default-language: Haskell2010

471 type: exitcode-stdio-1.0

211 type: exitcode-stdio-1.0

472 hs-source-dirs: bench test

212 hs-source-dirs: bench test

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

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

474 main-is: RunAll.hs

214 main-is: RunAll.hs

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

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

216+ ghc-prof-options: -fprof-auto

476 build-depends:

217 build-depends:

477 base,

218 base,

478− containers,

219+ containers == 0.5.*,

479− criterion,

220+ criterion == 1.1.*,

480− deepseq,

221+ deepseq >= 1.3 && < 1.5,

481 dependent-map,

222 dependent-map,

482 dependent-sum,

223 dependent-sum,

483 loch-th,

224 loch-th,

@@ -489,11 +230,7 @@ benchmark saulzar-bench

489 split,

230 split,

490 stm,

231 stm,

491 time,

232 time,

492− transformers

233+ transformers >= 0.3

493− other-modules:

494− Reflex.TestPlan

495− Reflex.Plan.Reflex

496− Reflex.Bench.Focused

497

234

498source-repository head

235source-repository head

499 type: git

236 type: git

release.nixdeleted−58

@@ -1,58 +0,0 @@

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

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

3−}:

4−

5−let

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

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

8−

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

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

11− compilers = [

12− "ghc"

13− "ghcjs"

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

15− "ghcAndroidAarch64"

16− "ghcAndroidAarch32"

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

18− "ghcIosAarch64"

19− ];

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

21− "-dontUseTemplateHaskell"

22− ""

23− ];

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

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

26− reflex-platform = reflex-platform-fun {

27− inherit system;

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

29− haskellOverlays = [

30− # Use this package's source for reflex

31− (self: super: {

32− _dep = super._dep // {

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

34− "release.nix"

35− ".git"

36− "dist"

37− "cabal.haskell-ci"

38− "cabal.project"

39− ".travis.yml"

40− ])) ./.;

41− };

42− })

43− ];

44− };

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

46− in variationPkgs // {

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

48− (builtins.attrValues variationPkgs);

49− });

50− in compilerPkgs // {

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

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

53− });

54−

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

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

57−

58−in perPlatform // { inherit metaCache; }

src/Control/Monad/ReaderIO.hsdeleted−60

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

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.hsdeleted−84

@@ -1,84 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE FlexibleInstances #-}

4−{-# LANGUAGE MultiParamTypeClasses #-}

5−{-# LANGUAGE PatternSynonyms #-}

6−{-# LANGUAGE RoleAnnotations #-}

7−{-# LANGUAGE ScopedTypeVariables #-}

8−{-# LANGUAGE TypeFamilies #-}

9−{-# OPTIONS_GHC -fno-warn-orphans #-}

10−-- |

11−-- Module:

12−-- Data.AppendMap

13−-- Description:

14−-- Instances and convenience functions for 'Data.Map.Monoidal'. We use

15−-- monoidal-containers to take advantage of its better monoid instance.

16−-- 'Data.Map' has @mappend = union@, which is left-biased. 'MonoidalMap'

17−-- has @mappend = unionWith mappend@ instead.

18−module Data.AppendMap

19− ( module Data.AppendMap

20− , module Data.Map.Monoidal

21− ) where

22−

23−import Prelude hiding (null)

24−

25−import Data.Coerce

26−import Data.Default

27−import Data.Map (Map)

28−#if MIN_VERSION_containers(0,5,11)

29−import qualified Data.Map.Internal.Debug as Map (showTree, showTreeWith)

30−#else

31−import qualified Data.Map as Map (showTree, showTreeWith)

32−#endif

33−import qualified Data.Witherable as W

34−import Data.Map.Monoidal

35−import qualified Data.Map.Monoidal as MonoidalMap

36−

37−

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

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

40−type AppendMap = MonoidalMap

41−

42−{-# DEPRECATED _unAppendMap "Use 'getMonoidalMap' instead" #-}

43−-- | A synonym for 'getMonoidalMap'

44−_unAppendMap :: MonoidalMap k v -> Map k v

45−_unAppendMap = getMonoidalMap

46−

47−-- | Pattern synonym for 'MonoidalMap'

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

49−pattern AppendMap m = MonoidalMap m

50−

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

52−instance W.Filterable (MonoidalMap k) where

53− mapMaybe = MonoidalMap.mapMaybe

54−#endif

55−

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

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

58−nonEmptyDelete k vs =

59− let deleted = delete k vs

60− in if null deleted

61− then Nothing

62− else Just deleted

63−

64−-- | Like 'mapMaybe' but indicates whether the resulting container is empty

65−mapMaybeNoNull :: (a -> Maybe b)

66− -> MonoidalMap token a

67− -> Maybe (MonoidalMap token b)

68−mapMaybeNoNull f as =

69− let bs = mapMaybe f as

70− in if null bs

71− then Nothing

72− else Just bs

73−

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

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

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

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

78−

79−-- | Displays a 'MonoidalMap' as a tree, using the supplied function to convert nodes to string.

80−showTreeWith :: forall k a. (k -> a -> String) -> Bool -> Bool -> MonoidalMap k a -> String

81−showTreeWith = coerce (Map.showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String)

82−

83−instance Default (MonoidalMap k a) where

84− def = empty

src/Data/FastMutableIntMap.hsdeleted−97

@@ -1,97 +0,0 @@

1−{-# LANGUAGE TypeFamilies #-}

2−-- |

3−-- Module:

4−-- Data.FastMutableIntMap

5−-- Description:

6−-- A mutable version of 'IntMap'

7−module Data.FastMutableIntMap

8− ( FastMutableIntMap

9− , new

10− , newEmpty

11− , insert

12− , isEmpty

13− , getFrozenAndClear

14− , size

15− , applyPatch

16− , PatchIntMap (..)

17− , traverseIntMapPatchWithKey

18− , lookup

19− , forIntersectionWithImmutable_

20− , for_

21− , patchIntMapNewElements

22− , patchIntMapNewElementsMap

23− , getDeletions

24− , toList

25− ) where

26−

27−--TODO: Pure JS version

28−--TODO: Fast copy to FastIntMap

29−--TODO: Fast patch type

30−

31−import Prelude hiding (lookup)

32−

33−import Control.Monad.IO.Class

34−import Data.Foldable (traverse_)

35−import Data.IntMap.Strict (IntMap)

36−import qualified Data.IntMap.Strict as IntMap

37−import Data.IORef

38−import Data.Patch.Class

39−import Data.Patch.IntMap

40−

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

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

43−newtype FastMutableIntMap a = FastMutableIntMap (IORef (IntMap a))

44−

45−-- | Create a new 'FastMutableIntMap' out of an 'IntMap'

46−new :: IntMap a -> IO (FastMutableIntMap a)

47−new m = FastMutableIntMap <$> newIORef m

48−

49−-- | Create a new empty 'FastMutableIntMap'

50−newEmpty :: IO (FastMutableIntMap a)

51−newEmpty = FastMutableIntMap <$> newIORef IntMap.empty

52−

53−-- | Insert an element into a 'FastMutableIntMap' at the given key

54−insert :: FastMutableIntMap a -> Int -> a -> IO ()

55−insert (FastMutableIntMap r) k v = modifyIORef' r $ IntMap.insert k v

56−

57−-- | Attempt to lookup an element by key in a 'FastMutableIntMap'

58−lookup :: FastMutableIntMap a -> Int -> IO (Maybe a)

59−lookup (FastMutableIntMap r) k = IntMap.lookup k <$> readIORef r

60−

61−-- | Runs the provided action over the intersection of a 'FastMutableIntMap' and an 'IntMap'

62−forIntersectionWithImmutable_ :: MonadIO m => FastMutableIntMap a -> IntMap b -> (a -> b -> m ()) -> m ()

63−forIntersectionWithImmutable_ (FastMutableIntMap r) b f = do

64− a <- liftIO $ readIORef r

65− traverse_ (uncurry f) $ IntMap.intersectionWith (,) a b

66−

67−-- | Runs the provided action over the values of a 'FastMutableIntMap'

68−for_ :: MonadIO m => FastMutableIntMap a -> (a -> m ()) -> m ()

69−for_ (FastMutableIntMap r) f = do

70− a <- liftIO $ readIORef r

71− traverse_ f a

72−

73−-- | Checks whether a 'FastMutableIntMap' is empty

74−isEmpty :: FastMutableIntMap a -> IO Bool

75−isEmpty (FastMutableIntMap r) = IntMap.null <$> readIORef r

76−

77−-- | Retrieves the size of a 'FastMutableIntMap'

78−size :: FastMutableIntMap a -> IO Int

79−size (FastMutableIntMap r) = IntMap.size <$> readIORef r

80−

81−-- | Make an immutable snapshot of the datastructure and clear it

82−getFrozenAndClear :: FastMutableIntMap a -> IO (IntMap a)

83−getFrozenAndClear (FastMutableIntMap r) = do

84− result <- readIORef r

85− writeIORef r IntMap.empty

86− return result

87−

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

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

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

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

92− v <- readIORef r

93− writeIORef r $! applyAlways p v

94− return $ IntMap.intersection v m

95−

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

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

src/Data/FastWeakBag.hsdeleted−161

@@ -1,161 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE ExistentialQuantification #-}

3−#ifdef USE_REFLEX_OPTIMIZER

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

5−#endif

6−#ifdef GHCJS_FAST_WEAK

7−{-# LANGUAGE ForeignFunctionInterface #-}

8−{-# LANGUAGE JavaScriptFFI #-}

9−#endif

10−-- | This module defines the 'FastWeakBag' type, which represents a mutable

11−-- collection of items that does not cause the items to be retained in memory.

12−-- This is useful for situations where a value needs to be inspected or modified

13−-- if it is still alive, but can be ignored if it is dead.

14−module Data.FastWeakBag

15− ( FastWeakBag

16− , FastWeakBagTicket

17− , empty

18− , isEmpty

19− , insert

20− , traverse

21− , traverse_

22− , remove

23− -- * Internal functions

24− -- These will not always be available.

25−#ifndef GHCJS_FAST_WEAK

26− , _weakBag_children --TODO: Don't export this

27−#endif

28− ) where

29−

30−import Prelude hiding (traverse)

31−

32−import Control.Monad

33−import Control.Monad.IO.Class

34−

35−#ifdef GHCJS_FAST_WEAK

36−import GHCJS.Types

37−import Reflex.FastWeak (js_isNull, unsafeFromRawJSVal, unsafeToRawJSVal)

38−#else

39−import Control.Exception

40−import Data.IntMap.Strict (IntMap)

41−import qualified Data.IntMap.Strict as IntMap

42−import Data.IORef

43−import System.Mem.Weak

44−#endif

45−

46−-- | A 'FastWeakBag' holds a set of values of type @/a/@, but does not retain them -

47−-- that is, they can still be garbage-collected. As long as the @/a/@ values remain

48−-- alive, the 'FastWeakBag' will continue to refer to them.

49−#ifdef GHCJS_FAST_WEAK

50−newtype FastWeakBag a = FastWeakBag JSVal

51−#else

52−data FastWeakBag a = FastWeakBag

53− { _weakBag_nextId :: {-# UNPACK #-} !(IORef Int) --TODO: what if this wraps around?

54− , _weakBag_children :: {-# UNPACK #-} !(IORef (IntMap (Weak a))) -- ^ Map of items contained by the 'FastWeakBag'

55− }

56−#endif

57−

58−-- | When inserting an item into a 'FastWeakBag', a 'FastWeakBagTicket' is returned. If

59−-- the caller retains the ticket, the item is guranteed to stay in memory (and

60−-- thus in the 'FastWeakBag'). The ticket can also be used to remove the item from

61−-- the 'FastWeakBag' prematurely (i.e. while it is still alive), using 'remove'.

62−#ifdef GHCJS_FAST_WEAK

63−newtype FastWeakBagTicket a = FastWeakBagTicket JSVal

64−#else

65−data FastWeakBagTicket a = FastWeakBagTicket

66− { _weakBagTicket_weakItem :: {-# UNPACK #-} !(Weak a)

67− , _weakBagTicket_item :: {-# NOUNPACK #-} !a

68− }

69−#endif

70−

71−-- | Insert an item into a 'FastWeakBag'.

72−{-# INLINE insert #-}

73−insert :: a -- ^ The item

74− -> FastWeakBag a -- ^ The 'FastWeakBag' to insert into

75− -> IO (FastWeakBagTicket a) -- ^ Returns a 'FastWeakBagTicket' that ensures the item

76− -- is retained and allows the item to be removed.

77−#ifdef GHCJS_FAST_WEAK

78−insert a wb = js_insert (unsafeToRawJSVal a) wb

79−foreign import javascript unsafe "$r = new h$FastWeakBagTicket($2, $1);" js_insert :: JSVal -> FastWeakBag a -> IO (FastWeakBagTicket a)

80−#else

81−insert a (FastWeakBag nextId children) = {-# SCC "insert" #-} do

82− a' <- evaluate a

83− myId <- atomicModifyIORef' nextId $ \n -> (succ n, n)

84− let cleanup = atomicModifyIORef' children $ \cs -> (IntMap.delete myId cs, ())

85− wa <- mkWeakPtr a' $ Just cleanup

86− atomicModifyIORef' children $ \cs -> (IntMap.insert myId wa cs, ())

87− return $ FastWeakBagTicket

88− { _weakBagTicket_weakItem = wa

89− , _weakBagTicket_item = a'

90− }

91−#endif

92−

93−-- | Create an empty 'FastWeakBag'.

94−{-# INLINE empty #-}

95−empty :: IO (FastWeakBag a)

96−#ifdef GHCJS_FAST_WEAK

97−empty = js_empty

98−foreign import javascript unsafe "$r = new h$FastWeakBag();" js_empty :: IO (FastWeakBag a)

99−#else

100−empty = {-# SCC "empty" #-} do

101− nextId <- newIORef 1

102− children <- newIORef IntMap.empty

103− let bag = FastWeakBag

104− { _weakBag_nextId = nextId

105− , _weakBag_children = children

106− }

107− return bag

108−#endif

109−

110−-- | Check whether a 'FastWeakBag' is empty.

111−{-# INLINE isEmpty #-}

112−isEmpty :: FastWeakBag a -> IO Bool

113−#ifdef GHCJS_FAST_WEAK

114−isEmpty = js_isEmpty

115−foreign import javascript unsafe "(function(){ for(var i = 0; i < $1.tickets.length; i++) { if($1.tickets[i] !== null) { return false; } }; return true; })()" js_isEmpty :: FastWeakBag a -> IO Bool --TODO: Clean up as we go along so this isn't O(n) every time

116−#else

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

118−#endif

119−

120−{-# INLINE traverse_ #-}

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

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

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

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

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

126−#ifdef GHCJS_FAST_WEAK

127−traverse_ wb f = do

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

129− val <- liftIO $ js_getTicketValue cursor

130− f $ unsafeFromRawJSVal val

131− go =<< liftIO (js_getNext (FastWeakBagTicket cursor))

132− go =<< liftIO (js_getInitial wb)

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

134−foreign import javascript unsafe "$r = $1.val;" js_getTicketValue :: JSVal -> IO JSVal

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

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

137−#else

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

139− cs <- liftIO $ readIORef children

140− forM_ cs $ \c -> do

141− ma <- liftIO $ deRefWeak c

142− mapM_ f ma

143−#endif

144−

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

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

147−traverse = traverse_

148−

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

150−-- on the same 'FastWeakBagTicket'.

151−{-# INLINE remove #-}

152−remove :: FastWeakBagTicket a -> IO ()

153−#ifdef GHCJS_FAST_WEAK

154−remove = js_remove

155−foreign import javascript unsafe "$1.bag.tickets[$1.pos] = null; $1.bag = new h$FastWeakBag(); $1.bag.tickets.push($1); $1.pos = 0;" js_remove :: FastWeakBagTicket a -> IO () --TODO: Don't bother with the new surrogate FastWeakBag; instead, make the GC check for bag === null, and then null it out here

156−#else

157−remove (FastWeakBagTicket w _) = {-# SCC "remove" #-} finalize w

158−#endif

159−--TODO: Should 'remove' also drop the reference to the item?

160−

161−--TODO: can/should we provide a null FastWeakBagTicket?

src/Data/Functor/Misc.hsnew file+237

@@ -0,0 +1,237 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DeriveDataTypeable #-}

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE GADTs #-}

6+{-# LANGUAGE KindSignatures #-}

7+{-# LANGUAGE LambdaCase #-}

8+{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE PolyKinds #-}

10+{-# LANGUAGE RankNTypes #-}

11+{-# LANGUAGE ScopedTypeVariables #-}

12+{-# LANGUAGE StandaloneDeriving #-}

13+#ifdef USE_REFLEX_OPTIMIZER

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

15+#endif

16+-- | This module provides types and functions with no particular theme, but

17+-- which are relevant to the use of 'Functor'-based datastructures like

18+-- 'Data.Dependent.Map.DMap'.

19+module Data.Functor.Misc

20+ ( -- * Const2

21+ Const2 (..)

22+ , dmapToMap

23+ , dmapToMapWith

24+ , mapToDMap

25+ , weakenDMapWith

26+ -- * WrapArg

27+ , WrapArg (..)

28+ -- * Convenience functions for DMap

29+ , mapWithFunctorToDMap

30+ , mapKeyValuePairsMonotonic

31+ , combineDMapsWithKey

32+ , EitherTag (..)

33+ , dmapToThese

34+ , eitherToDSum

35+ , dsumToEither

36+ -- * Deprecated functions

37+ , sequenceDmap

38+ , wrapDMap

39+ , rewrapDMap

40+ , unwrapDMap

41+ , unwrapDMapMaybe

42+ , extractFunctorDMap

43+ ) where

44+

45+import Control.Applicative (Applicative, (<$>))

46+import Control.Monad.Identity

47+import Data.Dependent.Map (DMap)

48+import qualified Data.Dependent.Map as DMap

49+import Data.Dependent.Sum

50+import Data.GADT.Compare

51+import Data.GADT.Show

52+import Data.Map (Map)

53+import qualified Data.Map as Map

54+import Data.Some (Some)

55+import qualified Data.Some as Some

56+import Data.These

57+import Data.Typeable hiding (Refl)

58+

59+--------------------------------------------------------------------------------

60+-- Const2

61+--------------------------------------------------------------------------------

62+

63+-- | 'Const2' stores a value of a given type 'k' and ensures that a particular

64+-- type 'v' is always given for the last type parameter

65+data Const2 :: * -> x -> x -> * where

66+ Const2 :: k -> Const2 k v v

67+ deriving (Typeable)

68+

69+deriving instance Show k => Show (Const2 k v v)

70+

71+instance Show k => GShow (Const2 k v) where

72+ gshowsPrec n x@(Const2 _) = showsPrec n x

73+

74+instance (Show k, Show (f v)) => ShowTag (Const2 k v) f where

75+ showTaggedPrec (Const2 _) = showsPrec

76+

77+instance Eq k => GEq (Const2 k v) where

78+ geq (Const2 a) (Const2 b) =

79+ if a == b

80+ then Just Refl

81+ else Nothing

82+

83+instance Ord k => GCompare (Const2 k v) where

84+ gcompare (Const2 a) (Const2 b) = case compare a b of

85+ LT -> GLT

86+ EQ -> GEQ

87+ GT -> GGT

88+

89+-- | Convert a 'DMap' to a regular 'Map'

90+dmapToMap :: DMap (Const2 k v) Identity -> Map k v

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

92+

93+dmapToMapWith :: (f v -> v') -> DMap (Const2 k v) f -> Map k v'

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

95+

96+-- | Convert a regular 'Map' to a 'DMap'

97+mapToDMap :: Map k v -> DMap (Const2 k v) Identity

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

99+

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

101+-- to a 'DMap'

102+mapWithFunctorToDMap :: Map k (f v) -> DMap (Const2 k v) f

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

104+

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

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

107+

108+--------------------------------------------------------------------------------

109+-- WrapArg

110+--------------------------------------------------------------------------------

111+

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

113+-- representing another functor. This was primarily used with dependent-map <

114+-- 0.2, in which the value type was not wrapped in a separate functor.

115+data WrapArg :: (k -> *) -> (k -> *) -> * -> * where

116+ WrapArg :: f a -> WrapArg g f (g a)

117+

118+instance GEq f => GEq (WrapArg g f) where

119+ geq (WrapArg a) (WrapArg b) = (\Refl -> Refl) <$> geq a b

120+

121+instance GCompare f => GCompare (WrapArg g f) where

122+ gcompare (WrapArg a) (WrapArg b) = case gcompare a b of

123+ GLT -> GLT

124+ GEQ -> GEQ

125+ GGT -> GGT

126+

127+--------------------------------------------------------------------------------

128+-- Convenience functions for DMap

129+--------------------------------------------------------------------------------

130+

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

132+-- well as the value. The provided function MUST preserve the ordering of the

133+-- keys, or the resulting 'DMap' will be malformed.

134+mapKeyValuePairsMonotonic :: (DSum k v -> DSum k' v') -> DMap k v -> DMap k' v'

135+mapKeyValuePairsMonotonic f = DMap.fromDistinctAscList . map f . DMap.toAscList

136+

137+{-# INLINE combineDMapsWithKey #-}

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

139+-- is present in either input map will be present in the output.

140+combineDMapsWithKey :: forall f g h i.

141+ GCompare f

142+ => (forall a. f a -> These (g a) (h a) -> i a)

143+ -> DMap f g

144+ -> DMap f h

145+ -> DMap f i

146+combineDMapsWithKey f mg mh = DMap.fromList $ go (DMap.toList mg) (DMap.toList mh)

147+ where go :: [DSum f g] -> [DSum f h] -> [DSum f i]

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

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

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

151+ GLT -> (gk :=> f gk (This gv)) : go gs' hs

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

153+ GGT -> (hk :=> f hk (That hv)) : go gs hs'

154+

155+-- | Extract the values of a 'DMap' of 'EitherTag's.

156+dmapToThese :: DMap (EitherTag a b) Identity -> Maybe (These a b)

157+dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of

158+ (Nothing, Nothing) -> Nothing

159+ (Just (Identity a), Nothing) -> Just $ This a

160+ (Nothing, Just (Identity b)) -> Just $ That b

161+ (Just (Identity a), Just (Identity b)) -> Just $ These a b

162+

163+-- | Tag type for 'Either' to use it as a 'DSum'.

164+data EitherTag l r a where

165+ LeftTag :: EitherTag l r l

166+ RightTag :: EitherTag l r r

167+

168+instance GEq (EitherTag l r) where

169+ geq a b = case (a, b) of

170+ (LeftTag, LeftTag) -> Just Refl

171+ (RightTag, RightTag) -> Just Refl

172+ _ -> Nothing

173+

174+instance GCompare (EitherTag l r) where

175+ gcompare a b = case (a, b) of

176+ (LeftTag, LeftTag) -> GEQ

177+ (LeftTag, RightTag) -> GLT

178+ (RightTag, LeftTag) -> GGT

179+ (RightTag, RightTag) -> GEQ

180+

181+instance GShow (EitherTag l r) where

182+ gshowsPrec _ a = case a of

183+ LeftTag -> showString "LeftTag"

184+ RightTag -> showString "RightTag"

185+

186+instance (Show l, Show r) => ShowTag (EitherTag l r) Identity where

187+ showTaggedPrec t n (Identity a) = case t of

188+ LeftTag -> showsPrec n a

189+ RightTag -> showsPrec n a

190+

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

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

193+eitherToDSum = \case

194+ Left a -> (LeftTag :=> Identity a)

195+ Right b -> (RightTag :=> Identity b)

196+

197+-- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'.

198+dsumToEither :: DSum (EitherTag a b) Identity -> Either a b

199+dsumToEither = \case

200+ (LeftTag :=> Identity a) -> Left a

201+ (RightTag :=> Identity b) -> Right b

202+

203+--------------------------------------------------------------------------------

204+-- Deprecated functions

205+--------------------------------------------------------------------------------

206+

207+{-# INLINE sequenceDmap #-}

208+{-# DEPRECATED sequenceDmap "Use 'Data.Dependent.Map.traverseWithKey (\\_ t -> fmap Identity t)' instead" #-}

209+-- | Run the actions contained in the 'DMap'

210+sequenceDmap :: Applicative t => DMap f t -> t (DMap f Identity)

211+sequenceDmap = DMap.traverseWithKey $ \_ t -> Identity <$> t

212+

213+{-# DEPRECATED wrapDMap "Use 'Data.Dependent.Map.map (f . runIdentity)' instead" #-}

214+-- | Replace the 'Identity' functor for a 'DMap''s values with a different functor

215+wrapDMap :: (forall a. a -> f a) -> DMap k Identity -> DMap k f

216+wrapDMap f = DMap.map $ f . runIdentity

217+

218+{-# DEPRECATED rewrapDMap "Use 'Data.Dependent.Map.map' instead" #-}

219+-- | Replace one functor for a 'DMap''s values with a different functor

220+rewrapDMap :: (forall (a :: *). f a -> g a) -> DMap k f -> DMap k g

221+rewrapDMap = DMap.map

222+

223+{-# DEPRECATED unwrapDMap "Use 'Data.Dependent.Map.map (Identity . f)' instead" #-}

224+-- | Replace one functor for a 'DMap''s values with the 'Identity' functor

225+unwrapDMap :: (forall a. f a -> a) -> DMap k f -> DMap k Identity

226+unwrapDMap f = DMap.map $ Identity . f

227+

228+{-# DEPRECATED unwrapDMapMaybe "Use 'Data.Dependent.Map.mapMaybeWithKey (\\_ a -> fmap Identity $ f a)' instead" #-}

229+-- | Like 'unwrapDMap', but possibly delete some values from the DMap

230+unwrapDMapMaybe :: GCompare k => (forall a. f a -> Maybe a) -> DMap k f -> DMap k Identity

231+unwrapDMapMaybe f = DMap.mapMaybeWithKey $ \_ a -> Identity <$> f a

232+

233+{-# DEPRECATED extractFunctorDMap "Use 'mapKeyValuePairsMonotonic (\\(Const2 k :=> Identity v) -> Const2 k :=> v)' instead" #-}

234+-- | Eliminate the 'Identity' functor in a 'DMap' and replace it with the

235+-- underlying functor

236+extractFunctorDMap :: DMap (Const2 k (f v)) Identity -> DMap (Const2 k v) f

237+extractFunctorDMap = mapKeyValuePairsMonotonic $ \(Const2 k :=> Identity v) -> Const2 k :=> v

src/Data/Map/Misc.hsdeleted−71

@@ -1,71 +0,0 @@

1−{-# LANGUAGE LambdaCase #-}

2−-- | Additional functions for manipulating 'Map's.

3−module Data.Map.Misc

4− (

5− -- * Working with Maps

6− diffMapNoEq

7− , diffMap

8− , applyMap

9− , mapPartitionEithers

10− , applyMapKeysSet

11− ) where

12−

13−import Data.Align

14−import Data.Map (Map)

15−import qualified Data.Map as Map

16−import Data.Maybe

17−import Data.Set (Set)

18−import qualified Data.Set as Set

19−import Data.These

20−

21−-- |Produce a @'Map' k (Maybe v)@ by comparing two @'Map' k v@s, @old@ and @new@ respectively. @Just@ represents an association present in @new@ and @Nothing@

22−-- represents an association only present in @old@ but no longer present in @new@.

23−--

24−-- Similar to 'diffMap' but doesn't require 'Eq' on the values, thus can't tell if a value has changed or not.

25−diffMapNoEq :: (Ord k) => Map k v -> Map k v -> Map k (Maybe v)

26−diffMapNoEq olds news = flip Map.mapMaybe (align olds news) $ \case

27− This _ -> Just Nothing

28− These _ new -> Just $ Just new

29− That new -> Just $ Just new

30−

31−-- |Produce a @'Map' k (Maybe v)@ by comparing two @'Map' k v@s, @old@ and @new respectively. @Just@ represents an association present in @new@ and either not

32−-- present in @old@ or where the value has changed. @Nothing@ represents an association only present in @old@ but no longer present in @new@.

33−--

34−-- See also 'diffMapNoEq' for a similar but weaker version which does not require 'Eq' on the values but thus can't indicated a value not changing between

35−-- @old@ and @new@ with @Nothing@.

36−diffMap :: (Ord k, Eq v) => Map k v -> Map k v -> Map k (Maybe v)

37−diffMap olds news = flip Map.mapMaybe (align olds news) $ \case

38− This _ -> Just Nothing

39− These old new

40− | old == new -> Nothing

41− | otherwise -> Just $ Just new

42− That new -> Just $ Just new

43−

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

45−--

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

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

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

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

50− maybeToEither = \case

51− Nothing -> Left ()

52− Just r -> Right r

53−

54−-- |Split a @'Map' k (Either a b)@ into @Map k a@ and @Map k b@, equivalent to @'Map.mapEither' id@

55−{-# DEPRECATED mapPartitionEithers "Use 'mapEither' instead" #-}

56−mapPartitionEithers :: Map k (Either a b) -> (Map k a, Map k b)

57−mapPartitionEithers = Map.mapEither id

58−

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

60−--

61−-- Equivalent to:

62−--

63−-- @

64−-- applyMapKeysSet patch ('Map.keysSet' m) == 'Map.keysSet' ('applyMap' patch m)

65−-- @

66−--

67−-- but avoids the intervening @Map@ and needs no values.

68−applyMapKeysSet :: Ord k => Map k (Maybe v) -> Set k -> Set k

69−applyMapKeysSet patch old = Map.keysSet insertions `Set.union` (old `Set.difference` Map.keysSet deletions)

70− where (insertions, deletions) = Map.partition isJust patch

71−

src/Data/WeakBag.hs+12−14

@@ -15,29 +15,29 @@ module Data.WeakBag

15 , singleton

16 , insert

17 , traverse

18− , traverse_

19 , remove

18 , remove

20 -- * Internal functions

19 -- * Internal functions

21 -- These will not always be available.

20 -- These will not always be available.

22 , _weakBag_children --TODO: Don't export this

21 , _weakBag_children --TODO: Don't export this

23 ) where

22 ) where

25−import Prelude hiding (traverse)

26−

27import Control.Exception

24import Control.Exception

28−import Control.Monad

25+import Control.Monad hiding (forM_, mapM_)

29import Control.Monad.IO.Class

26import Control.Monad.IO.Class

27+import Data.Foldable (forM_, mapM_)

30import Data.IntMap.Strict (IntMap)

28import Data.IntMap.Strict (IntMap)

31import qualified Data.IntMap.Strict as IntMap

29import qualified Data.IntMap.Strict as IntMap

32import Data.IORef

30import Data.IORef

33import System.Mem.Weak

31import System.Mem.Weak

33+import Prelude hiding (mapM_, traverse)

34+

35−-- | A 'WeakBag' holds a set of values of type @/a/@, but does not retain them -

35+-- | A @WeakBag a@ holds a set of values of type @a@, but does not retain them -

36−-- that is, they can still be garbage-collected. As long as the @/a/@ values remain

36+-- that is, they can still be garbage-collected. As long as the @a@s remain

37-- alive, the 'WeakBag' will continue to refer to them.

38data WeakBag a = WeakBag

39 { _weakBag_nextId :: {-# UNPACK #-} !(IORef Int) --TODO: what if this wraps around?

40− , _weakBag_children :: {-# UNPACK #-} !(IORef (IntMap (Weak a))) -- ^ The items referenced by the WeakBag

40+ , _weakBag_children :: {-# UNPACK #-} !(IORef (IntMap (Weak a)))

41 }

43-- | When inserting an item into a 'WeakBag', a 'WeakBagTicket' is returned. If

@@ -72,6 +72,8 @@ insert a (WeakBag nextId children) wbRef finalizer = {-# SCC "insert" #-} do

72 let !csWithoutMe = IntMap.delete myId cs

73 in (csWithoutMe, csWithoutMe)

74 when (IntMap.null csWithoutMe) $ finalizer b

75+ return ()

76+ return ()

75 wa <- mkWeakPtr a' $ Just cleanup

77 wa <- mkWeakPtr a' $ Just cleanup

76 atomicModifyIORef' children $ \cs -> (IntMap.insert myId wa cs, ())

78 atomicModifyIORef' children $ \cs -> (IntMap.insert myId wa cs, ())

77 return $ WeakBagTicket

79 return $ WeakBagTicket

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

100 ticket <- insert a bag wbRef finalizer

102 ticket <- insert a bag wbRef finalizer

101 return (bag, ticket)

103 return (bag, ticket)

102

104

103−{-# INLINE traverse_ #-}

105+{-# INLINE traverse #-}

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

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

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

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

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

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

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

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

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

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

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

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

110 cs <- liftIO $ readIORef children

112 cs <- liftIO $ readIORef children

111 forM_ cs $ \c -> do

113 forM_ cs $ \c -> do

112 ma <- liftIO $ deRefWeak c

114 ma <- liftIO $ deRefWeak c

113 mapM_ f ma

115 mapM_ f ma

114

116

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

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

117−traverse = traverse_

118−

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

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

120-- on the same 'WeakBagTicket'.

118-- on the same 'WeakBagTicket'.

121{-# INLINE remove #-}

119{-# INLINE remove #-}

src/Reflex.hs+2−13

@@ -6,30 +6,19 @@ module Reflex

6 ) where

8import Reflex.Class as X

9−import Reflex.Adjustable.Class as X

9+import Reflex.EventWriter as X

10−import Reflex.BehaviorWriter.Base as X

11−import Reflex.BehaviorWriter.Class as X

12−import Reflex.Collection as X

13import Reflex.Dynamic as X

10import Reflex.Dynamic as X

14−import Reflex.EventWriter.Base as X

15−import Reflex.EventWriter.Class as X

16#ifdef USE_TEMPLATE_HASKELL

11#ifdef USE_TEMPLATE_HASKELL

17import Reflex.Dynamic.TH as X

12import Reflex.Dynamic.TH as X

18#endif

13#endif

19import Reflex.Dynamic.Uniq as X

14import Reflex.Dynamic.Uniq as X

20−import Reflex.DynamicWriter.Base as X

15+import Reflex.DynamicWriter as X

21−import Reflex.DynamicWriter.Class as X

22−import Reflex.NotReady.Class as X

23import Reflex.PerformEvent.Base as X

16import Reflex.PerformEvent.Base as X

24import Reflex.PerformEvent.Class as X

17import Reflex.PerformEvent.Class as X

25import Reflex.PostBuild.Base as X

18import Reflex.PostBuild.Base as X

26import Reflex.PostBuild.Class as X

19import Reflex.PostBuild.Class as X

27−import Reflex.Profiled as X

28−import Reflex.Query.Base as X

29−import Reflex.Query.Class as X

30import Reflex.Requester.Base as X

20import Reflex.Requester.Base as X

31import Reflex.Requester.Class as X

21import Reflex.Requester.Class as X

32import Reflex.Spider as X

22import Reflex.Spider as X

33−import Reflex.Time as X

34import Reflex.TriggerEvent.Base as X

23import Reflex.TriggerEvent.Base as X

35import Reflex.TriggerEvent.Class as X

24import Reflex.TriggerEvent.Class as X

src/Reflex/Adjustable/Class.hsdeleted−140

@@ -1,140 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE FlexibleInstances #-}

4−{-# LANGUAGE FunctionalDependencies #-}

5−{-# LANGUAGE LambdaCase #-}

6−{-# LANGUAGE RankNTypes #-}

7−{-# LANGUAGE ScopedTypeVariables #-}

8−{-# LANGUAGE TypeFamilies #-}

9−{-# LANGUAGE UndecidableInstances #-}

10−#ifdef USE_REFLEX_OPTIMIZER

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

12−#endif

13−-- |

14−-- Module:

15−-- Reflex.Adjustable.Class

16−-- Description:

17−-- A class for actions that can be "adjusted" over time based on some 'Event'

18−-- such that, when observed after the firing of any such 'Event', the result

19−-- is as though the action was originally run with the 'Event's value.

20−module Reflex.Adjustable.Class

21− (

22− -- * The Adjustable typeclass

23− Adjustable(..)

24− , sequenceDMapWithAdjust

25− , sequenceDMapWithAdjustWithMove

26− , mapMapWithAdjustWithMove

27− -- * Deprecated aliases

28− , MonadAdjust

29− ) where

30−

31−import Control.Monad.Identity

32−import Control.Monad.Reader

33−import Data.Dependent.Map (DMap)

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

35−import qualified Data.Dependent.Map as DMap

36−import Data.Functor.Constant

37−import Data.Functor.Misc

38−import Data.IntMap.Strict (IntMap)

39−import qualified Data.IntMap.Strict as IntMap

40−import Data.Map (Map)

41−

42−import Reflex.Class

43−import Data.Patch.DMapWithMove

44−

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

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

47−-- is as though it had originally been run with the new value. Note that there

48−-- is some issue here with persistent side-effects: obviously, IO (and some

49−-- other side-effects) cannot be undone, so it is up to the instance implementer

50−-- to determine what the best meaning for this class is in such cases.

51−class (Reflex t, Monad m) => Adjustable t m | m -> t where

52− runWithReplace

53− :: m a

54− -> Event t (m b)

55− -> m (a, Event t b)

56−

57− traverseIntMapWithKeyWithAdjust

58− :: (IntMap.Key -> v -> m v')

59− -> IntMap v

60− -> Event t (PatchIntMap v)

61− -> m (IntMap v', Event t (PatchIntMap v'))

62−

63− traverseDMapWithKeyWithAdjust

64− :: GCompare k

65− => (forall a. k a -> v a -> m (v' a))

66− -> DMap k v

67− -> Event t (PatchDMap k v)

68− -> m (DMap k v', Event t (PatchDMap k v'))

69− {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

70− traverseDMapWithKeyWithAdjust f dm0 dm' = fmap (fmap (fmap fromPatchWithMove)) $

71− traverseDMapWithKeyWithAdjustWithMove f dm0 $ fmap toPatchWithMove dm'

72− where

73− toPatchWithMove (PatchDMap m) = PatchDMapWithMove $ DMap.map toNodeInfoWithMove m

74− toNodeInfoWithMove = \case

75− ComposeMaybe (Just v) -> NodeInfo (From_Insert v) $ ComposeMaybe Nothing

76− ComposeMaybe Nothing -> NodeInfo From_Delete $ ComposeMaybe Nothing

77− fromPatchWithMove (PatchDMapWithMove m) = PatchDMap $ DMap.map fromNodeInfoWithMove m

78− fromNodeInfoWithMove (NodeInfo from _) = ComposeMaybe $ case from of

79− From_Insert v -> Just v

80− From_Delete -> Nothing

81− From_Move _ -> error "traverseDMapWithKeyWithAdjust: implementation of traverseDMapWithKeyWithAdjustWithMove inserted spurious move"

82−

83− traverseDMapWithKeyWithAdjustWithMove

84− :: GCompare k

85− => (forall a. k a -> v a -> m (v' a))

86− -> DMap k v

87− -> Event t (PatchDMapWithMove k v)

88− -> m (DMap k v', Event t (PatchDMapWithMove k v'))

89−

90−instance Adjustable t m => Adjustable t (ReaderT r m) where

91− runWithReplace a0 a' = do

92− r <- ask

93− lift $ runWithReplace (runReaderT a0 r) $ fmap (`runReaderT` r) a'

94− traverseIntMapWithKeyWithAdjust f dm0 dm' = do

95− r <- ask

96− lift $ traverseIntMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'

97− traverseDMapWithKeyWithAdjust f dm0 dm' = do

98− r <- ask

99− lift $ traverseDMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'

100− traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do

101− r <- ask

102− lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runReaderT (f k v) r) dm0 dm'

103−

104−-- | Traverse a 'DMap' of 'Adjustable' actions, running each of them. The provided 'Event' of patches

105−-- to the 'DMap' can add, remove, or update values.

106−sequenceDMapWithAdjust

107− :: (GCompare k, Adjustable t m)

108− => DMap k m

109− -> Event t (PatchDMap k m)

110− -> m (DMap k Identity, Event t (PatchDMap k Identity))

111−sequenceDMapWithAdjust = traverseDMapWithKeyWithAdjust $ \_ -> fmap Identity

112−

113−-- | Traverses a 'DMap' of 'Adjustable' actions, running each of them. The provided 'Event' of patches

114−-- to the 'DMap' can add, remove, update, move, or swap values.

115−sequenceDMapWithAdjustWithMove

116− :: (GCompare k, Adjustable t m)

117− => DMap k m

118− -> Event t (PatchDMapWithMove k m)

119− -> m (DMap k Identity, Event t (PatchDMapWithMove k Identity))

120−sequenceDMapWithAdjustWithMove = traverseDMapWithKeyWithAdjustWithMove $ \_ -> fmap Identity

121−

122−-- | Traverses a 'Map', running the provided 'Adjustable' action. The provided 'Event' of patches to the 'Map'

123−-- can add, remove, update, move, or swap values.

124−mapMapWithAdjustWithMove

125− :: forall t m k v v'. (Adjustable t m, Ord k)

126− => (k -> v -> m v')

127− -> Map k v

128− -> Event t (PatchMapWithMove k v)

129− -> m (Map k v', Event t (PatchMapWithMove k v'))

130−mapMapWithAdjustWithMove f m0 m' = do

131− (out0 :: DMap (Const2 k v) (Constant v'), out') <- traverseDMapWithKeyWithAdjustWithMove (\(Const2 k) (Identity v) -> Constant <$> f k v) (mapToDMap m0) (const2PatchDMapWithMoveWith Identity <$> m')

132− return (dmapToMapWith (\(Constant v') -> v') out0, patchDMapWithMoveToPatchMapWithMoveWith (\(Constant v') -> v') <$> out')

133−

134−--------------------------------------------------------------------------------

135−-- Deprecated functions

136−--------------------------------------------------------------------------------

137−

138−{-# DEPRECATED MonadAdjust "Use Adjustable instead" #-}

139−-- | Synonym for 'Adjustable'

140−type MonadAdjust = Adjustable

src/Reflex/BehaviorWriter/Base.hsdeleted−211

@@ -1,211 +0,0 @@

1−{-|

2−Module: Reflex.BehaviorWriter.Base

3−Description: Implementation of BehaviorWriter

4−-}

5−{-# LANGUAGE CPP #-}

6−{-# LANGUAGE FlexibleInstances #-}

7−{-# LANGUAGE GADTs #-}

8−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

9−{-# LANGUAGE MultiParamTypeClasses #-}

10−{-# LANGUAGE RankNTypes #-}

11−{-# LANGUAGE ScopedTypeVariables #-}

12−{-# LANGUAGE TypeFamilies #-}

13−{-# LANGUAGE UndecidableInstances #-}

14−{-# LANGUAGE StandaloneDeriving #-}

15−#ifdef USE_REFLEX_OPTIMIZER

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

17−#endif

18−module Reflex.BehaviorWriter.Base

19− ( BehaviorWriterT (..)

20− , runBehaviorWriterT

21− , withBehaviorWriterT

22− ) where

23−

24−import Control.Monad.Exception

25−import Control.Monad.Identity

26−import Control.Monad.IO.Class

27−import Control.Monad.Morph

28−import Control.Monad.Reader

29−import Control.Monad.Ref

30−import Control.Monad.State.Strict

31−import Data.Dependent.Map (DMap)

32−import qualified Data.Dependent.Map as DMap

33−import Data.Functor.Misc

34−import Data.IntMap (IntMap)

35−import qualified Data.IntMap as IntMap

36−import Data.Map (Map)

37−import qualified Data.Map as Map

38−import Data.Some (Some)

39−

40−import Reflex.Class

41−import Reflex.Adjustable.Class

42−import Reflex.BehaviorWriter.Class

43−import Reflex.Host.Class

44−import Reflex.PerformEvent.Class

45−import Reflex.PostBuild.Class

46−import Reflex.Query.Class

47−import Reflex.Requester.Class

48−import Reflex.TriggerEvent.Class

49−

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

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

52− -- The list is kept in reverse order

53− deriving

54− ( Functor

55− , Applicative

56− , Monad

57− , MonadTrans

58− , MFunctor

59− , MonadIO

60− , MonadFix

61− , MonadAsyncException

62− , MonadException

63− )

64−

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

66−-- along with the result of the action.

67−runBehaviorWriterT :: (Monad m, Reflex t, Monoid w) => BehaviorWriterT t w m a -> m (a, Behavior t w)

68−runBehaviorWriterT (BehaviorWriterT a) = do

69− (result, ws) <- runStateT a []

70− return (result, mconcat $ reverse ws)

71−

72−-- | Map a function over the output of a 'BehaviorWriterT'.

73−withBehaviorWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m)

74− => (w -> w')

75− -> BehaviorWriterT t w m a

76− -> BehaviorWriterT t w' m a

77−withBehaviorWriterT f dw = do

78− (r, d) <- lift $ do

79− (r, d) <- runBehaviorWriterT dw

80− let d' = fmap f d

81− return (r, d')

82− tellBehavior d

83− return r

84−

85−deriving instance MonadHold t m => MonadHold t (BehaviorWriterT t w m)

86−deriving instance MonadSample t m => MonadSample t (BehaviorWriterT t w m)

87−

88−instance MonadRef m => MonadRef (BehaviorWriterT t w m) where

89− type Ref (BehaviorWriterT t w m) = Ref m

90− newRef = lift . newRef

91− readRef = lift . readRef

92− writeRef r = lift . writeRef r

93−

94−instance MonadAtomicRef m => MonadAtomicRef (BehaviorWriterT t w m) where

95− atomicModifyRef r = lift . atomicModifyRef r

96−

97−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (BehaviorWriterT t w m) where

98− newEventWithTrigger = lift . newEventWithTrigger

99− newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

100−

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

102− tellBehavior w = BehaviorWriterT $ modify (w :)

103−

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

105− ask = lift ask

106− local f (BehaviorWriterT a) = BehaviorWriterT $ mapStateT (local f) a

107− reader = lift . reader

108−

109−instance PerformEvent t m => PerformEvent t (BehaviorWriterT t w m) where

110− type Performable (BehaviorWriterT t w m) = Performable m

111− performEvent_ = lift . performEvent_

112− performEvent = lift . performEvent

113−

114−instance TriggerEvent t m => TriggerEvent t (BehaviorWriterT t w m) where

115− newTriggerEvent = lift newTriggerEvent

116− newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

117− newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

118−

119−instance PostBuild t m => PostBuild t (BehaviorWriterT t w m) where

120− getPostBuild = lift getPostBuild

121−

122−instance MonadState s m => MonadState s (BehaviorWriterT t w m) where

123− get = lift get

124− put = lift . put

125−

126−instance Requester t m => Requester t (BehaviorWriterT t w m) where

127− type Request (BehaviorWriterT t w m) = Request m

128− type Response (BehaviorWriterT t w m) = Response m

129− requesting = lift . requesting

130− requesting_ = lift . requesting_

131−

132−instance (MonadQuery t q m, Monad m) => MonadQuery t q (BehaviorWriterT t w m) where

133− tellQueryIncremental = lift . tellQueryIncremental

134− askQueryResult = lift askQueryResult

135− queryIncremental = lift . queryIncremental

136−

137−instance (Adjustable t m, Monoid w, MonadHold t m, Reflex t) => Adjustable t (BehaviorWriterT t w m) where

138− runWithReplace a0 a' = do

139− (result0, result') <- lift $ runWithReplace (runBehaviorWriterT a0) $ runBehaviorWriterT <$> a'

140− tellBehavior . join =<< hold (snd result0) (snd <$> result')

141− return (fst result0, fst <$> result')

142− traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustImpl traverseIntMapWithKeyWithAdjust

143− traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove weakenPatchDMapWithMoveWith

144−

145−traverseIntMapWithKeyWithAdjustImpl

146− :: forall t w v' p p' v m.

147− ( PatchTarget (p' (Behavior t w)) ~ IntMap (Behavior t w)

148− , Patch (p' (Behavior t w))

149− , Monoid w

150− , Reflex t

151− , MonadHold t m

152− , Functor p

153− , p ~ p'

154− )

155− => ( (IntMap.Key -> v -> m (v', Behavior t w))

156− -> IntMap v

157− -> Event t (p v)

158− -> m (IntMap (v', Behavior t w), Event t (p (v', Behavior t w)))

159− )

160− -> (IntMap.Key -> v -> BehaviorWriterT t w m v')

161− -> IntMap v

162− -> Event t (p v)

163− -> BehaviorWriterT t w m (IntMap v', Event t (p v'))

164−traverseIntMapWithKeyWithAdjustImpl base f (dm0 :: IntMap v) dm' = do

165− (result0, result') <- lift $ base (\k v -> runBehaviorWriterT $ f k v) dm0 dm'

166− let liftedResult0 = fmap fst result0

167− liftedResult' = fmap (fmap fst) result'

168− liftedWritten0 :: IntMap (Behavior t w)

169− liftedWritten0 = fmap snd result0

170− liftedWritten' = fmap (fmap snd) result'

171− i <- holdIncremental liftedWritten0 liftedWritten'

172− tellBehavior $ pull $ do

173− m <- sample $ currentIncremental i

174− mconcat . IntMap.elems <$> traverse sample m

175− return (liftedResult0, liftedResult')

176−

177−newtype BehaviorWriterTLoweredResult t w v a = BehaviorWriterTLoweredResult (v a, Behavior t w)

178−

179−traverseDMapWithKeyWithAdjustImpl

180− :: forall t w k v' p p' v m.

181− ( PatchTarget (p' (Some k) (Behavior t w)) ~ Map (Some k) (Behavior t w)

182− , Patch (p' (Some k) (Behavior t w))

183− , Monoid w

184− , Reflex t

185− , MonadHold t m

186− )

187− => ( (forall a. k a -> v a -> m (BehaviorWriterTLoweredResult t w v' a))

188− -> DMap k v

189− -> Event t (p k v)

190− -> m (DMap k (BehaviorWriterTLoweredResult t w v'), Event t (p k (BehaviorWriterTLoweredResult t w v')))

191− )

192− -> ((forall a. BehaviorWriterTLoweredResult t w v' a -> v' a) -> p k (BehaviorWriterTLoweredResult t w v') -> p k v')

193− -> ((forall a. BehaviorWriterTLoweredResult t w v' a -> Behavior t w) -> p k (BehaviorWriterTLoweredResult t w v') -> p' (Some k) (Behavior t w))

194− -> (forall a. k a -> v a -> BehaviorWriterT t w m (v' a))

195− -> DMap k v

196− -> Event t (p k v)

197− -> BehaviorWriterT t w m (DMap k v', Event t (p k v'))

198−traverseDMapWithKeyWithAdjustImpl base mapPatch weakenPatchWith f (dm0 :: DMap k v) dm' = do

199− (result0, result') <- lift $ base (\k v -> fmap BehaviorWriterTLoweredResult $ runBehaviorWriterT $ f k v) dm0 dm'

200− let getValue (BehaviorWriterTLoweredResult (v, _)) = v

201− getWritten (BehaviorWriterTLoweredResult (_, w)) = w

202− liftedResult0 = DMap.map getValue result0

203− liftedResult' = ffor result' $ mapPatch getValue

204− liftedWritten0 :: Map (Some k) (Behavior t w)

205− liftedWritten0 = weakenDMapWith getWritten result0

206− liftedWritten' = ffor result' $ weakenPatchWith getWritten

207− i <- holdIncremental liftedWritten0 liftedWritten'

208− tellBehavior $ pull $ do

209− m <- sample $ currentIncremental i

210− mconcat . Map.elems <$> traverse sample m

211− return (liftedResult0, liftedResult')

src/Reflex/BehaviorWriter/Class.hsdeleted−31

@@ -1,31 +0,0 @@

1−{-|

2−Module: Reflex.BehaviorWriter.Class

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

4−-}

5−{-# LANGUAGE CPP #-}

6−{-# LANGUAGE ConstraintKinds #-}

7−{-# LANGUAGE FlexibleInstances #-}

8−{-# LANGUAGE FunctionalDependencies #-}

9−{-# LANGUAGE UndecidableInstances #-}

10−#ifdef USE_REFLEX_OPTIMIZER

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

12−#endif

13−module Reflex.BehaviorWriter.Class

14− ( MonadBehaviorWriter

15− , BehaviorWriter(..)

16− ) where

17−

18−import Control.Monad.Reader (ReaderT, lift)

19−import Reflex.Class (Behavior)

20−

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

22−-- | Type synonym for 'BehaviorWriter'

23−type MonadBehaviorWriter = BehaviorWriter

24−

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

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

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

28− tellBehavior :: Behavior t w -> m ()

29−

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

31− tellBehavior = lift . tellBehavior

src/Reflex/Class.hs+338−1021

@@ -1,14 +1,11 @@

1−{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE CPP #-}

1{-# LANGUAGE CPP #-}

3−{-# LANGUAGE ConstraintKinds #-}

4−{-# LANGUAGE DefaultSignatures #-}

5{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE FlexibleContexts #-}

6{-# LANGUAGE FlexibleInstances #-}

3{-# LANGUAGE FlexibleInstances #-}

7{-# LANGUAGE FunctionalDependencies #-}

4{-# LANGUAGE FunctionalDependencies #-}

8{-# LANGUAGE GADTs #-}

5{-# LANGUAGE GADTs #-}

9{-# LANGUAGE LambdaCase #-}

6{-# LANGUAGE LambdaCase #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

10{-# LANGUAGE NoMonomorphismRestriction #-}

8{-# LANGUAGE NoMonomorphismRestriction #-}

11−{-# LANGUAGE PolyKinds #-}

12{-# LANGUAGE RankNTypes #-}

9{-# LANGUAGE RankNTypes #-}

13{-# LANGUAGE RecursiveDo #-}

10{-# LANGUAGE RecursiveDo #-}

14{-# LANGUAGE RoleAnnotations #-}

11{-# LANGUAGE RoleAnnotations #-}

@@ -16,56 +13,43 @@

16{-# LANGUAGE TypeFamilies #-}

13{-# LANGUAGE TypeFamilies #-}

17{-# LANGUAGE TypeOperators #-}

14{-# LANGUAGE TypeOperators #-}

18{-# LANGUAGE UndecidableInstances #-}

15{-# LANGUAGE UndecidableInstances #-}

19−{-# LANGUAGE Trustworthy #-}

20#ifdef USE_REFLEX_OPTIMIZER

16#ifdef USE_REFLEX_OPTIMIZER

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

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

22#endif

18#endif

19+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

20+{-# LANGUAGE EmptyDataDecls #-}

21+{-# OPTIONS_GHC -Wno-redundant-constraints #-}

22+#endif

24−-- |

25−-- Module:

26−-- Reflex.Class

27−-- Description:

28−-- This module contains the Reflex interface, as well as a variety of

24+-- | This module contains the Reflex interface, as well as a variety of

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

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

30−-- signals.

26+-- signals.

31module Reflex.Class

27module Reflex.Class

32− ( module Data.Patch

28+ ( module Reflex.Patch

33 -- * Primitives

29 -- * Primitives

34 , Reflex (..)

30 , Reflex (..)

35− , mergeInt

36 , coerceBehavior

31 , coerceBehavior

37 , coerceEvent

32 , coerceEvent

38 , coerceDynamic

33 , coerceDynamic

39− , coerceIncremental

40 , MonadSample (..)

34 , MonadSample (..)

41 , MonadHold (..)

35 , MonadHold (..)

42− -- ** 'fan' related types

36+ -- ** 'fan'-related types

43 , EventSelector (..)

37 , EventSelector (..)

44− , EventSelectorG (..)

38+ -- ** 'Incremental'-related types

45− , EventSelectorInt (..)

46 -- * Convenience functions

39 -- * Convenience functions

47 , constDyn

40 , constDyn

48 , pushAlways

41 , pushAlways

49 -- ** Combining 'Event's

42 -- ** Combining 'Event's

50 , leftmost

43 , leftmost

51− , merge

52− , mergeIncremental

53− , mergeIncrementalWithMove

54 , mergeMap

44 , mergeMap

55− , mergeIntMap

56 , mergeMapIncremental

45 , mergeMapIncremental

57 , mergeMapIncrementalWithMove

46 , mergeMapIncrementalWithMove

58− , mergeIntMapIncremental

59− , coincidencePatchMap

60− , coincidencePatchMapWithMove

61− , coincidencePatchIntMap

62 , mergeList

47 , mergeList

63 , mergeWith

48 , mergeWith

64 , difference

49 , difference

65 , alignEventWithMaybe

50 , alignEventWithMaybe

66 -- ** Breaking up 'Event's

51 -- ** Breaking up 'Event's

67 , splitE

52 , splitE

68− , fan

69 , fanEither

53 , fanEither

70 , fanThese

54 , fanThese

71 , fanMap

55 , fanMap

@@ -73,16 +57,11 @@ module Reflex.Class

73 , EitherTag (..)

57 , EitherTag (..)

74 , eitherToDSum

58 , eitherToDSum

75 , dsumToEither

59 , dsumToEither

76− , factorEvent

60+ -- ** Switching between 'Event's

77− , filterEventKey

61+ , switchPromptly

78− -- ** Collapsing 'Event . Event'

62+ , switchPromptOnly

79− , switchHold

80− , switchHoldPromptly

81− , switchHoldPromptOnly

82− , switchHoldPromptOnlyIncremental

83 -- ** Using 'Event's to sample 'Behavior's

63 -- ** Using 'Event's to sample 'Behavior's

84 , tag

64 , tag

85− , tagMaybe

86 , attach

65 , attach

87 , attachWith

66 , attachWith

88 , attachWithMaybe

67 , attachWithMaybe

@@ -90,53 +69,20 @@ module Reflex.Class

90 , gate

69 , gate

91 -- ** Combining 'Dynamic's

70 -- ** Combining 'Dynamic's

92 , distributeDMapOverDynPure

71 , distributeDMapOverDynPure

93− , distributeDMapOverDynPureG

94 , distributeListOverDyn

72 , distributeListOverDyn

95 , distributeListOverDynWith

73 , distributeListOverDynWith

96 , zipDyn

74 , zipDyn

97 , zipDynWith

75 , zipDynWith

98 -- ** Accumulating state

76 -- ** Accumulating state

99 , Accumulator (..)

77 , Accumulator (..)

100− , accumDyn

101− , accumMDyn

102− , accumMaybeDyn

103− , accumMaybeMDyn

104− , mapAccumDyn

105− , mapAccumMDyn

106− , mapAccumMaybeDyn

107− , mapAccumMaybeMDyn

108− , accumB

109− , accumMB

110− , accumMaybeB

111− , accumMaybeMB

112− , mapAccumB

113− , mapAccumMB

114− , mapAccumMaybeB

115− , mapAccumMaybeMB

116 , mapAccum_

78 , mapAccum_

117 , mapAccumM_

79 , mapAccumM_

118 , mapAccumMaybe_

80 , mapAccumMaybe_

119 , mapAccumMaybeM_

81 , mapAccumMaybeM_

120− , accumIncremental

121− , accumMIncremental

122− , accumMaybeIncremental

123− , accumMaybeMIncremental

124− , mapAccumIncremental

125− , mapAccumMIncremental

126− , mapAccumMaybeIncremental

127− , mapAccumMaybeMIncremental

128 , zipListWithEvent

82 , zipListWithEvent

129− , numberOccurrences

83+ , headE

130− , numberOccurrencesFrom

131− , numberOccurrencesFrom_

132− , (<@>)

133− , (<@)

134 , tailE

84 , tailE

135 , headTailE

85 , headTailE

136− , takeWhileE

137− , takeWhileJustE

138− , dropWhileE

139− , takeDropWhileJustE

140 , switcher

86 , switcher

141 -- * Debugging functions

87 -- * Debugging functions

142 , traceEvent

88 , traceEvent

@@ -144,24 +90,21 @@ module Reflex.Class

144 -- * Unsafe functions

90 -- * Unsafe functions

145 , unsafeDynamic

91 , unsafeDynamic

146 , unsafeMapIncremental

92 , unsafeMapIncremental

147− -- * 'Filterable' convenience functions

93+ -- * 'FunctorMaybe'

148− , FunctorMaybe -- fmapMaybe is purposely not exported from deprecated 'FunctorMaybe' and the new alias is exported instead

94+ , FunctorMaybe (..)

149− , mapMaybe -- Re-exported for convenience

150− , fmapMaybe

151 , fforMaybe

95 , fforMaybe

152 , ffilter

96 , ffilter

153− , filterLeft

154− , filterRight

155 -- * Miscellaneous convenience functions

97 -- * Miscellaneous convenience functions

156 , ffor

98 , ffor

157− , ffor2

99+ , MonadAdjust (..)

158− , ffor3

100+ , sequenceDMapWithAdjust

101+ , sequenceDMapWithAdjustWithMove

102+ , mapMapWithAdjustWithMove

159 -- * Deprecated functions

103 -- * Deprecated functions

160− , switchPromptly

104+ , appendEvents

161− , switchPromptOnly

105+ , onceE

162− -- * "Cheap" functions

106+ , sequenceThese

163 , fmapMaybeCheap

107 , fmapMaybeCheap

164− , mapMaybeCheap

165 , fmapCheap

108 , fmapCheap

166 , fforCheap

109 , fforCheap

167 , fforMaybeCheap

110 , fforMaybeCheap

@@ -169,65 +112,94 @@ module Reflex.Class

169 , tagCheap

112 , tagCheap

170 , mergeWithCheap

113 , mergeWithCheap

171 , mergeWithCheap'

114 , mergeWithCheap'

172− -- * Slow, but general, implementations

115+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

173− , slowHeadE

116+ , Spider

174− ) where

117+ , SpiderEnv

175−

118+ , SpiderTimeline

176−#ifdef MIN_VERSION_semialign

119+ , Global

177−import Prelude hiding (zip, zipWith)

120+ , Behavior (..)

178−

121+ , Event (..)

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

122+ , Dynamic (..)

180−import Data.These.Combinators (justThese)

123+ , Incremental (..)

181−#endif

124+ , never

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

125+ , constant

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

126+ , push

184−#endif

127+ , pushCheap

128+ , pull

129+ , merge

130+ , fan

131+ , switch

132+ , coincidence

133+ , current

134+ , updated

135+ , unsafeBuildDynamic

136+ , unsafeBuildIncremental

137+ , mergeIncremental

138+ , mergeIncrementalWithMove

139+ , currentIncremental

140+ , updatedIncremental

141+ , incrementalToDynamic

142+ , behaviorCoercion

143+ , eventCoercion

144+ , dynamicCoercion

185#endif

145#endif

146+ ) where

186

147

187import Control.Applicative

148import Control.Applicative

188−import Control.Monad.Identity

149+import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

189−import Control.Monad.Reader

150+import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

190−import Control.Monad.State.Strict

151+import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

191−import Control.Monad.Trans.Cont (ContT)

152+import Control.Monad.Trans.Cont (ContT ())

192−import Control.Monad.Trans.Except (ExceptT)

153+import Control.Monad.Trans.Except (ExceptT ())

193−import Control.Monad.Trans.RWS (RWST)

154+import Control.Monad.Trans.RWS (RWST ())

194−import Control.Monad.Trans.Writer (WriterT)

155+import Control.Monad.Trans.Writer (WriterT ())

195import Data.Align

156import Data.Align

196import Data.Bifunctor

157import Data.Bifunctor

197import Data.Coerce

158import Data.Coerce

198import Data.Default

159import Data.Default

199−import Data.Dependent.Map (DMap)

160+import Data.Dependent.Map (DMap, DSum (..), GCompare (..))

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

201import qualified Data.Dependent.Map as DMap

161import qualified Data.Dependent.Map as DMap

202−import Data.Functor.Compose

162+import Data.Either

203−import Data.Functor.Product

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

205−import Data.FastMutableIntMap (PatchIntMap)

206import Data.Foldable

163import Data.Foldable

207−import Data.Functor.Bind

164+import Data.Functor.Bind hiding (join)

165+import qualified Data.Functor.Bind as Bind

166+import Data.Functor.Constant

208import Data.Functor.Misc

167import Data.Functor.Misc

209import Data.Functor.Plus

168import Data.Functor.Plus

210−import Data.IntMap.Strict (IntMap)

211−import qualified Data.IntMap.Strict as IntMap

212import Data.List.NonEmpty (NonEmpty (..))

169import Data.List.NonEmpty (NonEmpty (..))

213import Data.Map (Map)

170import Data.Map (Map)

214−import Data.Semigroup (Semigroup (..))

171+import Data.Maybe

215−import Data.Some (Some(Some))

172+import Data.Monoid hiding (Alt, (<>))

173+import Data.Semigroup (Semigroup, sconcat, stimes, (<>))

216import Data.String

174import Data.String

217import Data.These

175import Data.These

176+import Data.Traversable

218import Data.Type.Coercion

177import Data.Type.Coercion

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

178+import Reflex.FunctorMaybe

220−import Data.Witherable (Filterable(..))

179+import Reflex.Patch

221−import qualified Data.Witherable as W

180+

222−import Reflex.FunctorMaybe (FunctorMaybe)

181+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

182+import Reflex.Spider.Internal (EventM, Global, HasSpiderTimeline, SpiderHost (..), SpiderHostFrame (..),

183+ SpiderPullM, SpiderPushM (..), behaviorHoldIdentity, dynamicConst,

184+ dynamicCurrent, dynamicDynIdentity, dynamicHold, dynamicHoldIdentity,

185+ dynamicUpdated, newMapDyn, readBehaviorTracked, readBehaviorUntracked,

186+ runFrame, runSpiderHostFrame, unsafeDyn)

187+import qualified Reflex.Spider.Internal

223−import qualified Reflex.FunctorMaybe

188+import qualified Reflex.Spider.Internal as S

224−import Data.Patch

189+import Unsafe.Coerce

225−import qualified Data.Patch.MapWithMove as PatchMapWithMove

190+#endif

191+

192+-- Note: must come last to silence warnings due to AMP on GHC < 7.10

193+import Prelude hiding (foldl, mapM, mapM_, sequence, sequence_)

226

194

227import Debug.Trace (trace)

195import Debug.Trace (trace)

228

196

197+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

198+#include "Spider/SpiderTimeline.include.hs"

199+#endif

200+

229-- | The 'Reflex' class contains all the primitive functionality needed for

201-- | The 'Reflex' class contains all the primitive functionality needed for

230−-- Functional Reactive Programming (FRP). The @/t/@ type parameter indicates

202+-- Functional Reactive Programming (FRP). The @t@ type parameter indicates

231-- which "timeline" is in use. Timelines are fully-independent FRP contexts,

203-- which "timeline" is in use. Timelines are fully-independent FRP contexts,

232-- and the type of the timeline determines the FRP engine to be used. For most

204-- and the type of the timeline determines the FRP engine to be used. For most

233-- purposes, the 'Reflex.Spider' implementation is recommended.

205-- purposes, the 'Reflex.Spider' implementation is recommended.

@@ -237,6 +209,9 @@ class ( MonadHold t (PushM t)

237 , Functor (Dynamic t)

209 , Functor (Dynamic t)

238 , Applicative (Dynamic t) -- Necessary for GHC <= 7.8

210 , Applicative (Dynamic t) -- Necessary for GHC <= 7.8

239 , Monad (Dynamic t)

211 , Monad (Dynamic t)

212+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

213+ , t ~ SpiderTimeline Global

214+#endif

240 ) => Reflex t where

215 ) => Reflex t where

241 -- | A container for a value that can change over time. 'Behavior's can be

216 -- | A container for a value that can change over time. 'Behavior's can be

242 -- sampled at will, but it is not possible to be notified when they change

217 -- sampled at will, but it is not possible to be notified when they change

@@ -259,6 +234,7 @@ class ( MonadHold t (PushM t)

259 type PushM t :: * -> *

234 type PushM t :: * -> *

260 -- | A monad for doing complex pull-based calculations efficiently

235 -- | A monad for doing complex pull-based calculations efficiently

261 type PullM t :: * -> *

236 type PullM t :: * -> *

237+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

262 -- | An 'Event' with no occurrences

238 -- | An 'Event' with no occurrences

263 never :: Event t a

239 never :: Event t a

264 -- | Create a 'Behavior' that always has the given value

240 -- | Create a 'Behavior' that always has the given value

@@ -273,23 +249,18 @@ class ( MonadHold t (PushM t)

273 -- recomputed whenever any of the read 'Behavior's changes

249 -- recomputed whenever any of the read 'Behavior's changes

274 pull :: PullM t a -> Behavior t a

250 pull :: PullM t a -> Behavior t a

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

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

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

252+ -- least one input event is occuring, and will contain all of the input keys

277 -- that are occurring simultaneously

253 -- that are occurring simultaneously

278−

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

254+ 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

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

281− -> DMap k q -> Event t (DMap k v)

282−

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

255+ -- | Efficiently fan-out an event to many destinations. This function should

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

256+ -- be partially applied, and then the result applied repeatedly to create

285− -- create child events

257+ -- child events

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

258+ fan :: GCompare k => Event t (DMap k Identity) -> EventSelector t k --TODO: Can we help enforce the partial application discipline here? The combinator is worthless without it

287−

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

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

289 -- 'Event' occurs

260 -- 'Event' occurs

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

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

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

262+ -- | Create an 'Event' that will occur whenever the input event is occurring

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

263+ -- and its occurrence value, another 'Event', is also occurring

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

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

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

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

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

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

@@ -298,19 +269,14 @@ class ( MonadHold t (PushM t)

298 -- | Create a new 'Dynamic'. The given 'PullM' must always return the most

269 -- | Create a new 'Dynamic'. The given 'PullM' must always return the most

299 -- recent firing of the given 'Event', if any.

270 -- recent firing of the given 'Event', if any.

300 unsafeBuildDynamic :: PullM t a -> Event t a -> Dynamic t a

271 unsafeBuildDynamic :: PullM t a -> Event t a -> Dynamic t a

301− -- | Create a new 'Incremental'. The given "PullM"'s value must always change

272+ -- | Create a new 'Incremental'. The given 'PullM''s value must always change

302 -- in the same way that the accumulated application of patches would change

273 -- in the same way that the accumulated application of patches would change

303 -- that value.

274 -- that value.

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

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

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

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

306− mergeIncrementalG :: GCompare k

307− => (forall a. q a -> Event t (v a))

308− -> Incremental t (PatchDMap k q)

277+ mergeIncremental :: GCompare k => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)

309− -> Event t (DMap k v)

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

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

311− mergeIncrementalWithMoveG :: GCompare k

312− => (forall a. q a -> Event t (v a))

313− -> Incremental t (PatchDMapWithMove k q) -> Event t (DMap k v)

279+ mergeIncrementalWithMove :: GCompare k => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)

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

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

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

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

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

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

@@ -326,30 +292,79 @@ class ( MonadHold t (PushM t)

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

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

327 -- occurrence type

293 -- occurrence type

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

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

329− -- | Construct a 'Coercion' for an 'Incremental' given 'Coercion's for its

295+#endif

330− -- patch target and patch types.

296+

331− incrementalCoercion

297+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

332− :: Coercion (PatchTarget a) (PatchTarget b) -> Coercion a b -> Coercion (Incremental t a) (Incremental t b)

298+instance t ~ SpiderTimeline Global => Reflex t where

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

299+ newtype Behavior t a = SpiderBehavior { unSpiderBehavior :: Reflex.Spider.Internal.Behavior Global a }

334− fanInt :: Event t (IntMap a) -> EventSelectorInt t a

300+ newtype Event t a = SpiderEvent { unSpiderEvent :: Reflex.Spider.Internal.Event Global a }

335−

301+ newtype Dynamic t a = SpiderDynamic { unSpiderDynamic :: Reflex.Spider.Internal.Dynamic Global (Identity a) } -- deriving (Functor, Applicative, Monad)

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

302+ newtype Incremental t p = SpiderIncremental { unSpiderIncremental :: Reflex.Spider.Internal.Dynamic Global p }

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

303+ type PullM t = SpiderPullM Global

338−-- create child events

304+ type PushM t = SpiderPushM Global

339−fan :: forall t k. (Reflex t, GCompare k)

305+never :: Reflex t => Event t a

340− => Event t (DMap k Identity) -> EventSelector t k

306+constant :: Reflex t => a -> Behavior t a

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

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

343− where

344− fixup :: forall a. (k a -> Event t (Identity a)) -> k a -> Event t a

345− fixup = case eventCoercion Coercion :: Coercion (Event t (Identity a)) (Event t a) of

346− Coercion -> coerce

347−

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

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

350−-- keys simultaneously.

351−mergeInt :: Reflex t => IntMap (Event t a) -> Event t (IntMap a)

307+push :: Reflex t => (a -> PushM t (Maybe b)) -> Event t a -> Event t b

352−mergeInt m = mergeIntIncremental $ unsafeBuildIncremental (return m) never

308+pushCheap :: Reflex t => (a -> PushM t (Maybe b)) -> Event t a -> Event t b

309+pull :: Reflex t => PullM t a -> Behavior t a

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

311+fan :: (Reflex t, GCompare k) => Event t (DMap k Identity) -> EventSelector t k

312+switch :: Reflex t => Behavior t (Event t a) -> Event t a

313+coincidence :: Reflex t => Event t (Event t a) -> Event t a

314+current :: Reflex t => Dynamic t a -> Behavior t a

315+updated :: Reflex t => Dynamic t a -> Event t a

316+unsafeBuildDynamic :: Reflex t => PullM t a -> Event t a -> Dynamic t a

317+unsafeBuildIncremental :: (Reflex t, Patch p) => PullM t (PatchTarget p) -> Event t p -> Incremental t p

318+mergeIncremental :: (Reflex t, GCompare k) => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)

319+mergeIncrementalWithMove :: (Reflex t, GCompare k) => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)

320+currentIncremental :: (Reflex t, Patch p) => Incremental t p -> Behavior t (PatchTarget p)

321+updatedIncremental :: (Reflex t, Patch p) => Incremental t p -> Event t p

322+incrementalToDynamic :: (Reflex t, Patch p) => Incremental t p -> Dynamic t (PatchTarget p)

323+behaviorCoercion :: Reflex t => Coercion a b -> Coercion (Behavior t a) (Behavior t b)

324+eventCoercion :: Reflex t => Coercion a b -> Coercion (Event t a) (Event t b)

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

326+{-# INLINE never #-}

327+never = SpiderEvent S.eventNever

328+{-# INLINE constant #-}

329+constant = SpiderBehavior . S.behaviorConst

330+{-# INLINE push #-}

331+push f = SpiderEvent . S.push (coerce f) . unSpiderEvent

332+{-# INLINE pushCheap #-}

333+pushCheap f = SpiderEvent . S.pushCheap (coerce f) . unSpiderEvent

334+{-# INLINE pull #-}

335+pull = SpiderBehavior . S.pull . coerce

336+{-# INLINE merge #-}

337+merge = SpiderEvent . S.merge . S.dynamicConst . (coerce :: DMap k (Event (SpiderTimeline x)) -> DMap k (S.Event x))

338+{-# INLINE fan #-}

339+fan e = EventSelector $ SpiderEvent . S.select (S.fan (unSpiderEvent e))

340+{-# INLINE switch #-}

341+switch = SpiderEvent . S.switch . (coerce :: S.Behavior x (Event (SpiderTimeline x) a) -> S.Behavior x (S.Event x a)) . unSpiderBehavior

342+{-# INLINE coincidence #-}

343+coincidence = SpiderEvent . S.coincidence . (coerce :: S.Event x (Event (SpiderTimeline x) a) -> S.Event x (S.Event x a)) . unSpiderEvent

344+{-# INLINE current #-}

345+current = SpiderBehavior . S.dynamicCurrent . unSpiderDynamic

346+{-# INLINE updated #-}

347+updated = coerceEvent . SpiderEvent . dynamicUpdated . unSpiderDynamic

348+{-# INLINE unsafeBuildDynamic #-}

349+unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeDyn (coerce readV0) $ coerce $ unSpiderEvent v'

350+{-# INLINE unsafeBuildIncremental #-}

351+unsafeBuildIncremental readV0 dv = SpiderIncremental $ S.dynamicDyn $ unsafeDyn (coerce readV0) $ unSpiderEvent dv

352+{-# INLINE mergeIncremental #-}

353+mergeIncremental = SpiderEvent . S.merge . (unsafeCoerce :: S.Dynamic x (PatchDMap k (Event (SpiderTimeline x))) -> S.Dynamic x (PatchDMap k (S.Event x))) . unSpiderIncremental

354+{-# INLINE mergeIncrementalWithMove #-}

355+mergeIncrementalWithMove = SpiderEvent . S.mergeWithMove . (unsafeCoerce :: S.Dynamic x (PatchDMapWithMove k (Event (SpiderTimeline x))) -> S.Dynamic x (PatchDMapWithMove k (S.Event x))) . unSpiderIncremental

356+{-# INLINE currentIncremental #-}

357+currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental

358+{-# INLINE updatedIncremental #-}

359+updatedIncremental = SpiderEvent . dynamicUpdated . unSpiderIncremental

360+{-# INLINE incrementalToDynamic #-}

361+incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ dynamicDynIdentity $ unsafeDyn (readBehaviorUntracked $ dynamicCurrent i) $ flip S.push (dynamicUpdated i) $ \p -> do

362+ c <- readBehaviorUntracked $ dynamicCurrent i

363+ return $ Identity <$> apply p c

364+eventCoercion Coercion = Coercion

365+behaviorCoercion Coercion = Coercion

366+dynamicCoercion = unsafeCoerce

367+#endif

353

368

354-- | Coerce a 'Behavior' between representationally-equivalent value types

369-- | Coerce a 'Behavior' between representationally-equivalent value types

355coerceBehavior :: (Reflex t, Coercible a b) => Behavior t a -> Behavior t b

370coerceBehavior :: (Reflex t, Coercible a b) => Behavior t a -> Behavior t b

@@ -363,14 +378,8 @@ coerceEvent = coerceWith $ eventCoercion Coercion

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

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

364coerceDynamic = coerceWith $ dynamicCoercion Coercion

379coerceDynamic = coerceWith $ dynamicCoercion Coercion

365

380

366−-- | Coerce an 'Incremental' between representationally-equivalent value types

367−coerceIncremental

368− :: (Reflex t, Coercible a b, Coercible (PatchTarget a) (PatchTarget b))

369− => Incremental t a -> Incremental t b

370−coerceIncremental = coerceWith $ incrementalCoercion Coercion Coercion

371−

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

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

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

382+-- _must_ change when and only when the 'Event' fires, such that the

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

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

375-- if this is not the case, the resulting 'Dynamic' will behave

384-- if this is not the case, the resulting 'Dynamic' will behave

376-- nondeterministically.

385-- nondeterministically.

@@ -398,168 +407,30 @@ class MonadSample t m => MonadHold t m where

398 -- value and will be updated whenever the given 'Event' occurs. The update

407 -- value and will be updated whenever the given 'Event' occurs. The update

399 -- takes effect immediately after the 'Event' occurs; if the occurrence that

408 -- takes effect immediately after the 'Event' occurs; if the occurrence that

400 -- sets the 'Behavior' (or one that is simultaneous with it) is used to sample

409 -- sets the 'Behavior' (or one that is simultaneous with it) is used to sample

401− -- the 'Behavior', it will see the __old__ value of the 'Behavior', not the new

410+ -- the 'Behavior', it will see the _old_ value of the 'Behavior', not the new

402 -- one.

411 -- one.

403 hold :: a -> Event t a -> m (Behavior t a)

412 hold :: a -> Event t a -> m (Behavior t a)

404− default hold :: (m ~ f m', MonadTrans f, MonadHold t m') => a -> Event t a -> m (Behavior t a)

405− hold v0 = lift . hold v0

406 -- | Create a 'Dynamic' value using the given initial value that changes every

413 -- | Create a 'Dynamic' value using the given initial value that changes every

407 -- time the 'Event' occurs.

414 -- time the 'Event' occurs.

408 holdDyn :: a -> Event t a -> m (Dynamic t a)

415 holdDyn :: a -> Event t a -> m (Dynamic t a)

409− default holdDyn :: (m ~ f m', MonadTrans f, MonadHold t m') => a -> Event t a -> m (Dynamic t a)

410− holdDyn v0 = lift . holdDyn v0

411 -- | Create an 'Incremental' value using the given initial value that changes

416 -- | Create an 'Incremental' value using the given initial value that changes

412 -- every time the 'Event' occurs.

417 -- every time the 'Event' occurs.

413 holdIncremental :: Patch p => PatchTarget p -> Event t p -> m (Incremental t p)

418 holdIncremental :: Patch p => PatchTarget p -> Event t p -> m (Incremental t p)

414− default holdIncremental :: (Patch p, m ~ f m', MonadTrans f, MonadHold t m') => PatchTarget p -> Event t p -> m (Incremental t p)

415− holdIncremental v0 = lift . holdIncremental v0

416− buildDynamic :: PushM t a -> Event t a -> m (Dynamic t a)

417− {-

418− default buildDynamic :: (m ~ f m', MonadTrans f, MonadHold t m') => PullM t a -> Event t a -> m (Dynamic t a)

419− buildDynamic getV0 = lift . buildDynamic getV0

420− -}

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

422− -- the supplied 'Event'.

423− headE :: Event t a -> m (Event t a)

424− -- | An event which only occurs at the current moment in time, such that:

425− --

426− -- > coincidence (pushAlways (\a -> (a <$) <$> now) e) = e

427− --

428− now :: m (Event t ())

429− default now :: (m ~ f m', MonadTrans f, MonadHold t m') => m (Event t ())

430− now = lift now

431−

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

433−-- using the combining function to produce a patch.

434−accumIncremental

435− :: (Reflex t, Patch p, MonadHold t m, MonadFix m)

436− => (PatchTarget p -> b -> p)

437− -> PatchTarget p

438− -> Event t b

439− -> m (Incremental t p)

440−accumIncremental f = accumMaybeIncremental $ \v o -> Just $ f v o

441−

442−-- | Similar to 'accumIncremental' but the combining function runs in 'PushM'

443−accumMIncremental

444− :: (Reflex t, Patch p, MonadHold t m, MonadFix m)

445− => (PatchTarget p -> b -> PushM t p)

446− -> PatchTarget p

447− -> Event t b

448− -> m (Incremental t p)

449−accumMIncremental f = accumMaybeMIncremental $ \v o -> Just <$> f v o

450−

451−-- | Similar to 'accumIncremental' but allows filtering of updates (by dropping updates when the

452−-- combining function produces @Nothing@)

453−accumMaybeIncremental

454− :: (Reflex t, Patch p, MonadHold t m, MonadFix m)

455− => (PatchTarget p -> b -> Maybe p)

456− -> PatchTarget p

457− -> Event t b

458− -> m (Incremental t p)

459−accumMaybeIncremental f = accumMaybeMIncremental $ \v o -> return $ f v o

460−

461−-- | Similar to 'accumMaybeMIncremental' but the combining function runs in 'PushM'

462−accumMaybeMIncremental

463− :: (Reflex t, Patch p, MonadHold t m, MonadFix m)

464− => (PatchTarget p -> b -> PushM t (Maybe p))

465− -> PatchTarget p

466− -> Event t b

467− -> m (Incremental t p)

468−accumMaybeMIncremental f z e = do

469− rec let e' = flip push e $ \o -> do

470− v <- sample $ currentIncremental d'

471− f v o

472− d' <- holdIncremental z e'

473− return d'

474−

475−-- | Accumulate an 'Incremental' by folding occurrences of an 'Event'

476−-- with a function that both accumulates and produces a value to fire

477−-- as an 'Event'. Returns both the accumulated value and the constructed

478−-- 'Event'.

479−mapAccumIncremental

480− :: (Reflex t, Patch p, MonadHold t m, MonadFix m)

481− => (PatchTarget p -> b -> (p, c))

482− -> PatchTarget p

483− -> Event t b

484− -> m (Incremental t p, Event t c)

485−mapAccumIncremental f = mapAccumMaybeIncremental $ \v o -> bimap Just Just $ f v o

486−

487−-- | Like 'mapAccumIncremental' but the combining function runs in 'PushM'

488−mapAccumMIncremental

489− :: (Reflex t, Patch p, MonadHold t m, MonadFix m)

490− => (PatchTarget p -> b -> PushM t (p, c))

491− -> PatchTarget p

492− -> Event t b

493− -> m (Incremental t p, Event t c)

494−mapAccumMIncremental f = mapAccumMaybeMIncremental $ \v o -> bimap Just Just <$> f v o

495−

496−-- | Accumulate an 'Incremental' by folding occurrences of an 'Event' with

497−-- a function that both optionally accumulates and optionally produces

498−-- a value to fire as a separate output 'Event'.

499−-- Note that because 'Nothing's are discarded in both cases, the output

500−-- 'Event' may fire even though the output 'Incremental' has not changed, and

501−-- the output 'Incremental' may update even when the output 'Event' is not firing.

502−mapAccumMaybeIncremental

503− :: (Reflex t, Patch p, MonadHold t m, MonadFix m)

504− => (PatchTarget p -> b -> (Maybe p, Maybe c))

505− -> PatchTarget p

506− -> Event t b

507− -> m (Incremental t p, Event t c)

508−mapAccumMaybeIncremental f = mapAccumMaybeMIncremental $ \v o -> return $ f v o

509−

510−-- | Like 'mapAccumMaybeIncremental' but the combining function is a 'PushM' action

511−mapAccumMaybeMIncremental

512− :: (Reflex t, Patch p, MonadHold t m, MonadFix m)

513− => (PatchTarget p -> b -> PushM t (Maybe p, Maybe c))

514− -> PatchTarget p

515− -> Event t b

516− -> m (Incremental t p, Event t c)

517−mapAccumMaybeMIncremental f z e = do

518− rec let e' = flip push e $ \o -> do

519− v <- sample $ currentIncremental d'

520− result <- f v o

521− return $ case result of

522− (Nothing, Nothing) -> Nothing

523− _ -> Just result

524− d' <- holdIncremental z $ mapMaybe fst e'

525− return (d', mapMaybe snd e')

526−

527−-- | A somewhat slow implementation of 'headE'

528−slowHeadE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)

529−slowHeadE e = do

530− rec be <- hold e $ fmapCheap (const never) e'

531− let e' = switch be

532− return e'

533

419

534-- | An 'EventSelector' allows you to efficiently 'select' an 'Event' based on a

420-- | An 'EventSelector' allows you to efficiently 'select' an 'Event' based on a

535-- key. This is much more efficient than filtering for each key with

421-- key. This is much more efficient than filtering for each key with

536−-- 'mapMaybe'.

422+-- 'fmapMaybe'.

537newtype EventSelector t k = EventSelector

423newtype EventSelector t k = EventSelector

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

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

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

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

540 -- 'Event's whose sub-'Event's have different types.

426 -- 'Event's whose sub-'Event's have different types.

541 --

427 --

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

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

543− -- (but equivalent to) using 'mapMaybe' to select only the relevant

429+ -- (but equivalent to) using 'fmapMaybe' to select only the relevant

544 -- occurrences of an 'Event'.

430 -- occurrences of an 'Event'.

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

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

546 }

432 }

547

433

548−newtype EventSelectorG t k v = EventSelectorG

549− { -- | Retrieve the 'Event' for the given key. The type of the 'Event' is

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

551− -- 'Event's whose sub-'Event's have different types.

552− --

553− -- Using 'EventSelector's and the 'fan' primitive is far more efficient than

554− -- (but equivalent to) using 'mapMaybe' to select only the relevant

555− -- occurrences of an 'Event'.

556− selectG :: forall a. k a -> Event t (v a)

557− }

558−

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

560−-- filtering by key.

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

562−

563--------------------------------------------------------------------------------

434--------------------------------------------------------------------------------

564-- Instances

435-- Instances

565--------------------------------------------------------------------------------

436--------------------------------------------------------------------------------

@@ -571,9 +442,6 @@ instance MonadHold t m => MonadHold t (ReaderT r m) where

571 hold a0 = lift . hold a0

442 hold a0 = lift . hold a0

572 holdDyn a0 = lift . holdDyn a0

443 holdDyn a0 = lift . holdDyn a0

573 holdIncremental a0 = lift . holdIncremental a0

444 holdIncremental a0 = lift . holdIncremental a0

574− buildDynamic a0 = lift . buildDynamic a0

575− headE = lift . headE

576− now = lift now

577

445

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

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

579 sample = lift . sample

447 sample = lift . sample

@@ -582,9 +450,6 @@ instance (MonadHold t m, Monoid r) => MonadHold t (WriterT r m) where

582 hold a0 = lift . hold a0

450 hold a0 = lift . hold a0

583 holdDyn a0 = lift . holdDyn a0

451 holdDyn a0 = lift . holdDyn a0

584 holdIncremental a0 = lift . holdIncremental a0

452 holdIncremental a0 = lift . holdIncremental a0

585− buildDynamic a0 = lift . buildDynamic a0

586− headE = lift . headE

587− now = lift now

588

453

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

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

590 sample = lift . sample

455 sample = lift . sample

@@ -593,9 +458,6 @@ instance MonadHold t m => MonadHold t (StateT s m) where

593 hold a0 = lift . hold a0

458 hold a0 = lift . hold a0

594 holdDyn a0 = lift . holdDyn a0

459 holdDyn a0 = lift . holdDyn a0

595 holdIncremental a0 = lift . holdIncremental a0

460 holdIncremental a0 = lift . holdIncremental a0

596− buildDynamic a0 = lift . buildDynamic a0

597− headE = lift . headE

598− now = lift now

599

461

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

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

601 sample = lift . sample

463 sample = lift . sample

@@ -604,9 +466,6 @@ instance MonadHold t m => MonadHold t (ExceptT e m) where

604 hold a0 = lift . hold a0

466 hold a0 = lift . hold a0

605 holdDyn a0 = lift . holdDyn a0

467 holdDyn a0 = lift . holdDyn a0

606 holdIncremental a0 = lift . holdIncremental a0

468 holdIncremental a0 = lift . holdIncremental a0

607− buildDynamic a0 = lift . buildDynamic a0

608− headE = lift . headE

609− now = lift now

610

469

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

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

612 sample = lift . sample

471 sample = lift . sample

@@ -615,9 +474,6 @@ instance (MonadHold t m, Monoid w) => MonadHold t (RWST r w s m) where

615 hold a0 = lift . hold a0

474 hold a0 = lift . hold a0

616 holdDyn a0 = lift . holdDyn a0

475 holdDyn a0 = lift . holdDyn a0

617 holdIncremental a0 = lift . holdIncremental a0

476 holdIncremental a0 = lift . holdIncremental a0

618− buildDynamic a0 = lift . buildDynamic a0

619− headE = lift . headE

620− now = lift now

621

477

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

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

623 sample = lift . sample

479 sample = lift . sample

@@ -626,9 +482,6 @@ instance MonadHold t m => MonadHold t (ContT r m) where

626 hold a0 = lift . hold a0

482 hold a0 = lift . hold a0

627 holdDyn a0 = lift . holdDyn a0

483 holdDyn a0 = lift . holdDyn a0

628 holdIncremental a0 = lift . holdIncremental a0

484 holdIncremental a0 = lift . holdIncremental a0

629− buildDynamic a0 = lift . buildDynamic a0

630− headE = lift . headE

631− now = lift now

632

485

633--------------------------------------------------------------------------------

486--------------------------------------------------------------------------------

634-- Convenience functions

487-- Convenience functions

@@ -643,14 +496,6 @@ pushAlways f = push (fmap Just . f)

643ffor :: Functor f => f a -> (a -> b) -> f b

496ffor :: Functor f => f a -> (a -> b) -> f b

644ffor = flip fmap

497ffor = flip fmap

645

498

646−-- | Rotated version of 'liftA2'.

647−ffor2 :: Applicative f => f a -> f b -> (a -> b -> c) -> f c

648−ffor2 a b f = liftA2 f a b

649−

650−-- | Rotated version of 'liftA3'.

651−ffor3 :: Applicative f => f a -> f b -> f c -> (a -> b -> c -> d) -> f d

652−ffor3 a b c f = liftA3 f a b c

653−

654instance Reflex t => Applicative (Behavior t) where

499instance Reflex t => Applicative (Behavior t) where

655 pure = constant

500 pure = constant

656 f <*> x = pull $ sample f `ap` sample x

501 f <*> x = pull $ sample f `ap` sample x

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

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

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

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

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

680 return = constant

525 return = constant

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

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

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

683−#endif

684

527

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

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

686 mempty = constant mempty

529 mempty = constant mempty

@@ -696,51 +539,32 @@ instance (Reflex t, Num a) => Num (Behavior t a) where

696 negate = fmap negate

539 negate = fmap negate

697 signum = fmap signum

540 signum = fmap signum

698

541

699−instance (Num a, Reflex t) => Num (Dynamic t a) where

700− (+) = liftA2 (+)

701− (*) = liftA2 (*)

702− abs = fmap abs

703− signum = fmap signum

704− fromInteger = pure . fromInteger

705− negate = fmap negate

706− (-) = liftA2 (-)

707−

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

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

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

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

710 sconcat = pull . fmap sconcat . mapM sample

544 sconcat = pull . fmap sconcat . mapM sample

545+#if MIN_VERSION_semigroups(0,17,0)

711 stimes n = fmap $ stimes n

546 stimes n = fmap $ stimes n

547+#else

548+ times1p n = fmap $ times1p n

549+#endif

712

550

713−-- | Alias for 'mapMaybe'

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

715−fmapMaybe = mapMaybe

716−

717−-- | Flipped version of 'mapMaybe'.

551+-- | Flipped version of 'fmapMaybe'.

718−fforMaybe :: Filterable f => f a -> (a -> Maybe b) -> f b

552+fforMaybe :: FunctorMaybe f => f a -> (a -> Maybe b) -> f b

719−fforMaybe = flip mapMaybe

553+fforMaybe = flip fmapMaybe

720

554

721-- | Filter 'f a' using the provided predicate.

555-- | Filter 'f a' using the provided predicate.

556+-- Relies on 'fforMaybe'.

722−ffilter :: Filterable f => (a -> Bool) -> f a -> f a

557+ffilter :: FunctorMaybe f => (a -> Bool) -> f a -> f a

723−ffilter = W.filter

558+ffilter f = fmapMaybe $ \x -> if f x then Just x else Nothing

724−

725−-- | Filter 'Left's from 'f (Either a b)' into 'a'.

726−filterLeft :: Filterable f => f (Either a b) -> f a

727−filterLeft = mapMaybe (either Just (const Nothing))

728−

729−-- | Filter 'Right's from 'f (Either a b)' into 'b'.

730−filterRight :: Filterable f => f (Either a b) -> f b

731−filterRight = mapMaybe (either (const Nothing) Just)

732

559

733-- | Left-biased event union (prefers left event on simultaneous

560-- | Left-biased event union (prefers left event on simultaneous

734-- occurrence).

561-- occurrence).

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

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

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

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

737

564

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

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

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

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

740− evf <.> evx = mapMaybe f (align evf evx) where

567+ evf <.> evx = coincidence (fmap (<$> evx) evf)

741− f (These g a) = Just (g a)

742− f _ = Nothing

743−

744

568

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

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

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

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

@@ -749,18 +573,11 @@ instance Reflex t => Bind (Event t) where

749

573

750instance Reflex t => Functor (Event t) where

574instance Reflex t => Functor (Event t) where

751 {-# INLINE fmap #-}

575 {-# INLINE fmap #-}

752− fmap f = mapMaybe $ Just . f

576+ fmap f = fmapMaybe $ Just . f

753− {-# INLINE (<$) #-}

754− x <$ e = fmapCheap (const x) e

755

577

756−-- TODO Remove this instance

757instance Reflex t => FunctorMaybe (Event t) where

578instance Reflex t => FunctorMaybe (Event t) where

758 {-# INLINE fmapMaybe #-}

579 {-# INLINE fmapMaybe #-}

759− fmapMaybe = mapMaybe

760−

761−instance Reflex t => Filterable (Event t) where

762− {-# INLINE mapMaybe #-}

763− mapMaybe f = push $ return . f

580+ fmapMaybe f = push $ return . f

764

581

765-- | Never: @'zero' = 'never'@.

582-- | Never: @'zero' = 'never'@.

766instance Reflex t => Plus (Event t) where

583instance Reflex t => Plus (Event t) where

@@ -771,13 +588,7 @@ instance Reflex t => Plus (Event t) where

771tag :: Reflex t => Behavior t b -> Event t a -> Event t b

588tag :: Reflex t => Behavior t b -> Event t a -> Event t b

772tag b = pushAlways $ \_ -> sample b

589tag b = pushAlways $ \_ -> sample b

773

590

774−-- | Replace each occurrence value of the 'Event' with the value of the

775−-- 'Behavior' at that time; if it is 'Just', fire with the contained value; if

776−-- it is 'Nothing', drop the occurrence.

777−tagMaybe :: Reflex t => Behavior t (Maybe b) -> Event t a -> Event t b

778−tagMaybe b = push $ \_ -> sample b

779−

780−-- | Create a new 'Event' that combines occurrences of supplied 'Event' with the

591+-- | Create a new 'Event' that combines occurences of supplied 'Event' with the

781-- current value of the 'Behavior'.

592-- current value of the 'Behavior'.

782attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b)

593attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b)

783attach = attachWith (,)

594attach = attachWith (,)

@@ -787,118 +598,48 @@ attach = attachWith (,)

787attachWith :: Reflex t => (a -> b -> c) -> Behavior t a -> Event t b -> Event t c

598attachWith :: Reflex t => (a -> b -> c) -> Behavior t a -> Event t b -> Event t c

788attachWith f = attachWithMaybe $ \a b -> Just $ f a b

599attachWith f = attachWithMaybe $ \a b -> Just $ f a b

789

600

790−-- | Create a new 'Event' by combining each occurrence with the current value of

601+-- | Create a new 'Event' by combining each occurence with the current value of

791-- the 'Behavior'. The occurrence is discarded if the combining function returns

602-- the 'Behavior'. The occurrence is discarded if the combining function returns

792-- Nothing

603-- Nothing

793attachWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c

604attachWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c

794attachWithMaybe f b e = flip push e $ \o -> (`f` o) <$> sample b

605attachWithMaybe f b e = flip push e $ \o -> (`f` o) <$> sample b

795

606

607+-- | Create a new 'Event' that only occurs only once, on the first occurence of

608+-- the supplied 'Event'.

609+headE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)

610+headE e = do

611+ rec be <- hold e $ fmap (const never) e'

612+ let e' = switch be

613+ return e'

614+

796−-- | Create a new 'Event' that occurs on all but the first occurrence of the

615+-- | Create a new 'Event' that occurs on all but the first occurence of the

797-- supplied 'Event'.

616-- supplied 'Event'.

798−tailE :: (Reflex t, MonadHold t m) => Event t a -> m (Event t a)

617+tailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)

799tailE e = snd <$> headTailE e

618tailE e = snd <$> headTailE e

800

619

801−-- | Create a tuple of two 'Event's with the first one occurring only the first

620+-- | Create a tuple of two 'Event's with the first one occuring only the first

802−-- time the supplied 'Event' occurs and the second occurring on all but the first

621+-- time the supplied 'Event' occurs and the second occuring on all but the first

803−-- occurrence.

622+-- occurence.

804−headTailE :: (Reflex t, MonadHold t m) => Event t a -> m (Event t a, Event t a)

623+headTailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a, Event t a)

805headTailE e = do

624headTailE e = do

806 eHead <- headE e

625 eHead <- headE e

807 be <- hold never $ fmap (const e) eHead

626 be <- hold never $ fmap (const e) eHead

808 return (eHead, switch be)

627 return (eHead, switch be)

809

628

810−-- | Take the streak of occurrences starting at the current time for which the

811−-- event returns 'True'.

812−--

813−-- Starting at the current time, fire all the occurrences of the 'Event' for

814−-- which the given predicate returns 'True'. When first 'False' is returned,

815−-- do not fire, and permanently stop firing, even if 'True' values would have

816−-- been encountered later.

817−takeWhileE

818− :: forall t m a

819− . (Reflex t, MonadFix m, MonadHold t m)

820− => (a -> Bool)

821− -> Event t a

822− -> m (Event t a)

823−takeWhileE f = takeWhileJustE $ \v -> guard (f v) $> v

824−

825−-- | Take the streak of occurrences starting at the current time for which the

826−-- event returns 'Just b'.

827−--

828−-- Starting at the current time, fire all the occurrences of the 'Event' for

829−-- which the given predicate returns 'Just b'. When first 'Nothing' is returned,

830−-- do not fire, and permanently stop firing, even if 'Just b' values would have

831−-- been encountered later.

832−takeWhileJustE

833− :: forall t m a b

834− . (Reflex t, MonadFix m, MonadHold t m)

835− => (a -> Maybe b)

836− -> Event t a

837− -> m (Event t b)

838−takeWhileJustE f e = do

839− rec let (eBad, eTrue) = fanEither $ ffor e' $ \a -> case f a of

840− Nothing -> Left never

841− Just b -> Right b

842− eFirstBad <- headE eBad

843− e' <- switchHold e eFirstBad

844− return eTrue

845−

846−-- | Drop the streak of occurrences starting at the current time for which the

847−-- event returns 'True'.

848−--

849−-- Starting at the current time, do not fire all the occurrences of the 'Event'

850−-- for which the given predicate returns 'True'. When 'False' is first

851−-- returned, do fire, and permanently continue firing, even if 'True' values

852−-- would have been encountered later.

853−dropWhileE

854− :: forall t m a

855− . (Reflex t, MonadFix m, MonadHold t m)

856− => (a -> Bool)

857− -> Event t a

858− -> m (Event t a)

859−dropWhileE f e = snd <$> takeDropWhileJustE (\v -> guard (f v) $> v) e

860−

861−-- | Both take and drop the streak of occurrences starting at the current time

862−-- for which the event returns 'Just b'.

863−--

864−-- For the left event, starting at the current time, fire all the occurrences

865−-- of the 'Event' for which the given function returns 'Just b'. When

866−-- 'Nothing' is returned, do not fire, and permanently stop firing, even if

867−-- 'Just b' values would have been encountered later.

868−--

869−-- For the right event, do not fire until the first occurrence where the given

870−-- function returns 'Nothing', and fire that one and all subsequent

871−-- occurrences. Even if the function would have again returned 'Just b', keep

872−-- on firing.

873−takeDropWhileJustE

874− :: forall t m a b

875− . (Reflex t, MonadFix m, MonadHold t m)

876− => (a -> Maybe b)

877− -> Event t a

878− -> m (Event t b, Event t a)

879−takeDropWhileJustE f e = do

880− rec let (eBad, eGood) = fanEither $ ffor e' $ \a -> case f a of

881− Nothing -> Left ()

882− Just b -> Right b

883− eFirstBad <- headE eBad

884− e' <- switchHold e (never <$ eFirstBad)

885− eRest <- switchHoldPromptOnly never (e <$ eFirstBad)

886− return (eGood, eRest)

887−

888−-- | Split the supplied 'Event' into two individual 'Event's occurring at the

629+-- | Split the supplied 'Event' into two individual 'Event's occuring at the

889-- same time with the respective values from the tuple.

630-- same time with the respective values from the tuple.

890splitE :: Reflex t => Event t (a, b) -> (Event t a, Event t b)

631splitE :: Reflex t => Event t (a, b) -> (Event t a, Event t b)

891splitE e = (fmap fst e, fmap snd e)

632splitE e = (fmap fst e, fmap snd e)

892

633

893-- | Print the supplied 'String' and the value of the 'Event' on each

634-- | Print the supplied 'String' and the value of the 'Event' on each

894−-- occurrence. This should /only/ be used for debugging.

635+-- occurence. This should /only/ be used for debugging.

895--

636--

896-- Note: As with Debug.Trace.trace, the message will only be printed if the

637-- Note: As with Debug.Trace.trace, the message will only be printed if the

897-- 'Event' is actually used.

638-- 'Event' is actually used.

898traceEvent :: (Reflex t, Show a) => String -> Event t a -> Event t a

639traceEvent :: (Reflex t, Show a) => String -> Event t a -> Event t a

899traceEvent s = traceEventWith $ \x -> s <> ": " <> show x

640traceEvent s = traceEventWith $ \x -> s <> ": " <> show x

900

641

901−-- | Print the output of the supplied function on each occurrence of the

642+-- | Print the output of the supplied function on each occurence of the

902-- 'Event'. This should /only/ be used for debugging.

643-- 'Event'. This should /only/ be used for debugging.

903--

644--

904-- Note: As with Debug.Trace.trace, the message will only be printed if the

645-- Note: As with Debug.Trace.trace, the message will only be printed if the

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

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

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

910 (<>) = alignWith (mergeThese (<>))

651 (<>) = alignWith (mergeThese (<>))

911 sconcat = fmap sconcat . mergeList . toList

652 sconcat = fmap sconcat . mergeList . toList

653+#if MIN_VERSION_semigroups(0,17,0)

912 stimes n = fmap $ stimes n

654 stimes n = fmap $ stimes n

655+#else

656+ times1p n = fmap $ times1p n

657+#endif

913

658

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

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

915 mempty = never

660 mempty = never

@@ -925,9 +670,10 @@ mergeWith = mergeWith' id

925

670

926{-# INLINE mergeWith' #-}

671{-# INLINE mergeWith' #-}

927mergeWith' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b

672mergeWith' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b

928−mergeWith' f g es = fmap (Prelude.foldl1 g . fmap f)

673+mergeWith' f g es = fmap (Prelude.foldl1 g . map (\(Const2 _ :=> Identity v) -> f v) . DMap.toList)

929− . mergeInt

674+ . merge

930− . IntMap.fromDistinctAscList

675+ . DMap.fromDistinctAscList

676+ . map (\(k, v) -> Const2 k :=> v)

931 $ zip [0 :: Int ..] es

677 $ zip [0 :: Int ..] es

932

678

933-- | Create a new 'Event' that occurs if at least one of the 'Event's in the

679-- | Create a new 'Event' that occurs if at least one of the 'Event's in the

@@ -938,38 +684,25 @@ leftmost :: Reflex t => [Event t a] -> Event t a

938leftmost = mergeWith const

684leftmost = mergeWith const

939

685

940-- | Create a new 'Event' that occurs if at least one of the 'Event's in the

686-- | Create a new 'Event' that occurs if at least one of the 'Event's in the

941−-- list occurs and has a list of the values of all 'Event's occurring at that

687+-- list occurs and has a list of the values of all 'Event's occuring at that

942-- time.

688-- time.

943mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a)

689mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a)

944mergeList [] = never

690mergeList [] = never

945−mergeList es = mergeWithFoldCheap' id es

691+mergeList es = mergeWithCheap' (:|[]) (<>) es

946−

692+

947−unsafeMapIncremental

948− :: (Reflex t, Patch p, Patch p')

949− => (PatchTarget p -> PatchTarget p')

693+unsafeMapIncremental :: (Reflex t, Patch p, Patch p') => (PatchTarget p -> PatchTarget p') -> (p -> p') -> Incremental t p -> Incremental t p'

950− -> (p -> p')

951− -> Incremental t p

952− -> Incremental t p'

953unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ g <$> updatedIncremental a

694unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ g <$> updatedIncremental a

954

695

955-- | Create a new 'Event' combining the map of 'Event's into an 'Event' that

696-- | Create a new 'Event' combining the map of 'Event's into an 'Event' that

956-- occurs if at least one of them occurs and has a map of values of all 'Event's

697-- occurs if at least one of them occurs and has a map of values of all 'Event's

957−-- occurring at that time.

698+-- occuring at that time.

958mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a)

699mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a)

959mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap

700mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap

960

701

961−-- | Like 'mergeMap' but for 'IntMap'.

962−mergeIntMap :: Reflex t => IntMap (Event t a) -> Event t (IntMap a)

963−mergeIntMap = fmap dmapToIntMap . merge . intMapWithFunctorToDMap

964−

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

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

966mergeMapIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Event t a)) -> Event t (Map k a)

703mergeMapIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Event t a)) -> Event t (Map k a)

967mergeMapIncremental = fmap dmapToMap . mergeIncremental . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWith id)

704mergeMapIncremental = fmap dmapToMap . mergeIncremental . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWith id)

968

705

969−-- | Create a merge whose parents can change over time

970−mergeIntMapIncremental :: Reflex t => Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)

971−mergeIntMapIncremental = fmap dmapToIntMap . mergeIncremental . unsafeMapIncremental intMapWithFunctorToDMap (const2IntPatchDMapWith id)

972−

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

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

974mergeMapIncrementalWithMove :: (Reflex t, Ord k) => Incremental t (PatchMapWithMove k (Event t a)) -> Event t (Map k a)

707mergeMapIncrementalWithMove :: (Reflex t, Ord k) => Incremental t (PatchMapWithMove k (Event t a)) -> Event t (Map k a)

975mergeMapIncrementalWithMove = fmap dmapToMap . mergeIncrementalWithMove . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWithMoveWith id)

708mergeMapIncrementalWithMove = fmap dmapToMap . mergeIncrementalWithMove . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWithMoveWith id)

@@ -979,7 +712,7 @@ fanEither :: Reflex t => Event t (Either a b) -> (Event t a, Event t b)

979fanEither e =

712fanEither e =

980 let justLeft = either Just (const Nothing)

713 let justLeft = either Just (const Nothing)

981 justRight = either (const Nothing) Just

714 justRight = either (const Nothing) Just

982− in (mapMaybe justLeft e, mapMaybe justRight e)

715+ in (fmapMaybe justLeft e, fmapMaybe justRight e)

983

716

984-- | Split the event into separate events for 'This' and 'That' values,

717-- | Split the event into separate events for 'This' and 'That' values,

985-- allowing them to fire simultaneously when the input value is 'These'.

718-- allowing them to fire simultaneously when the input value is 'These'.

@@ -991,141 +724,47 @@ fanThese e =

991 that (That y) = Just y

724 that (That y) = Just y

992 that (These _ y) = Just y

725 that (These _ y) = Just y

993 that _ = Nothing

726 that _ = Nothing

994− in (mapMaybe this e, mapMaybe that e)

727+ in (fmapMaybe this e, fmapMaybe that e)

995

728

996-- | Split the event into an 'EventSelector' that allows efficient selection of

729-- | Split the event into an 'EventSelector' that allows efficient selection of

997-- the individual 'Event's.

730-- the individual 'Event's.

998fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a)

731fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a)

999fanMap = fan . fmap mapToDMap

732fanMap = fan . fmap mapToDMap

1000

733

1001−-- | Switches to the new event whenever it receives one. Only the old event is

734+-- | Switches to the new event whenever it receives one. Whenever a new event

1002−-- considered the moment a new one is switched in; the output event will fire at

1003−-- that moment only if the old event does.

1004−--

1005−-- Because the simultaneous firing case is irrelevant, this function imposes

1006−-- laxer "timing requirements" on the overall circuit, avoiding many potential

1007−-- cyclic dependency / metastability failures. It's also more performant. Use

1008−-- this rather than 'switchHoldPromptly' and 'switchHoldPromptOnly' unless you

1009−-- are absolutely sure you need to act on the new event in the coincidental

1010−-- case.

1011−switchHold :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)

1012−switchHold ea0 eea = switch <$> hold ea0 eea

1013−

1014−-- | Switches to the new event whenever it receives one. Whenever a new event is

1015−-- provided, if it is firing, its value will be the resulting event's value; if

735+-- is provided, if it is firing, its value will be the resulting event's value;

1016−-- it is not firing, but the old one is, the old one's value will be used.

736+-- if it is not firing, but the old one is, the old one's value will be used.

1017−--

1018−-- 'switchHold', by always forwarding the old event the moment it is switched

1019−-- out, avoids many potential cyclic dependency problems / metastability

1020−-- problems. It's also more performant. Use it instead unless you are sure you

1021−-- cannot.

1022−switchHoldPromptly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)

737+switchPromptly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)

1023−switchHoldPromptly ea0 eea = do

738+switchPromptly ea0 eea = do

1024 bea <- hold ea0 eea

739 bea <- hold ea0 eea

1025 let eLag = switch bea

740 let eLag = switch bea

1026 eCoincidences = coincidence eea

741 eCoincidences = coincidence eea

1027 return $ leftmost [eCoincidences, eLag]

742 return $ leftmost [eCoincidences, eLag]

1028

743

1029−-- | switches to a new event whenever it receives one. At the moment of

744+-- | 'switch'es to a new event whenever it receives one. At the moment of

1030-- switching, the old event will be ignored if it fires, and the new one will be

745-- switching, the old event will be ignored if it fires, and the new one will be

1031-- used if it fires; this is the opposite of 'switch', which will use only the

746-- used if it fires; this is the opposite of 'switch', which will use only the

1032-- old value.

747-- old value.

1033−--

1034−-- 'switchHold', by always forwarding the old event the moment it is switched

1035−-- out, avoids many potential cyclic dependency problems / metastability

1036−-- problems. It's also more performant. Use it instead unless you are sure you

1037−-- cannot.

1038−switchHoldPromptOnly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)

748+switchPromptOnly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)

1039−switchHoldPromptOnly e0 e' = do

749+switchPromptOnly e0 e' = do

1040 eLag <- switch <$> hold e0 e'

750 eLag <- switch <$> hold e0 e'

1041 return $ coincidence $ leftmost [e', eLag <$ eLag]

751 return $ coincidence $ leftmost [e', eLag <$ eLag]

1042

752

1043−-- | When the given outer event fires, condense the inner events into the contained patch. Non-firing inner events will be replaced with deletions.

1044−coincidencePatchMap :: (Reflex t, Ord k) => Event t (PatchMap k (Event t v)) -> Event t (PatchMap k v)

1045−coincidencePatchMap e = fmapCheap PatchMap $ coincidence $ ffor e $ \(PatchMap m) -> mergeMap $ ffor m $ \case

1046− Nothing -> fmapCheap (const Nothing) e

1047− Just ev -> leftmost [fmapCheap Just ev, fmapCheap (const Nothing) e]

1048−

1049−-- | See 'coincidencePatchMap'

1050−coincidencePatchIntMap :: Reflex t => Event t (PatchIntMap (Event t v)) -> Event t (PatchIntMap v)

1051−coincidencePatchIntMap e = fmapCheap PatchIntMap $ coincidence $ ffor e $ \(PatchIntMap m) -> mergeIntMap $ ffor m $ \case

1052− Nothing -> fmapCheap (const Nothing) e

1053− Just ev -> leftmost [fmapCheap Just ev, fmapCheap (const Nothing) e]

1054−

1055−-- | See 'coincidencePatchMap'

1056−coincidencePatchMapWithMove :: (Reflex t, Ord k) => Event t (PatchMapWithMove k (Event t v)) -> Event t (PatchMapWithMove k v)

1057−coincidencePatchMapWithMove e = fmapCheap unsafePatchMapWithMove $ coincidence $ ffor e $ \p -> mergeMap $ ffor (unPatchMapWithMove p) $ \ni -> case PatchMapWithMove._nodeInfo_from ni of

1058− PatchMapWithMove.From_Delete -> fforCheap e $ \_ ->

1059− ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Delete }

1060− PatchMapWithMove.From_Move k -> fforCheap e $ \_ ->

1061− ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Move k }

1062− PatchMapWithMove.From_Insert ev -> leftmost

1063− [ fforCheap ev $ \v ->

1064− ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Insert v }

1065− , fforCheap e $ \_ ->

1066− ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Delete }

1067− ]

1068−

1069−-- | Given a 'PatchTarget' of events (e.g., a 'Map' with 'Event' values) and an event of 'Patch'es

1070−-- (e.g., a 'PatchMap' with 'Event' values), produce an 'Event' of the 'PatchTarget' type that

1071−-- fires with the patched value.

1072−switchHoldPromptOnlyIncremental

1073− :: forall t m p pt w

1074− . ( Reflex t

1075− , MonadHold t m

1076− , Patch (p (Event t w))

1077− , PatchTarget (p (Event t w)) ~ pt (Event t w)

1078− , Patch (p w)

1079− , PatchTarget (p w) ~ pt w

1080− , Monoid (pt w)

1081− )

1082− => (Incremental t (p (Event t w)) -> Event t (pt w))

1083− -> (Event t (p (Event t w)) -> Event t (p w))

1084− -> pt (Event t w)

1085− -> Event t (p (Event t w))

1086− -> m (Event t (pt w))

1087−switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch e0 e' = do

1088− lag <- mergePatchIncremental <$> holdIncremental e0 e'

1089− pure $ ffor (align lag (coincidencePatch e')) $ \case

1090− This old -> old

1091− That new -> new `applyAlways` mempty

1092− These old new -> new `applyAlways` old

1093−

1094instance Reflex t => Align (Event t) where

753instance Reflex t => Align (Event t) where

1095 nil = never

754 nil = never

1096−#if MIN_VERSION_these(0, 8, 0)

1097−instance Reflex t => Semialign (Event t) where

1098−#endif

1099 align = alignEventWithMaybe Just

755 align = alignEventWithMaybe Just

1100

756

1101−#ifdef MIN_VERSION_semialign

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

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

1104−#endif

1105− zip x y = mapMaybe justThese $ align x y

1106−#endif

1107−

1108−#ifdef MIN_VERSION_semialign

1109−#if MIN_VERSION_semialign(1,1,0)

1110−instance Reflex t => Unzip (Event t) where

1111− unzip = splitE

1112−#endif

1113−#endif

1114−

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

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

1116−-- the 'Behavior' is true at the time of occurrence.

758+-- the 'Behavior' is true at the time of occurence.

1117gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a

759gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a

1118gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing

760gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing

1119

761

1120−-- | Create a new behavior given a starting behavior and switch to the behavior

762+-- | Create a new behavior given a starting behavior and switch to a the behvior

1121−-- carried by the event when it fires.

763+-- carried by the event when it fires.

1122switcher :: (Reflex t, MonadHold t m)

764switcher :: (Reflex t, MonadHold t m)

1123 => Behavior t a -> Event t (Behavior t a) -> m (Behavior t a)

765 => Behavior t a -> Event t (Behavior t a) -> m (Behavior t a)

1124switcher b eb = pull . (sample <=< sample) <$> hold b eb

766switcher b eb = pull . (sample <=< sample) <$> hold b eb

1125

767

1126−instance (Reflex t, IsString a) => IsString (Dynamic t a) where

1127− fromString = pure . fromString

1128−

1129-- | Combine two 'Dynamic's. The result will change whenever either (or both)

768-- | Combine two 'Dynamic's. The result will change whenever either (or both)

1130-- input 'Dynamic' changes. Equivalent to @zipDynWith (,)@.

769-- input 'Dynamic' changes. Equivalent to @zipDynWith (,)@.

1131zipDyn :: Reflex t => Dynamic t a -> Dynamic t b -> Dynamic t (a, b)

770zipDyn :: Reflex t => Dynamic t a -> Dynamic t b -> Dynamic t (a, b)

@@ -1133,7 +772,7 @@ zipDyn = zipDynWith (,)

1133

772

1134-- | Combine two 'Dynamic's with a combining function. The result will change

773-- | Combine two 'Dynamic's with a combining function. The result will change

1135-- whenever either (or both) input 'Dynamic' changes.

774-- whenever either (or both) input 'Dynamic' changes.

1136−-- More efficient than 'liftA2'.

775+-- More efficient than liftA2.

1137zipDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> Dynamic t c

776zipDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> Dynamic t c

1138zipDynWith f da db =

777zipDynWith f da db =

1139 let eab = align (updated da) (updated db)

778 let eab = align (updated da) (updated db)

@@ -1149,10 +788,6 @@ zipDynWith f da db =

1149 return $ Just $ f a b

788 return $ Just $ f a b

1150 in unsafeBuildDynamic (f <$> sample (current da) <*> sample (current db)) ec

789 in unsafeBuildDynamic (f <$> sample (current da) <*> sample (current db)) ec

1151

790

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

1153− (<>) = zipDynWith (<>)

1154− stimes n = fmap $ stimes n

1155−

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

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

1157 mconcat = distributeListOverDynWith mconcat

792 mconcat = distributeListOverDynWith mconcat

1158 mempty = constDyn mempty

793 mempty = constDyn mempty

@@ -1160,23 +795,14 @@ instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where

1160

795

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

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

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

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

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

798+-- through the use of multiple uses of 'zipWithDyn' or 'Applicative' operators.

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

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

1165−distributeDMapOverDynPure = distributeDMapOverDynPureG coerceDynamic

800+distributeDMapOverDynPure dm = case DMap.toList dm of

1166−

1167−-- | This function converts a 'DMap' whose elements are 'Dynamic's into a

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

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

1170−distributeDMapOverDynPureG

1171− :: forall t k q v. (Reflex t, GCompare k)

1172− => (forall a. q a -> Dynamic t (v a))

1173− -> DMap k q -> Dynamic t (DMap k v)

1174−distributeDMapOverDynPureG nt dm = case DMap.toList dm of

1175 [] -> constDyn DMap.empty

801 [] -> constDyn DMap.empty

1176− [k :=> v] -> DMap.singleton k <$> nt v

802+ [k :=> v] -> fmap (DMap.singleton k . Identity) v

1177 _ ->

803 _ ->

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

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

1179− edmPre = mergeG getCompose $ DMap.map (Compose . updated . nt) dm

805+ edmPre = merge $ DMap.map updated dm

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

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

1181 olds <- sample $ current result

807 olds <- sample $ current result

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

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

@@ -1188,73 +814,21 @@ distributeListOverDyn = distributeListOverDynWith id

1188

814

1189-- | Create a new 'Dynamic' by applying a combining function to a list of 'Dynamic's

815-- | Create a new 'Dynamic' by applying a combining function to a list of 'Dynamic's

1190distributeListOverDynWith :: Reflex t => ([a] -> b) -> [Dynamic t a] -> Dynamic t b

816distributeListOverDynWith :: Reflex t => ([a] -> b) -> [Dynamic t a] -> Dynamic t b

1191−distributeListOverDynWith f =

817+distributeListOverDynWith f = fmap (f . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList) . distributeDMapOverDynPure . DMap.fromList . map (\(k, v) -> Const2 k :=> v) . zip [0 :: Int ..]

1192− fmap (f . map fromDSum . DMap.toAscList) .

1193− distributeDMapOverDynPure .

1194− DMap.fromDistinctAscList .

1195− zipWith toDSum [0..]

1196− where

1197− toDSum :: Int -> Dynamic t a -> DSum (Const2 Int a) (Dynamic t)

1198− toDSum k v = Const2 k :=> v

1199− fromDSum :: DSum (Const2 Int a) Identity -> a

1200− fromDSum (Const2 _ :=> Identity v) = v

1201

818

1202-- | Create a new 'Event' that occurs when the first supplied 'Event' occurs

819-- | Create a new 'Event' that occurs when the first supplied 'Event' occurs

1203-- unless the second supplied 'Event' occurs simultaneously.

820-- unless the second supplied 'Event' occurs simultaneously.

1204difference :: Reflex t => Event t a -> Event t b -> Event t a

821difference :: Reflex t => Event t a -> Event t b -> Event t a

1205difference = alignEventWithMaybe $ \case

822difference = alignEventWithMaybe $ \case

1206 This a -> Just a

823 This a -> Just a

1207− _ -> Nothing

824+ _ -> Nothing

1208

825

1209−-- | Zips two values by taking the union of their shapes and combining with the provided function.

1210−-- 'Nothing' values are dropped.

1211alignEventWithMaybe :: Reflex t => (These a b -> Maybe c) -> Event t a -> Event t b -> Event t c

826alignEventWithMaybe :: Reflex t => (These a b -> Maybe c) -> Event t a -> Event t b -> Event t c

1212−alignEventWithMaybe f ea eb = mapMaybe (f <=< dmapToThese) $

827+alignEventWithMaybe f ea eb =

828+ fmapMaybe (f <=< dmapToThese)

829+ $ merge

1213− merge $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]

830+ $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]

1214−

831+

1215−-- | Produces an 'Event' that fires only when the input event fires with a 'DSum' key that

1216−-- matches the provided key.

1217−filterEventKey

1218− :: forall t m k v a.

1219− ( Reflex t

1220− , MonadFix m

1221− , MonadHold t m

1222− , GEq k

1223− )

1224− => k a

1225− -> Event t (DSum k v)

1226− -> m (Event t (v a))

1227−filterEventKey k kv' = do

1228− let f :: DSum k v -> Maybe (v a)

1229− f (newK :=> newV) = case newK `geq` k of

1230− Just Refl -> Just newV

1231− Nothing -> Nothing

1232− takeWhileJustE f kv'

1233−

1234−-- | "Factor" the input 'DSum' 'Event' to produce an 'Event' which

1235−-- fires when the 'DSum' key changes and contains both the value of the

1236−-- 'DSum' at switchover and an 'Event' of values produced by subsequent

1237−-- firings of the input 'Event' that do not change the 'DSum' key.

1238−factorEvent

1239− :: forall t m k v a.

1240− ( Reflex t

1241− , MonadFix m

1242− , MonadHold t m

1243− , GEq k

1244− )

1245− => k a

1246− -> Event t (DSum k v)

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

1248−factorEvent k0 kv' = do

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

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

1251− Some oldKey -> case newKey `geq` oldKey of

1252− Just Refl -> return Nothing

1253− Nothing -> do

1254− newInner <- filterEventKey newKey kv'

1255− return $ Just $ newKey :=> Pair newVal (Compose newInner)

1256− eInitial <- filterEventKey k0 kv'

1257− return (eInitial, update)

1258

832

1259--------------------------------------------------------------------------------

833--------------------------------------------------------------------------------

1260-- Accumulator

834-- Accumulator

@@ -1262,12 +836,6 @@ factorEvent k0 kv' = do

1262

836

1263-- | An 'Accumulator' type can be built by accumulating occurrences of an

837-- | An 'Accumulator' type can be built by accumulating occurrences of an

1264-- 'Event'.

838-- 'Event'.

1265−#if __GLASGOW_HASKELL__ < 802

1266−{-# WARNING accum "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-}

1267−{-# WARNING accumM "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-}

1268−{-# WARNING accumMaybe "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-}

1269−{-# WARNING accumMaybeM "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-}

1270−#endif

1271class Reflex t => Accumulator t f | f -> t where

839class Reflex t => Accumulator t f | f -> t where

1272 accum :: (MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (f a)

840 accum :: (MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (f a)

1273 accum f = accumMaybe $ \v o -> Just $ f v o

841 accum f = accumMaybe $ \v o -> Just $ f v o

@@ -1284,239 +852,61 @@ class Reflex t => Accumulator t f | f -> t where

1284 mapAccumMaybe f = mapAccumMaybeM $ \v o -> return $ f v o

852 mapAccumMaybe f = mapAccumMaybeM $ \v o -> return $ f v o

1285 mapAccumMaybeM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (f a, Event t c)

853 mapAccumMaybeM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (f a, Event t c)

1286

854

1287−-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event'

1288−-- with the provided function. See 'foldDyn'.

1289−accumDyn

1290− :: (Reflex t, MonadHold t m, MonadFix m)

1291− => (a -> b -> a)

1292− -> a

1293− -> Event t b

1294− -> m (Dynamic t a)

1295−accumDyn f = accumMaybeDyn $ \v o -> Just $ f v o

1296−

1297−-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event'

1298−-- with the provided 'PushM' action.

1299−accumMDyn

1300− :: (Reflex t, MonadHold t m, MonadFix m)

1301− => (a -> b -> PushM t a)

1302− -> a

1303− -> Event t b

1304− -> m (Dynamic t a)

1305−accumMDyn f = accumMaybeMDyn $ \v o -> Just <$> f v o

1306−

1307−-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event'

1308−-- with the provided function, discarding 'Nothing' results.

1309−accumMaybeDyn

1310− :: (Reflex t, MonadHold t m, MonadFix m)

1311− => (a -> b -> Maybe a)

1312− -> a

1313− -> Event t b

1314− -> m (Dynamic t a)

1315−accumMaybeDyn f = accumMaybeMDyn $ \v o -> return $ f v o

1316−

1317−-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event'

1318−-- with the provided 'PushM' action, discarding 'Nothing' results.

1319−accumMaybeMDyn

1320− :: (Reflex t, MonadHold t m, MonadFix m)

1321− => (a -> b -> PushM t (Maybe a))

1322− -> a

1323− -> Event t b

1324− -> m (Dynamic t a)

1325−accumMaybeMDyn f z e = do

1326− rec let e' = flip push e $ \o -> do

1327− v <- sample $ current d'

1328− f v o

1329− d' <- holdDyn z e'

1330− return d'

1331−

1332−-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event'

1333−-- with a function that both accumulates and produces a value to fire

1334−-- as an 'Event'. Returns both the accumulated value and an 'Event'.

1335−mapAccumDyn

1336− :: (Reflex t, MonadHold t m, MonadFix m)

1337− => (a -> b -> (a, c))

1338− -> a

1339− -> Event t b

1340− -> m (Dynamic t a, Event t c)

1341−mapAccumDyn f = mapAccumMaybeDyn $ \v o -> bimap Just Just $ f v o

1342−

1343−-- | Similar to 'mapAccumDyn' except that the combining function is a

1344−-- 'PushM' action.

1345−mapAccumMDyn

1346− :: (Reflex t, MonadHold t m, MonadFix m)

1347− => (a -> b -> PushM t (a, c))

1348− -> a

1349− -> Event t b

1350− -> m (Dynamic t a, Event t c)

1351−mapAccumMDyn f = mapAccumMaybeMDyn $ \v o -> bimap Just Just <$> f v o

1352−

1353−-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event' with

1354−-- a function that both optionally accumulates and optionally produces

1355−-- a value to fire as a separate output 'Event'.

1356−-- Note that because 'Nothing's are discarded in both cases, the output

1357−-- 'Event' may fire even though the output 'Dynamic' has not changed, and

1358−-- the output 'Dynamic' may update even when the output 'Event' is not firing.

1359−mapAccumMaybeDyn

1360− :: (Reflex t, MonadHold t m, MonadFix m)

1361− => (a -> b -> (Maybe a, Maybe c))

1362− -> a

1363− -> Event t b

1364− -> m (Dynamic t a, Event t c)

1365−mapAccumMaybeDyn f = mapAccumMaybeMDyn $ \v o -> return $ f v o

1366−

1367−-- | Like 'mapAccumMaybeDyn' except that the combining function is a

1368−-- 'PushM' action.

1369−mapAccumMaybeMDyn

1370− :: (Reflex t, MonadHold t m, MonadFix m)

1371− => (a -> b -> PushM t (Maybe a, Maybe c))

1372− -> a

1373− -> Event t b

1374− -> m (Dynamic t a, Event t c)

1375−mapAccumMaybeMDyn f z e = do

1376− rec let e' = flip push e $ \o -> do

1377− v <- sample $ current d'

1378− result <- f v o

1379− return $ case result of

1380− (Nothing, Nothing) -> Nothing

1381− _ -> Just result

1382− d' <- holdDyn z $ mapMaybe fst e'

1383− return (d', mapMaybe snd e')

1384−

1385−-- | Accumulate a 'Behavior' by folding occurrences of an 'Event'

1386−-- with the provided function.

1387−{-# INLINE accumB #-}

1388−accumB

1389− :: (Reflex t, MonadHold t m, MonadFix m)

1390− => (a -> b -> a)

1391− -> a

1392− -> Event t b

1393− -> m (Behavior t a)

1394−accumB f = accumMaybeB $ \v o -> Just $ f v o

1395−

1396−-- | Like 'accumB' except that the combining function is a 'PushM' action.

1397−{-# INLINE accumMB #-}

1398−accumMB

1399− :: (Reflex t, MonadHold t m, MonadFix m)

1400− => (a -> b -> PushM t a)

1401− -> a

1402− -> Event t b

1403− -> m (Behavior t a)

1404−accumMB f = accumMaybeMB $ \v o -> Just <$> f v o

1405−

1406−-- | Accumulate a 'Behavior' by folding occurrences of an 'Event'

1407−-- with the provided function, discarding 'Nothing' results.

1408−{-# INLINE accumMaybeB #-}

1409−accumMaybeB

1410− :: (Reflex t, MonadHold t m, MonadFix m)

1411− => (a -> b -> Maybe a)

1412− -> a

1413− -> Event t b

1414− -> m (Behavior t a)

1415−accumMaybeB f = accumMaybeMB $ \v o -> return $ f v o

1416−

1417−-- | Like 'accumMaybeB' except that the combining function is a 'PushM' action.

1418−{-# INLINE accumMaybeMB #-}

1419−accumMaybeMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (Behavior t a)

1420−accumMaybeMB f z e = do

1421− rec let e' = flip push e $ \o -> do

1422− v <- sample d'

1423− f v o

1424− d' <- hold z e'

1425− return d'

1426−

1427−-- | Accumulate a 'Behavior' by folding occurrences of an 'Event'

1428−-- with a function that both accumulates and produces a value to fire

1429−-- as an 'Event'. Returns both the accumulated value and an 'Event'.

1430−{-# INLINE mapAccumB #-}

1431−mapAccumB

1432− :: (Reflex t, MonadHold t m, MonadFix m)

1433− => (a -> b -> (a, c))

1434− -> a

1435− -> Event t b

1436− -> m (Behavior t a, Event t c)

1437−mapAccumB f = mapAccumMaybeB $ \v o -> bimap Just Just $ f v o

1438−

1439−-- | Like 'mapAccumB' except that the combining function is a 'PushM' action.

1440−{-# INLINE mapAccumMB #-}

1441−mapAccumMB

1442− :: (Reflex t, MonadHold t m, MonadFix m)

1443− => (a -> b -> PushM t (a, c))

1444− -> a

1445− -> Event t b

1446− -> m (Behavior t a, Event t c)

1447−mapAccumMB f = mapAccumMaybeMB $ \v o -> bimap Just Just <$> f v o

1448−

1449−-- | Accumulate a 'Behavior' by folding occurrences of an 'Event' with

1450−-- a function that both optionally accumulates and optionally produces

1451−-- a value to fire as a separate output 'Event'. 'Nothing's are discarded.

1452−{-# INLINE mapAccumMaybeB #-}

1453−mapAccumMaybeB

1454− :: (Reflex t, MonadHold t m, MonadFix m)

1455− => (a -> b -> (Maybe a, Maybe c))

1456− -> a

1457− -> Event t b

1458− -> m (Behavior t a, Event t c)

1459−mapAccumMaybeB f = mapAccumMaybeMB $ \v o -> return $ f v o

1460−

1461−-- | Like 'mapAccumMaybeB' except that the combining function is a 'PushM' action.

1462−{-# INLINE mapAccumMaybeMB #-}

1463−mapAccumMaybeMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (Behavior t a, Event t c)

1464−mapAccumMaybeMB f z e = do

1465− rec let e' = flip push e $ \o -> do

1466− v <- sample d'

1467− result <- f v o

1468− return $ case result of

1469− (Nothing, Nothing) -> Nothing

1470− _ -> Just result

1471− d' <- hold z $ mapMaybe fst e'

1472− return (d', mapMaybe snd e')

1473−

1474-- | Accumulate occurrences of an 'Event', producing an output occurrence each

855-- | Accumulate occurrences of an 'Event', producing an output occurrence each

1475-- time. Discard the underlying 'Accumulator'.

856-- time. Discard the underlying 'Accumulator'.

1476−{-# INLINE mapAccum_ #-}

1477mapAccum_ :: forall t m a b c. (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (Event t c)

857mapAccum_ :: forall t m a b c. (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (Event t c)

1478mapAccum_ f z e = do

858mapAccum_ f z e = do

1479− (_, result) <- mapAccumB f z e

859+ (_ :: Behavior t a, result) <- mapAccum f z e

1480 return result

860 return result

1481

861

1482-- | Accumulate occurrences of an 'Event', possibly producing an output

862-- | Accumulate occurrences of an 'Event', possibly producing an output

1483-- occurrence each time. Discard the underlying 'Accumulator'.

863-- occurrence each time. Discard the underlying 'Accumulator'.

1484−{-# INLINE mapAccumMaybe_ #-}

1485mapAccumMaybe_ :: forall t m a b c. (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (Event t c)

864mapAccumMaybe_ :: forall t m a b c. (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (Event t c)

1486mapAccumMaybe_ f z e = do

865mapAccumMaybe_ f z e = do

1487− (_, result) <- mapAccumMaybeB f z e

866+ (_ :: Behavior t a, result) <- mapAccumMaybe f z e

1488 return result

867 return result

1489

868

1490-- | Accumulate occurrences of an 'Event', using a 'PushM' action and producing

869-- | Accumulate occurrences of an 'Event', using a 'PushM' action and producing

1491-- an output occurrence each time. Discard the underlying 'Accumulator'.

870-- an output occurrence each time. Discard the underlying 'Accumulator'.

1492−{-# INLINE mapAccumM_ #-}

1493mapAccumM_ :: forall t m a b c. (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (Event t c)

871mapAccumM_ :: forall t m a b c. (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (Event t c)

1494mapAccumM_ f z e = do

872mapAccumM_ f z e = do

1495− (_, result) <- mapAccumMB f z e

873+ (_ :: Behavior t a, result) <- mapAccumM f z e

1496 return result

874 return result

1497

875

1498-- | Accumulate occurrences of an 'Event', using a 'PushM' action and possibly

876-- | Accumulate occurrences of an 'Event', using a 'PushM' action and possibly

1499-- producing an output occurrence each time. Discard the underlying

877-- producing an output occurrence each time. Discard the underlying

1500-- 'Accumulator'.

878-- 'Accumulator'.

1501−{-# INLINE mapAccumMaybeM_ #-}

1502mapAccumMaybeM_ :: forall t m a b c. (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (Event t c)

879mapAccumMaybeM_ :: forall t m a b c. (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (Event t c)

1503mapAccumMaybeM_ f z e = do

880mapAccumMaybeM_ f z e = do

1504− (_, result) <- mapAccumMaybeMB f z e

881+ (_ :: Behavior t a, result) <- mapAccumMaybeM f z e

1505 return result

882 return result

1506

883

1507instance Reflex t => Accumulator t (Dynamic t) where

884instance Reflex t => Accumulator t (Dynamic t) where

1508− accumMaybeM = accumMaybeMDyn

885+ accumMaybeM f z e = do

886+ rec let e' = flip push e $ \o -> do

887+ v <- sample $ current d'

888+ f v o

889+ d' <- holdDyn z e'

890+ return d'

1509− mapAccumMaybeM = mapAccumMaybeMDyn

891+ mapAccumMaybeM f z e = do

892+ rec let e' = flip push e $ \o -> do

893+ v <- sample $ current d'

894+ result <- f v o

895+ return $ case result of

896+ (Nothing, Nothing) -> Nothing

897+ _ -> Just result

898+ d' <- holdDyn z $ fmapMaybe fst e'

899+ return (d', fmapMaybe snd e')

1510

900

1511instance Reflex t => Accumulator t (Behavior t) where

901instance Reflex t => Accumulator t (Behavior t) where

1512− accumMaybeM = accumMaybeMB

902+ accumMaybeM f z e = current <$> accumMaybeM f z e

1513− mapAccumMaybeM = mapAccumMaybeMB

903+ mapAccumMaybeM f z e = first current <$> mapAccumMaybeM f z e

1514

904

1515instance Reflex t => Accumulator t (Event t) where

905instance Reflex t => Accumulator t (Event t) where

1516 accumMaybeM f z e = updated <$> accumMaybeM f z e

906 accumMaybeM f z e = updated <$> accumMaybeM f z e

1517 mapAccumMaybeM f z e = first updated <$> mapAccumMaybeM f z e

907 mapAccumMaybeM f z e = first updated <$> mapAccumMaybeM f z e

1518

908

1519−-- | Create a new 'Event' by combining each occurrence with the next value of the

909+-- | Create a new 'Event' by combining each occurence with the next value of the

1520-- list using the supplied function. If the list runs out of items, all

910-- list using the supplied function. If the list runs out of items, all

1521-- subsequent 'Event' occurrences will be ignored.

911-- subsequent 'Event' occurrences will be ignored.

1522zipListWithEvent :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> c) -> [a] -> Event t b -> m (Event t c)

912zipListWithEvent :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> c) -> [a] -> Event t b -> m (Event t c)

@@ -1526,174 +916,101 @@ zipListWithEvent f l e = do

1526 _ -> (Nothing, Nothing) --TODO: Unsubscribe the event?

916 _ -> (Nothing, Nothing) --TODO: Unsubscribe the event?

1527 mapAccumMaybe_ f' l e

917 mapAccumMaybe_ f' l e

1528

918

1529−-- | Assign a number to each occurrence of the given 'Event', starting from 0

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

1530−{-# INLINE numberOccurrences #-}

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

1531−numberOccurrences :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Event t (b, a))

921+-- is as though it had originally been run with the new value. Note that there

1532−numberOccurrences = numberOccurrencesFrom 0

922+-- is some issue here with persistent side-effects: obviously, IO (and some

1533−

923+-- other side-effects) cannot be undone, so it is up to the instance implementer

1534−-- | Assign a number to each occurrence of the given 'Event'

924+-- to determine what the best meaning for this class is in such cases.

1535−{-# INLINE numberOccurrencesFrom #-}

925+class (Reflex t, Monad m) => MonadAdjust t m | m -> t where

1536−numberOccurrencesFrom :: (Reflex t, MonadHold t m, MonadFix m, Num b) => b -> Event t a -> m (Event t (b, a))

926+ runWithReplace :: m a -> Event t (m b) -> m (a, Event t b)

1537−numberOccurrencesFrom = mapAccum_ (\n a -> let !next = n + 1 in (next, (n, a)))

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

1538−

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

1539−-- | Assign a number to each occurrence of the given 'Event'; discard the occurrences' values

929+

1540−{-# INLINE numberOccurrencesFrom_ #-}

930+instance (Reflex t, MonadAdjust t m) => MonadAdjust t (ReaderT r m) where

1541−numberOccurrencesFrom_ :: (Reflex t, MonadHold t m, MonadFix m, Num b) => b -> Event t a -> m (Event t b)

931+ runWithReplace a0 a' = do

1542−numberOccurrencesFrom_ = mapAccum_ (\n _ -> let !next = n + 1 in (next, n))

932+ r <- ask

1543−

933+ lift $ runWithReplace (runReaderT a0 r) $ fmap (`runReaderT` r) a'

1544−-- | This is used to sample the value of a 'Behavior' using an 'Event'.

934+ traverseDMapWithKeyWithAdjust f dm0 dm' = do

1545−--

935+ r <- ask

1546−-- The '<@>' operator is intended to be used in conjunction with

936+ lift $ traverseDMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'

1547−-- the 'Applicative' instance for 'Behavior'.

937+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do

1548−--

938+ r <- ask

1549−-- This is useful when we want to combine the values of one 'Event' and

939+ lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runReaderT (f k v) r) dm0 dm'

1550−-- the value of several 'Behavior's at the time the 'Event' is firing.

940+

1551−--

941+sequenceDMapWithAdjust :: (GCompare k, MonadAdjust t m) => DMap k m -> Event t (PatchDMap k m) -> m (DMap k Identity, Event t (PatchDMap k Identity))

1552−-- If we have:

942+sequenceDMapWithAdjust = traverseDMapWithKeyWithAdjust $ \_ -> fmap Identity

1553−--

943+

1554−-- > f :: a -> b -> c -> d

944+sequenceDMapWithAdjustWithMove :: (GCompare k, MonadAdjust t m) => DMap k m -> Event t (PatchDMapWithMove k m) -> m (DMap k Identity, Event t (PatchDMapWithMove k Identity))

1555−-- > b1 :: Behavior t a

945+sequenceDMapWithAdjustWithMove = traverseDMapWithKeyWithAdjustWithMove $ \_ -> fmap Identity

1556−-- > b2 :: Behavior t b

946+

1557−-- > e :: Event t c

947+mapMapWithAdjustWithMove :: forall t m k v v'. (MonadAdjust t m, Ord k) => (k -> v -> m v') -> Map k v -> Event t (PatchMapWithMove k v) -> m (Map k v', Event t (PatchMapWithMove k v'))

1558−--

948+mapMapWithAdjustWithMove f m0 m' = do

1559−-- then we can do:

949+ (out0 :: DMap (Const2 k v) (Constant v'), out') <- traverseDMapWithKeyWithAdjustWithMove (\(Const2 k) (Identity v) -> Constant <$> f k v) (mapToDMap m0) (const2PatchDMapWithMoveWith Identity <$> m')

1560−--

950+ return (dmapToMapWith (\(Constant v') -> v') out0, patchDMapWithMoveToPatchMapWithMoveWith (\(Constant v') -> v') <$> out')

1561−-- > f <$> b1 <*> b2 <@> e :: Event t d

1562−--

1563−-- in order to apply the function 'f' to the relevant values.

1564−--

1565−-- The alternative would be something like:

1566−--

1567−-- > attachWith (\(x1, x2) y -> f x1 x2 y) ((,) <$> b1 <*> b2) e :: Event t d

1568−--

1569−-- or a variation involing a custom data type to hold the combination of

1570−-- 'Behavior's even when that combination might only ever be used by 'f'.

1571−--

1572−-- A more suggestive example might be:

1573−--

1574−-- > handleMouse <$> bPlayerState <*> bMousePosition <@> eMouseClick :: Event t (GameState -> GameState)

1575−--

1576−(<@>) :: Reflex t => Behavior t (a -> b) -> Event t a -> Event t b

1577−(<@>) b = push $ \x -> do

1578− f <- sample b

1579− return . Just . f $ x

1580−infixl 4 <@>

1581−

1582−-- | An version of '<@>' that does not use the value of the 'Event'.

1583−--

1584−-- Alternatively, it is 'tag' in operator form.

1585−--

1586−-- This is useful when we want to combine the values of several

1587−-- 'Behavior's at particular points in time using an 'Applicative'

1588−-- style syntax.

1589−--

1590−-- If we have:

1591−--

1592−-- > g :: a -> b -> d

1593−-- > b1 :: Behavior t a

1594−-- > b2 :: Behavior t b

1595−-- > e :: Event t c

1596−--

1597−-- where 'e' is firing at the points in time of interest.

1598−--

1599−-- Then we can use '<@':

1600−--

1601−-- > g <$> b1 <*> b2 <@ e :: Event t d

1602−--

1603−-- to combine the values of 'b1' and 'b2' at each of those points of time,

1604−-- with the function 'g' being used to combine the values.

1605−--

1606−-- This is the same as '<@>' except that the 'Event' is being used only

1607−-- to act as a trigger.

1608−(<@) :: (Reflex t) => Behavior t b -> Event t a -> Event t b

1609−(<@) = tag

1610−infixl 4 <@

1611

951

1612------------------

952------------------

1613-- Cheap Functions

953-- Cheap Functions

1614------------------

954------------------

1615

955

1616−-- | A "cheap" version of 'pushAlways'. See the performance note on 'pushCheap'.

1617{-# INLINE pushAlwaysCheap #-}

956{-# INLINE pushAlwaysCheap #-}

1618pushAlwaysCheap :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b

957pushAlwaysCheap :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b

1619pushAlwaysCheap f = pushCheap (fmap Just . f)

958pushAlwaysCheap f = pushCheap (fmap Just . f)

1620

959

1621−-- | A "cheap" version of 'mapMaybe'. See the performance note on 'pushCheap'.

1622−{-# INLINE mapMaybeCheap #-}

1623−mapMaybeCheap :: Reflex t => (a -> Maybe b) -> Event t a -> Event t b

1624−mapMaybeCheap f = pushCheap $ return . f

1625−

1626−-- | An alias for 'mapMaybeCheap'

1627{-# INLINE fmapMaybeCheap #-}

960{-# INLINE fmapMaybeCheap #-}

1628fmapMaybeCheap :: Reflex t => (a -> Maybe b) -> Event t a -> Event t b

961fmapMaybeCheap :: Reflex t => (a -> Maybe b) -> Event t a -> Event t b

1629−fmapMaybeCheap = mapMaybeCheap

962+fmapMaybeCheap f = pushCheap $ return . f

1630

963

1631−

1632−-- | A "cheap" version of 'fforMaybe'. See the performance note on 'pushCheap'.

1633{-# INLINE fforMaybeCheap #-}

964{-# INLINE fforMaybeCheap #-}

1634fforMaybeCheap :: Reflex t => Event t a -> (a -> Maybe b) -> Event t b

965fforMaybeCheap :: Reflex t => Event t a -> (a -> Maybe b) -> Event t b

1635−fforMaybeCheap = flip mapMaybeCheap

966+fforMaybeCheap = flip fmapMaybeCheap

1636

967

1637−-- | A "cheap" version of 'ffor'. See the performance note on 'pushCheap'.

1638{-# INLINE fforCheap #-}

968{-# INLINE fforCheap #-}

1639fforCheap :: Reflex t => Event t a -> (a -> b) -> Event t b

969fforCheap :: Reflex t => Event t a -> (a -> b) -> Event t b

1640fforCheap = flip fmapCheap

970fforCheap = flip fmapCheap

1641

971

1642−-- | A "cheap" version of 'fmap'. See the performance note on 'pushCheap'.

1643{-# INLINE fmapCheap #-}

972{-# INLINE fmapCheap #-}

1644fmapCheap :: Reflex t => (a -> b) -> Event t a -> Event t b

973fmapCheap :: Reflex t => (a -> b) -> Event t a -> Event t b

1645fmapCheap f = pushCheap $ return . Just . f

974fmapCheap f = pushCheap $ return . Just . f

1646

975

1647−-- | A "cheap" version of 'tag'. See the performance note on 'pushCheap'.

1648{-# INLINE tagCheap #-}

976{-# INLINE tagCheap #-}

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

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

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

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

1651

979

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

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

1654−-- that are occurring simultaneously

1655−merge :: (Reflex t, GCompare k) => DMap k (Event t) -> Event t (DMap k Identity)

1656−merge = mergeG coerceEvent

1657−{-# INLINE merge #-}

1658−

1659−-- | Create a merge whose parents can change over time

1660−mergeIncremental :: (Reflex t, GCompare k)

1661− => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)

1662−mergeIncremental = mergeIncrementalG coerceEvent

1663−

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

1665−mergeIncrementalWithMove :: (Reflex t, GCompare k)

1666− => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)

1667−mergeIncrementalWithMove = mergeIncrementalWithMoveG coerceEvent

1668−

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

1670{-# INLINE mergeWithCheap #-}

980{-# INLINE mergeWithCheap #-}

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

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

1672mergeWithCheap = mergeWithCheap' id

982mergeWithCheap = mergeWithCheap' id

1673

983

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

1675{-# INLINE mergeWithCheap' #-}

984{-# INLINE mergeWithCheap' #-}

1676mergeWithCheap' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b

985mergeWithCheap' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b

1677−mergeWithCheap' f g = mergeWithFoldCheap' $ foldl1 g . fmap f

986+mergeWithCheap' f g es = fmapCheap (Prelude.foldl1 g . map (\(Const2 _ :=> Identity v) -> f v) . DMap.toList)

1678−

987+ . merge

1679−-- | A "cheap" version of 'mergeWithFoldCheap''. See the performance note on 'pushCheap'.

1680−{-# INLINE mergeWithFoldCheap' #-}

1681−mergeWithFoldCheap' :: Reflex t => (NonEmpty a -> b) -> [Event t a] -> Event t b

1682−mergeWithFoldCheap' f es =

1683− fmapCheap (f . (\(h : t) -> h :| t) . IntMap.elems)

1684− . mergeInt

1685− . IntMap.fromDistinctAscList

988+ . DMap.fromDistinctAscList

989+ . map (\(k, v) -> Const2 k :=> v)

1686− $ zip [0 :: Int ..] es

990+ $ zip [0 :: Int ..] es

1687

991

1688--------------------------------------------------------------------------------

992--------------------------------------------------------------------------------

1689-- Deprecated functions

993-- Deprecated functions

1690--------------------------------------------------------------------------------

994--------------------------------------------------------------------------------

1691

995

1692−{-# DEPRECATED switchPromptly "Use 'switchHoldPromptly' instead. The 'switchHold*' naming convention was chosen because those functions are more closely related to each other than they are to 'switch'. " #-}

996+-- | Create a new 'Event' that occurs if at least one of the supplied 'Event's

1693−-- | See 'switchHoldPromptly'

997+-- occurs. If both occur at the same time they are combined using 'mappend'.

998+{-# DEPRECATED appendEvents "If a 'Semigroup a' instance is available, use 'mappend'; otherwise, use 'alignWith (mergeThese mappend)' instead" #-}

1694−switchPromptly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)

999+appendEvents :: (Reflex t, Monoid a) => Event t a -> Event t a -> Event t a

1695−switchPromptly = switchHoldPromptly

1000+appendEvents = alignWith $ mergeThese mappend

1696−{-# DEPRECATED switchPromptOnly "Use 'switchHoldPromptOnly' instead. The 'switchHold*' naming convention was chosen because those functions are more closely related to each other than they are to 'switch'. " #-}

1001+

1697−-- | See 'switchHoldPromptOnly'

1002+-- | Alias for 'headE'

1698−switchPromptOnly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)

1003+{-# DEPRECATED onceE "Use 'headE' instead" #-}

1699−switchPromptOnly = switchHoldPromptOnly

1004+onceE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)

1005+onceE = headE

1006+

1007+-- | Run both sides of a 'These' monadically, combining the results.

1008+{-# DEPRECATED sequenceThese "Use bisequenceA or bisequence from the bifunctors package instead" #-}

1009+#ifdef USE_TEMPLATE_HASKELL

1010+{-# ANN sequenceThese "HLint: ignore Use fmap" #-}

1011+#endif

1012+sequenceThese :: Monad m => These (m a) (m b) -> m (These a b)

1013+sequenceThese t = case t of

1014+ This ma -> fmap This ma

1015+ These ma mb -> liftM2 These ma mb

1016+ That mb -> fmap That mb

src/Reflex/Collection.hsdeleted−225

@@ -1,225 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE FlexibleInstances #-}

3−{-# LANGUAGE LambdaCase #-}

4−{-# LANGUAGE MultiParamTypeClasses #-}

5−{-# LANGUAGE RankNTypes #-}

6−{-# LANGUAGE RecursiveDo #-}

7−{-# LANGUAGE ScopedTypeVariables #-}

8−{-# LANGUAGE TypeFamilies #-}

9−{-# LANGUAGE UndecidableInstances #-}

10−#ifdef USE_REFLEX_OPTIMIZER

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

12−#endif

13−-- |

14−-- Module:

15−-- Reflex.Collection

16−module Reflex.Collection

17− (

18− -- * Widgets on Collections

19− listHoldWithKey

20− , listWithKey

21− , listWithKeyShallowDiff

22− , listViewWithKey

23− , selectViewListWithKey

24− , selectViewListWithKey_

25− -- * List Utils

26− , list

27− , simpleList

28− ) where

29−

30−#ifdef MIN_VERSION_semialign

31−import Prelude hiding (zip, zipWith)

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

33−import Data.Zip (Zip (..))

34−#endif

35−#endif

36−

37−import Control.Monad.Identity

38−import Data.Align

39−import Data.Functor.Misc

40−import Data.Map (Map)

41−import qualified Data.Map as Map

42−import Data.Map.Misc

43−import Data.These

44−

45−import Reflex.Class

46−import Reflex.Adjustable.Class

47−import Reflex.Dynamic

48−import Reflex.PostBuild.Class

49−

50−-- | Create a set of widgets based on the provided 'Map'. When the

51−-- input 'Event' fires, remove widgets for keys with the value 'Nothing'

52−-- and add/replace widgets for keys with 'Just' values.

53−listHoldWithKey

54− :: forall t m k v a

55− . (Ord k, Adjustable t m, MonadHold t m)

56− => Map k v

57− -> Event t (Map k (Maybe v))

58− -> (k -> v -> m a)

59− -> m (Dynamic t (Map k a))

60−listHoldWithKey m0 m' f = do

61− let dm0 = mapWithFunctorToDMap $ Map.mapWithKey f m0

62− dm' = fmap

63− (PatchDMap . mapWithFunctorToDMap . Map.mapWithKey

64− (\k v -> ComposeMaybe $ fmap (f k) v)

65− )

66− m'

67− (a0, a') <- sequenceDMapWithAdjust dm0 dm'

68−

69− --TODO: Move the dmapToMap to the righthand side so it doesn't get

70− --fully redone every time

71− fmap dmapToMap . incrementalToDynamic <$> holdIncremental a0 a'

72−

73−--TODO: Something better than Dynamic t (Map k v) - we want something

74−--where the Events carry diffs, not the whole value

75−listWithKey

76− :: forall t k v m a

77− . (Ord k, Adjustable t m, PostBuild t m, MonadFix m, MonadHold t m)

78− => Dynamic t (Map k v)

79− -> (k -> Dynamic t v -> m a)

80− -> m (Dynamic t (Map k a))

81−listWithKey vals mkChild = do

82− postBuild <- getPostBuild

83− let childValChangedSelector = fanMap $ updated vals

84−

85− -- We keep track of changes to children values in the mkChild

86− -- function we pass to listHoldWithKey The other changes we need

87− -- to keep track of are child insertions and

88− -- deletions. diffOnlyKeyChanges keeps track of insertions and

89− -- deletions but ignores value changes, since they're already

90− -- accounted for.

91− diffOnlyKeyChanges olds news =

92− flip Map.mapMaybe (align olds news) $ \case

93− This _ -> Just Nothing

94− These _ _ -> Nothing

95− That new -> Just $ Just new

96− rec sentVals :: Dynamic t (Map k v) <- foldDyn applyMap Map.empty changeVals

97− let changeVals :: Event t (Map k (Maybe v))

98− changeVals =

99− attachWith diffOnlyKeyChanges (current sentVals) $ leftmost

100− [ updated vals

101−

102− -- TODO: This should probably be added to the

103− -- attachWith, not to the updated; if we were using

104− -- diffMap instead of diffMapNoEq, I think it might not

105− -- work

106− , tag (current vals) postBuild

107− ]

108− listHoldWithKey Map.empty changeVals $ \k v ->

109− mkChild k =<< holdDyn v (select childValChangedSelector $ Const2 k)

110−

111−-- | Display the given map of items (in key order) using the builder

112−-- function provided, and update it with the given event. 'Nothing'

113−-- update entries will delete the corresponding children, and 'Just'

114−-- entries will create them if they do not exist or send an update

115−-- event to them if they do.

116−listWithKeyShallowDiff

117− :: (Ord k, Adjustable t m, MonadFix m, MonadHold t m)

118− => Map k v

119− -> Event t (Map k (Maybe v))

120− -> (k -> v -> Event t v -> m a)

121− -> m (Dynamic t (Map k a))

122−listWithKeyShallowDiff initialVals valsChanged mkChild = do

123− let childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged

124− sentVals <- foldDyn applyMap (void initialVals) $ fmap (fmap void) valsChanged

125− let relevantPatch patch _ = case patch of

126−

127− -- Even if we let a Nothing through when the element doesn't

128− -- already exist, this doesn't cause a problem because it is

129− -- ignored

130− Nothing -> Just Nothing

131−

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

133− Just _ -> Nothing

134− listHoldWithKey

135− initialVals

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

137− (current sentVals)

138− valsChanged

139− )

140− $ \k v -> mkChild k v $ select childValChangedSelector $ Const2 k

141−

142−--TODO: Something better than Dynamic t (Map k v) - we want something

143−--where the Events carry diffs, not the whole value

144−-- | Create a dynamically-changing set of Event-valued widgets. This

145−-- is like 'listWithKey', specialized for widgets returning @/Event t a/@.

146−-- 'listWithKey' would return @/Dynamic t (Map k (Event t a))/@ in

147−-- this scenario, but 'listViewWithKey' flattens this to

148−-- @/Event t (Map k a)/@ via 'switch'.

149−listViewWithKey

150− :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m)

151− => Dynamic t (Map k v)

152− -> (k -> Dynamic t v -> m (Event t a))

153− -> m (Event t (Map k a))

154−listViewWithKey vals mkChild =

155− switch . fmap mergeMap <$> listViewWithKey' vals mkChild

156−

157−listViewWithKey'

158− :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m)

159− => Dynamic t (Map k v)

160− -> (k -> Dynamic t v -> m a)

161− -> m (Behavior t (Map k a))

162−listViewWithKey' vals mkChild = current <$> listWithKey vals mkChild

163−

164−-- | Create a dynamically-changing set of widgets, one of which is

165−-- selected at any time.

166−selectViewListWithKey

167− :: forall t m k v a

168− . (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)

169− => Dynamic t k

170− -- ^ Current selection key

171− -> Dynamic t (Map k v)

172− -- ^ Dynamic key/value map

173− -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a))

174− -- ^ Function to create a widget for a given key from Dynamic value

175− -- and Dynamic Bool indicating if this widget is currently selected

176− -> m (Event t (k, a))

177− -- ^ Event that fires when any child's return Event fires. Contains

178− -- key of an arbitrary firing widget.

179−selectViewListWithKey selection vals mkChild = do

180− -- For good performance, this value must be shared across all children

181− let selectionDemux = demux selection

182− selectChild <- listWithKey vals $ \k v -> do

183− let selected = demuxed selectionDemux k

184− selectSelf <- mkChild k v selected

185− return $ fmap ((,) k) selectSelf

186− return $ switchPromptlyDyn $ leftmost . Map.elems <$> selectChild

187−

188−-- | Like 'selectViewListWithKey' but discards the value of the list

189−-- item widget's output 'Event'.

190−selectViewListWithKey_

191− :: forall t m k v a

192− . (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)

193− => Dynamic t k

194− -- ^ Current selection key

195− -> Dynamic t (Map k v)

196− -- ^ Dynamic key/value map

197− -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a))

198− -- ^ Function to create a widget for a given key from Dynamic value

199− -- and Dynamic Bool indicating if this widget is currently selected

200− -> m (Event t k)

201− -- ^ Event that fires when any child's return Event fires. Contains

202− -- key of an arbitrary firing widget.

203−selectViewListWithKey_ selection vals mkChild =

204− fmap fst <$> selectViewListWithKey selection vals mkChild

205−

206−-- | Create a dynamically-changing set of widgets from a Dynamic

207−-- key/value map. Unlike the 'withKey' variants, the child widgets

208−-- are insensitive to which key they're associated with.

209−list

210− :: (Ord k, Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m)

211− => Dynamic t (Map k v)

212− -> (Dynamic t v -> m a)

213− -> m (Dynamic t (Map k a))

214−list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)

215−

216−-- | Create a dynamically-changing set of widgets from a Dynamic list.

217−simpleList

218− :: (Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m)

219− => Dynamic t [v]

220− -> (Dynamic t v -> m a)

221− -> m (Dynamic t [a])

222−simpleList xs mkChild =

223− fmap (fmap (map snd . Map.toList)) $ flip list mkChild $ fmap

224− (Map.fromList . zip [(1 :: Int) ..])

225− xs

src/Reflex/Dynamic.hs+201−160

@@ -8,63 +8,45 @@

8{-# LANGUAGE NoMonomorphismRestriction #-}

9{-# LANGUAGE PolyKinds #-}

10{-# LANGUAGE RankNTypes #-}

11−{-# LANGUAGE RecursiveDo #-}

12{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE ScopedTypeVariables #-}

13−{-# LANGUAGE StandaloneDeriving #-}

14{-# LANGUAGE TypeFamilies #-}

12{-# LANGUAGE TypeFamilies #-}

15{-# LANGUAGE TypeOperators #-}

13{-# LANGUAGE TypeOperators #-}

16{-# LANGUAGE UndecidableInstances #-}

14{-# LANGUAGE UndecidableInstances #-}

17#ifdef USE_REFLEX_OPTIMIZER

15#ifdef USE_REFLEX_OPTIMIZER

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

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

19#endif

17#endif

20−-- |

21−-- Module:

22−-- Reflex.Dynamic

23−-- Description:

24−-- This module contains various functions for working with 'Dynamic' values.

18+-- | This module contains various functions for working with 'Dynamic' values.

25−-- 'Dynamic' and its primitives have been moved to the 'Reflex' class.

19+-- 'Dynamic' and its primitives have been moved to the 'Reflex' class.

26module Reflex.Dynamic

20module Reflex.Dynamic

27 ( -- * Basics

21 ( -- * Basics

28 Dynamic -- Abstract so we can preserve the law that the current value is always equal to the most recent update

22 Dynamic -- Abstract so we can preserve the law that the current value is always equal to the most recent update

29 , current

23 , current

30 , updated

24 , updated

31 , holdDyn

25 , holdDyn

32− , mapDynM

33− , forDynM

34 , constDyn

26 , constDyn

27+ , uniqDyn

28+ , uniqDynBy

35 , count

29 , count

36 , toggle

30 , toggle

37− , switchDyn

38 , switchPromptlyDyn

31 , switchPromptlyDyn

39 , tagPromptlyDyn

32 , tagPromptlyDyn

40 , attachPromptlyDyn

33 , attachPromptlyDyn

41 , attachPromptlyDynWith

34 , attachPromptlyDynWith

42 , attachPromptlyDynWithMaybe

35 , attachPromptlyDynWithMaybe

43− , maybeDyn

44− , eitherDyn

45− , factorDyn

46− , scanDyn

47− , scanDynMaybe

48− , holdUniqDyn

49− , holdUniqDynBy

50− , improvingMaybe

51 , foldDyn

36 , foldDyn

52 , foldDynM

37 , foldDynM

53 , foldDynMaybe

38 , foldDynMaybe

54 , foldDynMaybeM

39 , foldDynMaybeM

55 , joinDynThroughMap

40 , joinDynThroughMap

56− , joinDynThroughIntMap

57 , traceDyn

41 , traceDyn

58 , traceDynWith

42 , traceDynWith

59 , splitDynPure

43 , splitDynPure

60 , distributeMapOverDynPure

44 , distributeMapOverDynPure

61− , distributeIntMapOverDynPure

62 , distributeDMapOverDynPure

45 , distributeDMapOverDynPure

63 , distributeListOverDynPure

46 , distributeListOverDynPure

64 , Demux

47 , Demux

65 , demux

48 , demux

66 , demuxed

49 , demuxed

67− -- * Miscellaneous

68 -- Things that probably aren't very useful:

50 -- Things that probably aren't very useful:

69 , HList (..)

51 , HList (..)

70 , FHList (..)

52 , FHList (..)

@@ -74,80 +56,72 @@ module Reflex.Dynamic

74 , AllAreFunctors (..)

56 , AllAreFunctors (..)

75 , HListPtr (..)

57 , HListPtr (..)

76 , distributeFHListOverDynPure

58 , distributeFHListOverDynPure

77− -- * Unsafe

59+ -- Unsafe

78 , unsafeDynamic

60 , unsafeDynamic

61+ -- * Deprecated functions

62+ , apDyn

63+ , attachDyn

64+ , attachDynWith

65+ , attachDynWithMaybe

66+ , collectDyn

67+ , combineDyn

68+ , distributeDMapOverDyn

69+ , distributeFHListOverDyn

70+ , forDyn

71+ , forDynM

72+ , getDemuxed

73+ , joinDyn

74+ , mapDyn

75+ , mapDynM

76+ , mconcatDyn

77+ , nubDyn

78+ , splitDyn

79+ , tagDyn

79 ) where

80 ) where

81−import Data.Functor.Compose

82+import Prelude hiding (mapM, mapM_)

83+

82import Data.Functor.Misc

84import Data.Functor.Misc

83import Reflex.Class

85import Reflex.Class

85−import Control.Monad

87+import Control.Applicative ((<*>))

88+import Control.Monad hiding (forM, forM_, mapM, mapM_)

86import Control.Monad.Fix

89import Control.Monad.Fix

87−import Control.Monad.Identity

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

88import Data.Align

91import Data.Align

89import Data.Dependent.Map (DMap)

92import Data.Dependent.Map (DMap)

90import qualified Data.Dependent.Map as DMap

93import qualified Data.Dependent.Map as DMap

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

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

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

95+import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), GOrdering (..))

93−import Data.IntMap (IntMap)

94−import qualified Data.IntMap as IntMap

95import Data.Map (Map)

96import Data.Map (Map)

96−import Data.Maybe

97+import Data.Monoid

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

98import Data.These

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

100

101import Debug.Trace

100import Debug.Trace

102

101

103−-- | Map a sampling function over a 'Dynamic'.

104−mapDynM :: forall t m a b. (Reflex t, MonadHold t m) => (forall m'. MonadSample t m' => a -> m' b) -> Dynamic t a -> m (Dynamic t b)

105−mapDynM f d = buildDynamic (f =<< sample (current d)) $ pushAlways f (updated d)

106−

107−-- | Flipped version of 'mapDynM'

108−forDynM :: forall t m a b. (Reflex t, MonadHold t m) => Dynamic t a -> (forall m'. MonadSample t m' => a -> m' b) -> m (Dynamic t b)

109−forDynM d f = mapDynM f d

110−

111-- | Create a new 'Dynamic' that only signals changes if the values actually

102-- | Create a new 'Dynamic' that only signals changes if the values actually

112-- changed.

103-- changed.

113−holdUniqDyn :: (Reflex t, MonadHold t m, MonadFix m, Eq a) => Dynamic t a -> m (Dynamic t a)

104+uniqDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a

114−holdUniqDyn = holdUniqDynBy (==)

105+uniqDyn = uniqDynBy (==)

115

106

116-- | Create a new 'Dynamic' that changes only when the underlying 'Dynamic'

107-- | Create a new 'Dynamic' that changes only when the underlying 'Dynamic'

117-- changes and the given function returns 'False' when given both the old and

108-- changes and the given function returns 'False' when given both the old and

118-- the new values.

109-- the new values.

119−holdUniqDynBy :: (Reflex t, MonadHold t m, MonadFix m) => (a -> a -> Bool) -> Dynamic t a -> m (Dynamic t a)

110+uniqDynBy :: Reflex t => (a -> a -> Bool) -> Dynamic t a -> Dynamic t a

120−holdUniqDynBy eq = scanDynMaybe id (\new old -> if new `eq` old then Nothing else Just new)

111+uniqDynBy eq d =

121−

112+ let e' = attachWithMaybe (\x x' -> if x' `eq` x then Nothing else Just x') (current d) (updated d)

122−-- | @/Dynamic Maybe/@ that can only update from @/Nothing/@ to @/Just/@ or @/Just/@ to @/Just/@ (i.e., cannot revert to @/Nothing/@)

123−improvingMaybe :: (Reflex t, MonadHold t m, MonadFix m) => Dynamic t (Maybe a) -> m (Dynamic t (Maybe a))

124−improvingMaybe = scanDynMaybe id (\new _ -> if isJust new then Just new else Nothing)

125−

126−-- | Create a 'Dynamic' that accumulates values from another 'Dynamic'. This

127−-- function does not force its input 'Dynamic' until the output 'Dynamic' is

128−-- forced.

129−scanDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b) -> (a -> b -> b) -> Dynamic t a -> m (Dynamic t b)

130−scanDyn z f = scanDynMaybe z (\a b -> Just $ f a b)

131−

132−-- | Like 'scanDyn', but the the accumulator function may decline to update the

133−-- result 'Dynamic''s value.

134−scanDynMaybe :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b) -> (a -> b -> Maybe b) -> Dynamic t a -> m (Dynamic t b)

135−scanDynMaybe z f d = do

136− rec d' <- buildDynamic (z <$> sample (current d)) $ flip push (updated d) $ \a -> do

137− b <- sample $ current d'

113+ in unsafeDynamic (current d) e'

138− return $ f a b

139− return d'

140

114

141-- | Create a 'Dynamic' using the initial value and change it each time the

115-- | Create a 'Dynamic' using the initial value and change it each time the

142-- 'Event' occurs using a folding function on the previous value and the value

116-- 'Event' occurs using a folding function on the previous value and the value

143-- of the 'Event'.

117-- of the 'Event'.

144foldDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> b) -> b -> Event t a -> m (Dynamic t b)

118foldDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> b) -> b -> Event t a -> m (Dynamic t b)

145−foldDyn = accumDyn . flip

119+foldDyn = accum . flip

146

120

147-- | Like 'foldDyn', but the combining function is a 'PushM' action, so it

121-- | Like 'foldDyn', but the combining function is a 'PushM' action, so it

148-- can 'sample' existing 'Behaviors' and 'hold' new ones.

122-- can 'sample' existing 'Behaviors' and 'hold' new ones.

149foldDynM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t b) -> b -> Event t a -> m (Dynamic t b)

123foldDynM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t b) -> b -> Event t a -> m (Dynamic t b)

150−foldDynM = accumMDyn . flip

124+foldDynM = accumM . flip

151

125

152-- | Create a 'Dynamic' using the provided initial value and change it each time

126-- | Create a 'Dynamic' using the provided initial value and change it each time

153-- the provided 'Event' occurs, using a function to combine the old value with

127-- the provided 'Event' occurs, using a function to combine the old value with

@@ -156,14 +130,14 @@ foldDynM = accumMDyn . flip

156-- 'Dynamic''s 'updated' 'Event' will fire in the 'Just' case, and will not fire

130-- 'Dynamic''s 'updated' 'Event' will fire in the 'Just' case, and will not fire

157-- in the 'Nothing' case.

131-- in the 'Nothing' case.

158foldDynMaybe :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe b) -> b -> Event t a -> m (Dynamic t b)

132foldDynMaybe :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe b) -> b -> Event t a -> m (Dynamic t b)

159−foldDynMaybe = accumMaybeDyn . flip

133+foldDynMaybe = accumMaybe . flip

160

134

161-- | Like 'foldDynMaybe', but the combining function is a 'PushM' action, so it

135-- | Like 'foldDynMaybe', but the combining function is a 'PushM' action, so it

162-- can 'sample' existing 'Behaviors' and 'hold' new ones.

136-- can 'sample' existing 'Behaviors' and 'hold' new ones.

163foldDynMaybeM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe b)) -> b -> Event t a -> m (Dynamic t b)

137foldDynMaybeM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe b)) -> b -> Event t a -> m (Dynamic t b)

164−foldDynMaybeM = accumMaybeMDyn . flip

138+foldDynMaybeM = accumMaybeM . flip

165

139

166−-- | Create a new 'Dynamic' that counts the occurrences of the 'Event'.

140+-- | Create a new 'Dynamic' that counts the occurences of the 'Event'.

167count :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Dynamic t b)

141count :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Dynamic t b)

168count e = holdDyn 0 =<< zipListWithEvent const (iterate (+1) 1) e

142count e = holdDyn 0 =<< zipListWithEvent const (iterate (+1) 1) e

169

143

@@ -172,25 +146,10 @@ count e = holdDyn 0 =<< zipListWithEvent const (iterate (+1) 1) e

172toggle :: (Reflex t, MonadHold t m, MonadFix m) => Bool -> Event t a -> m (Dynamic t Bool)

146toggle :: (Reflex t, MonadHold t m, MonadFix m) => Bool -> Event t a -> m (Dynamic t Bool)

173toggle = foldDyn (const not)

147toggle = foldDyn (const not)

174

148

175−-- | Switches to the new 'Event' whenever it receives one. Only the old event is

176−-- considered the moment a new one is switched in; the output event will fire at

177−-- that moment if only if the old event does.

178−--

179−-- Prefer this to 'switchPromptlyDyn' where possible. The lack of doing double

180−-- work when the outer and (new) inner fires means this imposes fewer "timing

181−-- requirements" and thus is far more easy to use without introducing fresh

182−-- failure cases. 'switchDyn' is also more performant.

183−switchDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a

184−switchDyn d = switch (current d)

185−

186-- | Switches to the new 'Event' whenever it receives one. Switching occurs

149-- | Switches to the new 'Event' whenever it receives one. Switching occurs

187−-- __before__ the inner 'Event' fires - so if the 'Dynamic' changes and both the

150+-- *before* the inner 'Event' fires - so if the 'Dynamic' changes and both the

188-- old and new inner Events fire simultaneously, the output will fire with the

151-- old and new inner Events fire simultaneously, the output will fire with the

189−-- value of the __new__ 'Event'.

152+-- value of the *new* 'Event'.

190−--

191−-- Prefer 'switchDyn' to this where possible. The timing requirements that

192−-- switching before imposes are likely to bring down your app unless you are

193−-- very careful. 'switchDyn' is also more performant.

194switchPromptlyDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a

153switchPromptlyDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a

195switchPromptlyDyn de =

154switchPromptlyDyn de =

196 let eLag = switch $ current de

155 let eLag = switch $ current de

@@ -206,31 +165,28 @@ splitDynPure d = (fmap fst d, fmap snd d)

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

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

207distributeMapOverDynPure = fmap dmapToMap . distributeDMapOverDynPure . mapWithFunctorToDMap

166distributeMapOverDynPure = fmap dmapToMap . distributeDMapOverDynPure . mapWithFunctorToDMap

208

167

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

210−-- non-'Dynamic' elements.

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

212−distributeIntMapOverDynPure = fmap dmapToIntMap . distributeDMapOverDynPure . intMapWithFunctorToDMap

213−

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

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

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

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

216−{-# DEPRECATED distributeListOverDynPure "Use 'distributeListOverDyn' instead" #-}

217distributeListOverDynPure :: Reflex t => [Dynamic t v] -> Dynamic t [v]

170distributeListOverDynPure :: Reflex t => [Dynamic t v] -> Dynamic t [v]

218−distributeListOverDynPure = distributeListOverDyn

171+distributeListOverDynPure =

172+ fmap (map fromDSum . DMap.toAscList) .

173+ distributeDMapOverDynPure .

174+ DMap.fromDistinctAscList .

175+ zipWith toDSum [0..]

176+ where

177+ toDSum :: Int -> Dynamic t a -> DSum (Const2 Int a) (Dynamic t)

178+ toDSum k v = Const2 k :=> v

179+ fromDSum :: DSum (Const2 Int a) Identity -> a

180+ fromDSum (Const2 _ :=> Identity v) = v

219

181

220--TODO: Generalize this to functors other than Maps

182--TODO: Generalize this to functors other than Maps

221-- | Combine a 'Dynamic' of a 'Map' of 'Dynamic's into a 'Dynamic'

183-- | Combine a 'Dynamic' of a 'Map' of 'Dynamic's into a 'Dynamic'

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

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

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

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

224−joinDynThroughMap = (distributeMapOverDynPure =<<)

186+joinDynThroughMap = joinDyn . fmap distributeMapOverDynPure

225

187

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

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

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

229−joinDynThroughIntMap = (distributeIntMapOverDynPure =<<)

230−

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

188+-- | Print the value of the 'Dynamic' on each change and prefix it

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

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

189+-- with the provided string. This should /only/ be used for debugging.

234--

190--

235-- Note: Just like Debug.Trace.trace, the value will only be shown if something

191-- Note: Just like Debug.Trace.trace, the value will only be shown if something

236-- else in the system is depending on it.

192-- else in the system is depending on it.

@@ -238,8 +194,7 @@ traceDyn :: (Reflex t, Show a) => String -> Dynamic t a -> Dynamic t a

238traceDyn s = traceDynWith $ \x -> s <> ": " <> show x

194traceDyn s = traceDynWith $ \x -> s <> ": " <> show x

239

195

240-- | Print the result of applying the provided function to the value

196-- | Print the result of applying the provided function to the value

241−-- of the 'Dynamic' when it is first read and on each subsequent change

197+-- of the 'Dynamic' on each change. This should /only/ be used for

242−-- that is observed (as 'traceEvent'). This should /only/ be used for

243-- debugging.

198-- debugging.

244--

199--

245-- Note: Just like Debug.Trace.trace, the value will only be shown if something

200-- Note: Just like Debug.Trace.trace, the value will only be shown if something

@@ -255,35 +210,36 @@ traceDynWith f d =

255-- | Replace the value of the 'Event' with the current value of the 'Dynamic'

210-- | Replace the value of the 'Event' with the current value of the 'Dynamic'

256-- each time the 'Event' occurs.

211-- each time the 'Event' occurs.

257--

212--

258−-- Note: @/tagPromptlyDyn d e/@ differs from @/tag (current d) e/@ in the case that @/e/@ is firing

213+-- Note: `tagPromptlyDyn d e` differs from `tag (current d) e` in the case that `e` is firing

259−-- at the same time that @/d/@ is changing. With @/tagPromptlyDyn d e/@, the __new__ value of @/d/@

214+-- at the same time that `d` is changing. With `tagPromptlyDyn d e`, the *new* value of `d`

260−-- will replace the value of @/e/@, whereas with @/tag (current d) e/@, the __old__ value

215+-- will replace the value of `e`, whereas with `tag (current d) e`, the *old* value

261-- will be used, since the 'Behavior' won't be updated until the end of the frame.

216-- will be used, since the 'Behavior' won't be updated until the end of the frame.

262-- Additionally, this means that the output 'Event' may not be used to directly change

217-- Additionally, this means that the output 'Event' may not be used to directly change

263−-- the input 'Dynamic', because that would mean its value depends on itself. __When creating__

218+-- the input 'Dynamic', because that would mean its value depends on itself. When creating

264−-- __cyclic data flows, generally @/tag (current d) e/@ is preferred.__

219+-- cyclic data flows, generally `tag (current d) e` is preferred.

265tagPromptlyDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a

220tagPromptlyDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a

266tagPromptlyDyn = attachPromptlyDynWith const

221tagPromptlyDyn = attachPromptlyDynWith const

267

222

268-- | Attach the current value of the 'Dynamic' to the value of the

223-- | Attach the current value of the 'Dynamic' to the value of the

269-- 'Event' each time it occurs.

224-- 'Event' each time it occurs.

270--

225--

271−-- Note: @/attachPromptlyDyn d/@ is not the same as @/attach (current d)/@. See 'tagPromptlyDyn' for details.

226+-- Note: `attachPromptlyDyn d` is not the same as `attach (current d)`. See 'tagPromptlyDyn' for details.

272attachPromptlyDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b)

227attachPromptlyDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b)

273attachPromptlyDyn = attachPromptlyDynWith (,)

228attachPromptlyDyn = attachPromptlyDynWith (,)

274

229

275-- | Combine the current value of the 'Dynamic' with the value of the

230-- | Combine the current value of the 'Dynamic' with the value of the

276-- 'Event' each time it occurs.

231-- 'Event' each time it occurs.

277--

232--

278−-- Note: @/attachPromptlyDynWith f d/@ is not the same as @/attachWith f (current d)/@. See 'tagPromptlyDyn' for details.

233+-- Note: `attachPromptlyDynWith f d` is not the same as `attachWith f (current d)`. See 'tagPromptlyDyn' for details.

279attachPromptlyDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c

234attachPromptlyDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c

280attachPromptlyDynWith f = attachPromptlyDynWithMaybe $ \a b -> Just $ f a b

235attachPromptlyDynWith f = attachPromptlyDynWithMaybe $ \a b -> Just $ f a b

281

236

282−-- | Create a new 'Event' by combining the value at each occurrence with the

237+-- | Create a new 'Event' by combining the value at each occurence with the

283-- current value of the 'Dynamic' value and possibly filtering if the combining

238-- current value of the 'Dynamic' value and possibly filtering if the combining

284-- function returns 'Nothing'.

239-- function returns 'Nothing'.

285--

240--

286−-- Note: @/attachPromptlyDynWithMaybe f d/@ is not the same as @/attachWithMaybe f (current d)/@. See 'tagPromptlyDyn' for details.

241+-- Note: `attachPromptlyDynWithMaybe f d` is not the same as `attachWithMaybe f

242+-- (current d)`. See 'tagPromptlyDyn' for details.

287attachPromptlyDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c

243attachPromptlyDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c

288attachPromptlyDynWithMaybe f d e =

244attachPromptlyDynWithMaybe f d e =

289 let e' = attach (current d) e

245 let e' = attach (current d) e

@@ -292,49 +248,6 @@ attachPromptlyDynWithMaybe f d e =

292 These (_, b) a -> f a b -- Both events are firing, so use the newer value

248 These (_, b) a -> f a b -- Both events are firing, so use the newer value

293 That _ -> Nothing -- The tagging event isn't firing, so don't fire

249 That _ -> Nothing -- The tagging event isn't firing, so don't fire

294

250

295−-- | Factor a @/Dynamic t (Maybe a)/@ into a @/Dynamic t (Maybe (Dynamic t a))/@,

296−-- such that the outer 'Dynamic' is updated only when the "Maybe"'s constructor

297−-- chages from 'Nothing' to 'Just' or vice-versa. Whenever the constructor

298−-- becomes 'Just', an inner 'Dynamic' will be provided, whose value will track

299−-- the 'a' inside the 'Just'; when the constructor becomes 'Nothing', the

300−-- existing inner 'Dynamic' will become constant, and will not change when the

301−-- outer constructor changes back to 'Nothing'.

302−maybeDyn :: forall t a m. (Reflex t, MonadFix m, MonadHold t m) => Dynamic t (Maybe a) -> m (Dynamic t (Maybe (Dynamic t a)))

303−maybeDyn = fmap (fmap unpack) . eitherDyn . fmap pack

304− where pack = \case

305− Nothing -> Left ()

306− Just a -> Right a

307− unpack = \case

308− Left _ -> Nothing

309− Right a -> Just a

310−

311−-- | Turns a 'Dynamic t (Either a b)' into a 'Dynamic t (Either (Dynamic t a) (Dynamic t b))' such that

312−-- the outer 'Dynamic' is updated only when the 'Either' constructor changes (e.g., from 'Left' to 'Right').

313−eitherDyn :: forall t a b m. (Reflex t, MonadFix m, MonadHold t m) => Dynamic t (Either a b) -> m (Dynamic t (Either (Dynamic t a) (Dynamic t b)))

314−eitherDyn = fmap (fmap unpack) . factorDyn . fmap eitherToDSum

315− where unpack :: DSum (EitherTag a b) (Compose (Dynamic t) Identity) -> Either (Dynamic t a) (Dynamic t b)

316− unpack = \case

317− LeftTag :=> Compose a -> Left $ coerceDynamic a

318− RightTag :=> Compose b -> Right $ coerceDynamic b

319−

320−-- | Factor a 'Dynamic t DSum' into a 'Dynamic' 'DSum' containing nested 'Dynamic' values.

321−-- The outer 'Dynamic' updates only when the key of the 'DSum' changes, while the update of the inner

322−-- 'Dynamic' represents updates within the current key.

323−factorDyn :: forall t m k v. (Reflex t, MonadHold t m, GEq k)

324− => Dynamic t (DSum k v) -> m (Dynamic t (DSum k (Compose (Dynamic t) v)))

325−factorDyn d = buildDynamic (sample (current d) >>= holdKey) update where

326− update :: Event t (DSum k (Compose (Dynamic t) v))

327− update = flip push (updated d) $ \(newKey :=> newVal) -> do

328− (oldKey :=> _) <- sample (current d)

329− case newKey `geq` oldKey of

330− Just Refl -> return Nothing

331− Nothing -> Just <$> holdKey (newKey :=> newVal)

332−

333− holdKey (k :=> v) = do

334− inner' <- filterEventKey k (updated d)

335− inner <- holdDyn v inner'

336− return $ k :=> Compose inner

337−

338--------------------------------------------------------------------------------

251--------------------------------------------------------------------------------

339-- Demux

252-- Demux

340--------------------------------------------------------------------------------

253--------------------------------------------------------------------------------

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

348--

261--

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

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

350--

263--

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

264+-- However, the when getDemuxed is used multiple times, the complexity is only

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

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

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

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

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

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

@@ -434,9 +347,6 @@ data HListPtr l a where

434 HHeadPtr :: HListPtr (h ': t) h

347 HHeadPtr :: HListPtr (h ': t) h

435 HTailPtr :: HListPtr t a -> HListPtr (h ': t) a

348 HTailPtr :: HListPtr t a -> HListPtr (h ': t) a

436

349

437−deriving instance Eq (HListPtr l a)

438−deriving instance Ord (HListPtr l a)

439−

440fhlistToDMap :: forall (f :: * -> *) l. FHList f l -> DMap (HListPtr l) f

350fhlistToDMap :: forall (f :: * -> *) l. FHList f l -> DMap (HListPtr l) f

441fhlistToDMap = DMap.fromList . go

351fhlistToDMap = DMap.fromList . go

442 where go :: forall l'. FHList f l' -> [DSum (HListPtr l') f]

352 where go :: forall l'. FHList f l' -> [DSum (HListPtr l') f]

@@ -502,7 +412,7 @@ instance AllAreFunctors f t => AllAreFunctors f (h ': t) where

502

412

503-- | Convert a datastructure whose constituent parts are all 'Dynamic's into a

413-- | Convert a datastructure whose constituent parts are all 'Dynamic's into a

504-- single 'Dynamic' whose value represents all the current values of the input's

414-- single 'Dynamic' whose value represents all the current values of the input's

505−-- constituent 'Dynamic's.

415+-- consitutent 'Dynamic's.

506collectDynPure :: ( RebuildSortedHList (HListElems b)

416collectDynPure :: ( RebuildSortedHList (HListElems b)

507 , IsHList a, IsHList b

417 , IsHList a, IsHList b

508 , AllAreFunctors (Dynamic t) (HListElems b)

418 , AllAreFunctors (Dynamic t) (HListElems b)

@@ -543,3 +453,134 @@ instance IsHList (a, b, c, d, e, f) where

543#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800

453#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800

544 _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139

454 _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139

545#endif

455#endif

456+

457+--------------------------------------------------------------------------------

458+-- Deprecated functions

459+--------------------------------------------------------------------------------

460+

461+-- | Map a function over a 'Dynamic'.

462+{-# DEPRECATED mapDyn "Use 'return . fmap f' instead of 'mapDyn f'; consider eliminating monadic style" #-}

463+mapDyn :: (Reflex t, Monad m) => (a -> b) -> Dynamic t a -> m (Dynamic t b)

464+mapDyn f = return . fmap f

465+

466+-- | Map a sampling function over a 'Dynamic'. The sampling function will use the input 'Dynamic''s 'current' 'Behavior' until the first time its 'updated' 'Event' fires, at which point it will be invoked only once each time the 'Event' fires.

467+{-# DEPRECATED mapDynM "Consider using the Monad instance for Dynamic instead." #-}

468+mapDynM :: forall t m a b. (Reflex t, MonadHold t m) => (forall m'. MonadSample t m' => a -> m' b) -> Dynamic t a -> m (Dynamic t b)

469+mapDynM f d = do

470+ let e' = push (fmap Just . f :: a -> PushM t (Maybe b)) $ updated d

471+ eb' = fmap constant e'

472+ v0 = pull $ f =<< sample (current d)

473+ bb' :: Behavior t (Behavior t b) <- hold v0 eb'

474+ let b' = pull $ sample =<< sample bb'

475+ return $ unsafeDynamic b' e'

476+

477+-- | Flipped version of 'mapDyn'.

478+{-# DEPRECATED forDyn "Use 'return . ffor a' instead of 'forDyn a'; consider eliminating monadic style" #-}

479+forDyn :: (Reflex t, Monad m) => Dynamic t a -> (a -> b) -> m (Dynamic t b)

480+forDyn a = return . ffor a

481+

482+-- | Flipped version of 'mapDynM'

483+{-# DEPRECATED forDynM "Consider using the Monad instance for Dynamic instead." #-}

484+forDynM :: forall t m a b. (Reflex t, MonadHold t m) => Dynamic t a -> (forall m'. MonadSample t m' => a -> m' b) -> m (Dynamic t b)

485+forDynM d f = mapDynM f d

486+

487+-- | Split the 'Dynamic' into two 'Dynamic's, each taking the respective value

488+-- of the tuple.

489+{-# DEPRECATED splitDyn "Use 'return . splitDynPure' instead; consider eliminating monadic style" #-}

490+splitDyn :: (Reflex t, Monad m) => Dynamic t (a, b) -> m (Dynamic t a, Dynamic t b)

491+splitDyn = return . splitDynPure

492+

493+-- | Merge the 'Dynamic' values using their 'Monoid' instance.

494+{-# DEPRECATED mconcatDyn "Use 'return . mconcat' instead; consider eliminating monadic style" #-}

495+mconcatDyn :: forall t m a. (Reflex t, Monad m, Monoid a) => [Dynamic t a] -> m (Dynamic t a)

496+mconcatDyn = return . mconcat

497+

498+-- | This function no longer needs to be monadic; see 'distributeMapOverDynPure'.

499+{-# DEPRECATED distributeDMapOverDyn "Use 'return . distributeDMapOverDynPure' instead; consider eliminating monadic style" #-}

500+distributeDMapOverDyn :: (Reflex t, Monad m, GCompare k) => DMap k (Dynamic t) -> m (Dynamic t (DMap k Identity))

501+distributeDMapOverDyn = return . distributeDMapOverDynPure

502+

503+-- | Merge two 'Dynamic's into a new one using the provided function. The new

504+-- 'Dynamic' changes its value each time one of the original 'Dynamic's changes

505+-- its value.

506+{-# DEPRECATED combineDyn "Use 'return (zipDynWith f a b)' instead of 'combineDyn f a b'; consider eliminating monadic style" #-}

507+combineDyn :: forall t m a b c. (Reflex t, Monad m) => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> m (Dynamic t c)

508+combineDyn f a b = return $ zipDynWith f a b

509+

510+-- | A psuedo applicative version of ap for 'Dynamic'. Example useage:

511+--

512+-- > do

513+-- > person <- Person `mapDyn` dynFirstName

514+-- > `apDyn` dynListName

515+-- > `apDyn` dynAge

516+-- > `apDyn` dynAddress

517+{-# DEPRECATED apDyn "Use 'ffor m (<*> a)' instead of 'apDyn m a'; consider eliminating monadic style, since Dynamics are now Applicative and can be used with applicative style directly" #-}

518+#ifdef USE_TEMPLATE_HASKELL

519+{-# ANN apDyn "HLint: ignore Use fmap" #-}

520+#endif

521+apDyn :: forall t m a b. (Reflex t, Monad m)

522+ => m (Dynamic t (a -> b))

523+ -> Dynamic t a

524+ -> m (Dynamic t b)

525+apDyn m a = fmap (<*> a) m

526+

527+--TODO: The pattern of using hold (sample b0) can be reused in various places as a safe way of building certain kinds of Dynamics; see if we can factor this out

528+-- | This function no longer needs to be monadic, so it has been replaced by

529+-- 'demuxed', which is pure.

530+{-# DEPRECATED getDemuxed "Use 'return . demuxed d' instead of 'getDemuxed d'; consider eliminating monadic style" #-}

531+getDemuxed :: (Reflex t, Monad m, Eq k) => Demux t k -> k -> m (Dynamic t Bool)

532+getDemuxed d = return . demuxed d

533+

534+-- | This function no longer needs to be monadic, so it has been replaced by

535+-- 'distributeFHListOverDynPure', which is pure.

536+{-# DEPRECATED distributeFHListOverDyn "Use 'return . distributeFHListOverDynPure' instead; consider eliminating monadic style" #-}

537+distributeFHListOverDyn :: forall t m l. (Reflex t, Monad m, RebuildSortedHList l) => FHList (Dynamic t) l -> m (Dynamic t (HList l))

538+distributeFHListOverDyn = return . distributeFHListOverDynPure

539+

540+-- | This function no longer needs to be monadic, so it has been replaced by

541+-- 'collectDynPure', which is pure.

542+{-# DEPRECATED collectDyn "Use 'return . collectDynPure' instead; consider eliminating monadic style" #-}

543+collectDyn :: ( RebuildSortedHList (HListElems b)

544+ , IsHList a, IsHList b

545+ , AllAreFunctors (Dynamic t) (HListElems b)

546+ , Reflex t, Monad m

547+ , HListElems a ~ FunctorList (Dynamic t) (HListElems b)

548+ ) => a -> m (Dynamic t b)

549+collectDyn = return . collectDynPure

550+

551+-- | This function has been renamed to 'tagPromptlyDyn' to clarify its

552+-- semantics.

553+{-# DEPRECATED tagDyn "Use 'tagPromptlyDyn' instead" #-}

554+tagDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a

555+tagDyn = tagPromptlyDyn

556+

557+-- | This function has been renamed to 'attachPromptlyDyn' to clarify its

558+-- semantics.

559+{-# DEPRECATED attachDyn "Use 'attachPromptlyDyn' instead" #-}

560+attachDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b)

561+attachDyn = attachPromptlyDyn

562+

563+-- | This function has been renamed to 'attachPromptlyDynWith' to clarify its

564+-- semantics.

565+{-# DEPRECATED attachDynWith "Use 'attachPromptlyDynWith' instead" #-}

566+attachDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c

567+attachDynWith = attachPromptlyDynWith

568+

569+-- | This function has been renamed to 'attachPromptlyDynWithMaybe' to clarify

570+-- its semantics.

571+{-# DEPRECATED attachDynWithMaybe "Use 'attachPromptlyDynWithMaybe' instead" #-}

572+attachDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c

573+attachDynWithMaybe = attachPromptlyDynWithMaybe

574+

575+-- | Combine an inner and outer 'Dynamic' such that the resulting 'Dynamic''s

576+-- current value will always be equal to the current value's current value, and

577+-- will change whenever either the inner or the outer (or both) values change.

578+{-# DEPRECATED joinDyn "Use 'join' instead" #-}

579+joinDyn :: Reflex t => Dynamic t (Dynamic t a) -> Dynamic t a

580+joinDyn = join

581+

582+-- | 'nubDyn''s behavior is not quite analogous to 'nub''s behavior, so it has

583+-- been renamed to 'uniqDyn'

584+{-# DEPRECATED nubDyn "Use 'uniqDyn' instead" #-}

585+nubDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a

586+nubDyn = uniqDyn

src/Reflex/Dynamic/TH.hs+28−14

@@ -13,6 +13,9 @@ module Reflex.Dynamic.TH

13 ( qDynPure

14 , unqDyn

15 , mkDynPure

16+ -- * Deprecated functions

17+ , qDyn

18+ , mkDyn

16 ) where

19 ) where

18import Reflex.Dynamic

21import Reflex.Dynamic

@@ -20,7 +23,7 @@ import Reflex.Dynamic

20import Control.Monad.State

23import Control.Monad.State

21import Data.Data

24import Data.Data

22import Data.Generics

25import Data.Generics

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

26+import Data.Monoid

24import qualified Language.Haskell.Exts as Hs

27import qualified Language.Haskell.Exts as Hs

25import qualified Language.Haskell.Meta.Syntax.Translate as Hs

28import qualified Language.Haskell.Meta.Syntax.Translate as Hs

26import Language.Haskell.TH

29import Language.Haskell.TH

@@ -44,8 +47,8 @@ qDynPure qe = do

44 _ -> gmapM f d

47 _ -> gmapM f d

45 (e', exprsReversed) <- runStateT (gmapM f e) []

48 (e', exprsReversed) <- runStateT (gmapM f e) []

46 let exprs = reverse exprsReversed

49 let exprs = reverse exprsReversed

47− arg = foldr (\a b -> ConE 'FHCons `AppE` snd a `AppE` b) (ConE 'FHNil) exprs

50+ arg = foldr (\a b -> ConE 'FHCons `AppE` a `AppE` b) (ConE 'FHNil) $ map snd exprs

48− param = foldr (\a b -> ConP 'HCons [VarP (fst a), b]) (ConP 'HNil []) exprs

51+ param = foldr (\a b -> ConP 'HCons [VarP a, b]) (ConP 'HNil []) $ map fst exprs

49 [| $(return $ LamE [param] e') <$> distributeFHListOverDynPure $(return arg) |]

52 [| $(return $ LamE [param] e') <$> distributeFHListOverDynPure $(return arg) |]

51-- | Antiquote a 'Dynamic' expression. This can /only/ be used inside of a

54-- | Antiquote a 'Dynamic' expression. This can /only/ be used inside of a

@@ -81,26 +84,37 @@ mkDynPure = QuasiQuoter

81 }

84 }

83mkDynExp :: String -> Q Exp

86mkDynExp :: String -> Q Exp

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

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

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

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

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

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

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

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

88−#if MIN_VERSION_haskell_src_exts(1,18,0)

89− antiE :: Hs.Exp Hs.SrcSpanInfo -> Hs.Exp Hs.SrcSpanInfo

90− antiE x = case x of

91− Hs.SpliceExp l se ->

92− Hs.App l (Hs.Var l $ Hs.Qual l (Hs.ModuleName l modName) (Hs.Ident l occName)) $ case se of

93− Hs.IdSplice l2 v -> Hs.Var l2 $ Hs.UnQual l2 $ Hs.Ident l2 v

94− Hs.ParenSplice _ ps -> ps

95− _ -> x

96−#else

97 antiE x = case x of

91 antiE x = case x of

98 Hs.SpliceExp se ->

92 Hs.SpliceExp se ->

99 Hs.App (Hs.Var $ Hs.Qual (Hs.ModuleName modName) (Hs.Ident occName)) $ case se of

93 Hs.App (Hs.Var $ Hs.Qual (Hs.ModuleName modName) (Hs.Ident occName)) $ case se of

100 Hs.IdSplice v -> Hs.Var $ Hs.UnQual $ Hs.Ident v

94 Hs.IdSplice v -> Hs.Var $ Hs.UnQual $ Hs.Ident v

101 Hs.ParenSplice ps -> ps

95 Hs.ParenSplice ps -> ps

102 _ -> x

96 _ -> x

103−#endif

104 reinstateUnqDyn (TH.Name (TH.OccName occName') (TH.NameQ (TH.ModName modName')))

97 reinstateUnqDyn (TH.Name (TH.OccName occName') (TH.NameQ (TH.ModName modName')))

105 | modName == modName' && occName == occName' = 'unqMarker

98 | modName == modName' && occName == occName' = 'unqMarker

106 reinstateUnqDyn x = x

99 reinstateUnqDyn x = x

100+

101+--------------------------------------------------------------------------------

102+-- Deprecated

103+--------------------------------------------------------------------------------

104+

105+{-# DEPRECATED qDyn "Instead of $(qDyn x), use return $(qDynPure x)" #-}

106+-- | Like 'qDynPure', but wraps its result monadically using 'return'. This is

107+-- no longer necessary, due to 'Dynamic' being an instance of 'Functor'.

108+qDyn :: Q Exp -> Q Exp

109+qDyn qe = [| return $(qDynPure qe) |]

110+

111+{-# DEPRECATED mkDyn "Instead of [mkDyn| x |], use return [mkDynPure| x |]" #-}

112+-- | Like 'mkDynPure', but wraps its result monadically using 'return'. This is

113+-- no longer necessary, due to 'Dynamic' being an instance of 'Functor'.

114+mkDyn :: QuasiQuoter

115+mkDyn = QuasiQuoter

116+ { quoteExp = \s -> [| return $(mkDynExp s) |]

117+ , quotePat = error "mkDyn: pattern splices are not supported"

118+ , quoteType = error "mkDyn: type splices are not supported"

119+ , quoteDec = error "mkDyn: declaration splices are not supported"

120+ }

src/Reflex/Dynamic/Uniq.hs+5−5

@@ -17,6 +17,7 @@ module Reflex.Dynamic.Uniq

17import Control.Applicative (Applicative (..))

18import GHC.Exts

19import Reflex.Class

20+import Reflex.Dynamic

21-- | A 'Dynamic' whose 'updated' 'Event' will never fire with the same value as

22-- | A 'Dynamic' whose 'updated' 'Event' will never fire with the same value as

22-- the 'current' 'Behavior''s contents. In order to maintain this constraint,

23-- the 'current' 'Behavior''s contents. In order to maintain this constraint,

@@ -31,7 +32,7 @@ newtype UniqDynamic t a = UniqDynamic { unUniqDynamic :: Dynamic t a }

32-- | Construct a 'UniqDynamic' by eliminating redundant updates from a 'Dynamic'.

33-- | Construct a 'UniqDynamic' by eliminating redundant updates from a 'Dynamic'.

33uniqDynamic :: Reflex t => Dynamic t a -> UniqDynamic t a

34uniqDynamic :: Reflex t => Dynamic t a -> UniqDynamic t a

34−uniqDynamic d = UniqDynamic $ unsafeBuildDynamic (sample $ current d) $ flip pushCheap (updated d) $ \new -> do

35+uniqDynamic d = UniqDynamic $ unsafeBuildDynamic (sample $ current d) $ flip push (updated d) $ \new -> do --TODO: It would be very nice if we had an uncached push here

35 old <- sample $ current d --TODO: Is it better to sample ourselves here?

36 old <- sample $ current d --TODO: Is it better to sample ourselves here?

36 return $ unsafeJustChanged old new

37 return $ unsafeJustChanged old new

@@ -46,7 +47,7 @@ uniqDynamic d = UniqDynamic $ unsafeBuildDynamic (sample $ current d) $ flip pus

46-- instance, but can be equal by pointer equality. This may cause 'UniqDynamic'

47-- instance, but can be equal by pointer equality. This may cause 'UniqDynamic'

47-- to lose changes from NaN to NaN.

48-- to lose changes from NaN to NaN.

48fromUniqDynamic :: (Reflex t, Eq a) => UniqDynamic t a -> Dynamic t a

49fromUniqDynamic :: (Reflex t, Eq a) => UniqDynamic t a -> Dynamic t a

49−fromUniqDynamic (UniqDynamic d) = unsafeDynamic (current d) e'

50+fromUniqDynamic (UniqDynamic d) = uniqDynBy superEq d

50 where

51 where

51 -- Only consider values different if they fail both pointer equality /and/

52 -- Only consider values different if they fail both pointer equality /and/

52 -- 'Eq' equality. This is to make things a bit more deterministic in the

53 -- 'Eq' equality. This is to make things a bit more deterministic in the

@@ -56,7 +57,6 @@ fromUniqDynamic (UniqDynamic d) = unsafeDynamic (current d) e'

56 -- nonequal by pointer quality. I suspect that it is impossible to make the

57 -- nonequal by pointer quality. I suspect that it is impossible to make the

57 -- behavior deterministic in this case.

58 -- behavior deterministic in this case.

58 superEq a b = a `unsafePtrEq` b || a == b

59 superEq a b = a `unsafePtrEq` b || a == b

59− e' = attachWithMaybe (\x x' -> if x' `superEq` x then Nothing else Just x') (current d) (updated d)

61-- | Create a UniqDynamic without uniqing it on creation. This will be slightly

62-- faster than uniqDynamic when used with a Dynamic whose values are always (or

@@ -81,13 +81,13 @@ instance Reflex t => Accumulator t (UniqDynamic t) where

81 let f' old change = do

82 mNew <- f old change

83 return $ unsafeJustChanged old =<< mNew

84− d <- accumMaybeMDyn f' z e

84+ d <- accumMaybeM f' z e

85 return $ UniqDynamic d

86 mapAccumMaybeM f z e = do

87 let f' old change = do

88 (mNew, output) <- f old change

89 return (unsafeJustChanged old =<< mNew, output)

90− (d, out) <- mapAccumMaybeMDyn f' z e

90+ (d, out) <- mapAccumMaybeM f' z e

91 return (UniqDynamic d, out)

93instance Reflex t => Functor (UniqDynamic t) where

src/Reflex/DynamicWriter.hs+190−4

@@ -1,7 +1,193 @@

1+-- | This module defines 'MonadDynamicWriter' and 'DynamicWriterT', its standard

2+-- implementation.

3+{-# LANGUAGE CPP #-}

4+{-# LANGUAGE FlexibleInstances #-}

5+{-# LANGUAGE FunctionalDependencies #-}

6+{-# LANGUAGE GADTs #-}

7+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8+{-# LANGUAGE LambdaCase #-}

9+{-# LANGUAGE MultiParamTypeClasses #-}

10+{-# LANGUAGE RankNTypes #-}

11+{-# LANGUAGE ScopedTypeVariables #-}

12+{-# LANGUAGE TypeFamilies #-}

13+{-# LANGUAGE UndecidableInstances #-}

14+#ifdef USE_REFLEX_OPTIMIZER

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

16+#endif

1module Reflex.DynamicWriter

17module Reflex.DynamicWriter

2− {-# DEPRECATED "Use 'Reflex.DynamicWriter.Class' and 'Reflex.DynamicWrite.Base' instead, or just import 'Reflex'" #-}

18+ ( MonadDynamicWriter (..)

3− ( module X

19+ , DynamicWriterT (..)

20+ , runDynamicWriterT

21+ , withDynamicWriterT

4 ) where

22 ) where

6−import Reflex.DynamicWriter.Base as X

24+import Control.Monad.Exception

25+import Control.Monad.Identity

26+import Control.Monad.IO.Class

27+import Control.Monad.Reader

28+import Control.Monad.Ref

29+import Control.Monad.State.Strict

30+import Data.Align

31+import Data.Dependent.Map (DMap)

32+import qualified Data.Dependent.Map as DMap

33+import Data.Functor.Misc

34+import Data.Map (Map)

35+import qualified Data.Map as Map

36+import Data.Semigroup

37+import Data.Some (Some)

38+import Data.These

7−import Reflex.DynamicWriter.Class as X

39+import Reflex.Class

40+import Reflex.Host.Class

41+import Reflex.PerformEvent.Class

42+import Reflex.PostBuild.Class

43+import Reflex.Requester.Class

44+import Reflex.TriggerEvent.Class

45+

46+instance MonadTrans (DynamicWriterT t w) where

47+ lift = DynamicWriterT . lift

48+

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

50+mapIncrementalMapValues f = unsafeMapIncremental (fmap f) (fmap f)

51+

52+mergeDynIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Dynamic t v)) -> Incremental t (PatchMap k v)

53+mergeDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues

54+ where changedValues = fmap (PatchMap . fmap Just) $ mergeMapIncremental $ mapIncrementalMapValues updated a

55+ addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchMap m) -> PatchMap <$> mapM (mapM (sample . current)) m

56+

57+mergeDynIncrementalWithMove :: (Reflex t, Ord k) => Incremental t (PatchMapWithMove k (Dynamic t v)) -> Incremental t (PatchMapWithMove k v)

58+mergeDynIncrementalWithMove a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ alignWith f addedAndRemovedValues changedValues

59+ where changedValues = mergeMapIncrementalWithMove $ mapIncrementalMapValues updated a

60+ addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ fmap unsafePatchMapWithMove . mapM (mapM (sample . current)) . unPatchMapWithMove

61+ f x = unsafePatchMapWithMove $

62+ let (p, changed) = case x of

63+ This p_ -> (unPatchMapWithMove p_, mempty)

64+ That c -> (mempty, c)

65+ These p_ c -> (unPatchMapWithMove p_, c)

66+ (pWithNewVals, noLongerMoved) = flip runState [] $ forM p $ \case

67+ MapEdit_Insert moved v -> return $ MapEdit_Insert moved v

68+ MapEdit_Delete moved -> return $ MapEdit_Delete moved

69+ MapEdit_Move moved k -> case Map.lookup k changed of

70+ Nothing -> return $ MapEdit_Move moved k

71+ Just v -> do

72+ modify (k:)

73+ return $ MapEdit_Insert moved v

74+ noLongerMovedMap = Map.fromList $ fmap (\k -> (k, ())) noLongerMoved

75+ removeMovedFlag = \case --TODO: Check if moved was true before, in each case?

76+ MapEdit_Insert _ v -> MapEdit_Insert False v

77+ MapEdit_Delete _ -> MapEdit_Delete False

78+ MapEdit_Move _ k -> MapEdit_Move False k

79+ in Map.differenceWith (\e _ -> Just $ removeMovedFlag e) pWithNewVals noLongerMovedMap --TODO: Check if any in the second map are not covered?

80+

81+-- | A basic implementation of 'MonadDynamicWriter'.

82+newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT [Dynamic t w] m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadHold t, MonadSample t, MonadAsyncException, MonadException) -- The list is kept in reverse order

83+

84+instance MonadRef m => MonadRef (DynamicWriterT t w m) where

85+ type Ref (DynamicWriterT t w m) = Ref m

86+ newRef = lift . newRef

87+ readRef = lift . readRef

88+ writeRef r = lift . writeRef r

89+

90+instance MonadAtomicRef m => MonadAtomicRef (DynamicWriterT t w m) where

91+ atomicModifyRef r = lift . atomicModifyRef r

92+

93+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWriterT t w m) where

94+ newEventWithTrigger = lift . newEventWithTrigger

95+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

96+

97+-- | Run a 'DynamicWriterT' action. The dynamic writer output will be provided

98+-- along with the result of the action.

99+runDynamicWriterT :: (MonadFix m, Reflex t, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)

100+runDynamicWriterT (DynamicWriterT a) = do

101+ (result, ws) <- runStateT a []

102+ return (result, mconcat $ reverse ws)

103+

104+-- | 'MonadDynamicWriter' efficiently collects 'Dynamic' values using 'tellDyn'

105+-- and combines them monoidally to provide a 'Dynamic' result.

106+class (Monad m, Monoid w) => MonadDynamicWriter t w m | m -> t w where

107+ tellDyn :: Dynamic t w -> m ()

108+

109+instance (Monad m, Monoid w, Reflex t) => MonadDynamicWriter t w (DynamicWriterT t w m) where

110+ tellDyn w = DynamicWriterT $ modify (w :)

111+

112+instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where

113+ ask = lift ask

114+ local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a

115+ reader = lift . reader

116+

117+instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where

118+ type Performable (DynamicWriterT t w m) = Performable m

119+ performEvent_ = lift . performEvent_

120+ performEvent = lift . performEvent

121+

122+instance TriggerEvent t m => TriggerEvent t (DynamicWriterT t w m) where

123+ newTriggerEvent = lift newTriggerEvent

124+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

125+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

126+

127+instance PostBuild t m => PostBuild t (DynamicWriterT t w m) where

128+ getPostBuild = lift getPostBuild

129+

130+instance MonadDynamicWriter t w m => MonadDynamicWriter t w (ReaderT r m) where

131+ tellDyn = lift . tellDyn

132+

133+instance MonadState s m => MonadState s (DynamicWriterT t w m) where

134+ get = lift get

135+ put = lift . put

136+

137+newtype DynamicWriterTLoweredResult t w v a = DynamicWriterTLoweredResult (v a, Dynamic t w)

138+

139+-- | When the execution of a 'DynamicWriterT' action is adjusted using

140+-- 'MonadAdjust', the 'Dynamic' output of that action will also be updated to

141+-- match.

142+instance (MonadAdjust t m, MonadFix m, Monoid w, MonadHold t m, Reflex t) => MonadAdjust t (DynamicWriterT t w m) where

143+ runWithReplace a0 a' = do

144+ (result0, result') <- lift $ runWithReplace (runDynamicWriterT a0) $ runDynamicWriterT <$> a'

145+ tellDyn . join =<< holdDyn (snd result0) (snd <$> result')

146+ return (fst result0, fst <$> result')

147+ traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap weakenPatchDMapWith mergeDynIncremental

148+ traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove weakenPatchDMapWithMoveWith mergeDynIncrementalWithMove

149+

150+traverseDMapWithKeyWithAdjustImpl :: forall t w k v' p p' v m. (PatchTarget (p' (Some k) (Dynamic t w)) ~ Map (Some k) (Dynamic t w), PatchTarget (p' (Some k) w) ~ Map (Some k) w, Patch (p' (Some k) w), Patch (p' (Some k) (Dynamic t w)), MonadFix m, Monoid w, Reflex t, MonadHold t m)

151+ => ( (forall a. k a -> v a -> m (DynamicWriterTLoweredResult t w v' a))

152+ -> DMap k v

153+ -> Event t (p k v)

154+ -> m (DMap k (DynamicWriterTLoweredResult t w v'), Event t (p k (DynamicWriterTLoweredResult t w v')))

155+ )

156+ -> ((forall a. DynamicWriterTLoweredResult t w v' a -> v' a) -> p k (DynamicWriterTLoweredResult t w v') -> p k v')

157+ -> ((forall a. DynamicWriterTLoweredResult t w v' a -> Dynamic t w) -> p k (DynamicWriterTLoweredResult t w v') -> p' (Some k) (Dynamic t w))

158+ -> (Incremental t (p' (Some k) (Dynamic t w)) -> Incremental t (p' (Some k) w))

159+ -> (forall a. k a -> v a -> DynamicWriterT t w m (v' a))

160+ -> DMap k v

161+ -> Event t (p k v)

162+ -> DynamicWriterT t w m (DMap k v', Event t (p k v'))

163+traverseDMapWithKeyWithAdjustImpl base mapPatch weakenPatchWith mergeMyDynIncremental f (dm0 :: DMap k v) dm' = do

164+ (result0, result') <- lift $ base (\k v -> fmap DynamicWriterTLoweredResult $ runDynamicWriterT $ f k v) dm0 dm'

165+ let getValue (DynamicWriterTLoweredResult (v, _)) = v

166+ getWritten (DynamicWriterTLoweredResult (_, w)) = w

167+ liftedResult0 = DMap.map getValue result0

168+ liftedResult' = ffor result' $ mapPatch getValue

169+ liftedWritten0 :: Map (Some k) (Dynamic t w)

170+ liftedWritten0 = weakenDMapWith getWritten result0

171+ liftedWritten' = ffor result' $ weakenPatchWith getWritten

172+ --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics

173+ i <- holdIncremental liftedWritten0 liftedWritten'

174+ tellDyn $ fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeMyDynIncremental i

175+ return (liftedResult0, liftedResult')

176+

177+-- | Map a function over the output of a 'DynamicWriterT'.

178+withDynamicWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m, MonadFix m)

179+ => (w -> w')

180+ -> DynamicWriterT t w m a

181+ -> DynamicWriterT t w' m a

182+withDynamicWriterT f dw = do

183+ (r, d) <- lift $ do

184+ (r, d) <- runDynamicWriterT dw

185+ let d' = fmap f d

186+ return (r, d')

187+ tellDyn d

188+ return r

189+

190+instance Requester t m => Requester t (DynamicWriterT t w m) where

191+ type Request (DynamicWriterT t w m) = Request m

192+ type Response (DynamicWriterT t w m) = Response m

193+ withRequesting f = DynamicWriterT $ withRequesting $ unDynamicWriterT . f

src/Reflex/DynamicWriter/Base.hsdeleted−246

@@ -1,246 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE FlexibleInstances #-}

3−{-# LANGUAGE GADTs #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5−{-# LANGUAGE LambdaCase #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

7−{-# LANGUAGE RankNTypes #-}

8−{-# LANGUAGE ScopedTypeVariables #-}

9−{-# LANGUAGE TupleSections #-}

10−{-# LANGUAGE TypeFamilies #-}

11−{-# LANGUAGE UndecidableInstances #-}

12−{-# LANGUAGE StandaloneDeriving #-}

13−#ifdef USE_REFLEX_OPTIMIZER

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

15−#endif

16−module Reflex.DynamicWriter.Base

17− ( DynamicWriterT (..)

18− , runDynamicWriterT

19− , withDynamicWriterT

20− ) where

21−

22−import Control.Monad.Exception

23−import Control.Monad.Identity

24−import Control.Monad.IO.Class

25−import Control.Monad.Morph

26−import Control.Monad.Primitive

27−import Control.Monad.Reader

28−import Control.Monad.Ref

29−import Control.Monad.State.Strict

30−import Data.Align

31−import Data.Dependent.Map (DMap)

32−import qualified Data.Dependent.Map as DMap

33−import Data.FastMutableIntMap

34−import Data.Functor.Misc

35−import Data.IntMap (IntMap)

36−import qualified Data.IntMap as IntMap

37−import Data.Map (Map)

38−import qualified Data.Map as Map

39−import Data.Semigroup (Semigroup(..))

40−import Data.Some (Some)

41−import Data.These

42−

43−import Reflex.Adjustable.Class

44−import Reflex.Class

45−import Reflex.DynamicWriter.Class

46−import Reflex.EventWriter.Class (EventWriter, tellEvent)

47−import Reflex.Host.Class

48−import qualified Data.Patch.MapWithMove as MapWithMove

49−import Reflex.PerformEvent.Class

50−import Reflex.PostBuild.Class

51−import Reflex.Query.Class

52−import Reflex.Requester.Class

53−import Reflex.TriggerEvent.Class

54−

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

56−mapIncrementalMapValues f = unsafeMapIncremental (fmap f) (fmap f)

57−

58−mergeDynIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Dynamic t v)) -> Incremental t (PatchMap k v)

59−mergeDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues

60− where changedValues = fmap (PatchMap . fmap Just) $ mergeMapIncremental $ mapIncrementalMapValues updated a

61− addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchMap m) -> PatchMap <$> mapM (mapM (sample . current)) m

62−

63−mergeIntMapDynIncremental :: Reflex t => Incremental t (PatchIntMap (Dynamic t v)) -> Incremental t (PatchIntMap v)

64−mergeIntMapDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues

65− where changedValues = fmap (PatchIntMap . fmap Just) $ mergeIntMapIncremental $ mapIncrementalMapValues updated a

66− addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchIntMap m) -> PatchIntMap <$> mapM (mapM (sample . current)) m

67−

68−mergeDynIncrementalWithMove :: forall t k v. (Reflex t, Ord k) => Incremental t (PatchMapWithMove k (Dynamic t v)) -> Incremental t (PatchMapWithMove k v)

69−mergeDynIncrementalWithMove a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ alignWith f addedAndRemovedValues changedValues

70− where changedValues = mergeMapIncrementalWithMove $ mapIncrementalMapValues updated a

71− addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ fmap unsafePatchMapWithMove . mapM (mapM (sample . current)) . unPatchMapWithMove

72− f :: These (PatchMapWithMove k v) (Map k v) -> PatchMapWithMove k v

73− f x = unsafePatchMapWithMove $

74− let (p, changed) = case x of

75− This p_ -> (unPatchMapWithMove p_, mempty)

76− That c -> (mempty, c)

77− These p_ c -> (unPatchMapWithMove p_, c)

78− (pWithNewVals, noLongerMoved) = flip runState [] $ forM p $ MapWithMove.nodeInfoMapMFrom $ \case

79− MapWithMove.From_Insert v -> return $ MapWithMove.From_Insert v

80− MapWithMove.From_Delete -> return MapWithMove.From_Delete

81− MapWithMove.From_Move k -> case Map.lookup k changed of

82− Nothing -> return $ MapWithMove.From_Move k

83− Just v -> do

84− modify (k:)

85− return $ MapWithMove.From_Insert v

86− noLongerMovedMap = Map.fromList $ fmap (, ()) noLongerMoved

87− in Map.differenceWith (\e _ -> Just $ MapWithMove.nodeInfoSetTo Nothing e) pWithNewVals noLongerMovedMap --TODO: Check if any in the second map are not covered?

88−

89−-- | A basic implementation of 'DynamicWriter'.

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

91− -- The list is kept in reverse order

92− deriving

93− ( Functor

94− , Applicative

95− , Monad

96− , MonadTrans

97− , MFunctor

98− , MonadIO

99− , MonadFix

100− , MonadAsyncException

101− , MonadException

102− )

103−

104−deriving instance MonadHold t m => MonadHold t (DynamicWriterT t w m)

105−deriving instance MonadSample t m => MonadSample t (DynamicWriterT t w m)

106−

107−

108−instance MonadRef m => MonadRef (DynamicWriterT t w m) where

109− type Ref (DynamicWriterT t w m) = Ref m

110− newRef = lift . newRef

111− readRef = lift . readRef

112− writeRef r = lift . writeRef r

113−

114−instance MonadAtomicRef m => MonadAtomicRef (DynamicWriterT t w m) where

115− atomicModifyRef r = lift . atomicModifyRef r

116−

117−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWriterT t w m) where

118− newEventWithTrigger = lift . newEventWithTrigger

119− newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

120−

121−-- | Run a 'DynamicWriterT' action. The dynamic writer output will be provided

122−-- along with the result of the action.

123−runDynamicWriterT :: (MonadFix m, Reflex t, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)

124−runDynamicWriterT (DynamicWriterT a) = do

125− (result, ws) <- runStateT a []

126− return (result, mconcat $ reverse ws)

127−

128−instance (Monad m, Monoid w, Reflex t) => DynamicWriter t w (DynamicWriterT t w m) where

129− tellDyn w = DynamicWriterT $ modify (w :)

130−

131−instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where

132− ask = lift ask

133− local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a

134− reader = lift . reader

135−

136−instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where

137− type Performable (DynamicWriterT t w m) = Performable m

138− performEvent_ = lift . performEvent_

139− performEvent = lift . performEvent

140−

141−instance TriggerEvent t m => TriggerEvent t (DynamicWriterT t w m) where

142− newTriggerEvent = lift newTriggerEvent

143− newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

144− newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

145−

146−instance PostBuild t m => PostBuild t (DynamicWriterT t w m) where

147− getPostBuild = lift getPostBuild

148−

149−instance MonadState s m => MonadState s (DynamicWriterT t w m) where

150− get = lift get

151− put = lift . put

152−

153−instance PrimMonad m => PrimMonad (DynamicWriterT t w m) where

154− type PrimState (DynamicWriterT t w m) = PrimState m

155− primitive = lift . primitive

156−

157−newtype DynamicWriterTLoweredResult t w v a = DynamicWriterTLoweredResult (v a, Dynamic t w)

158−

159−-- | When the execution of a 'DynamicWriterT' action is adjusted using

160−-- 'Adjustable', the 'Dynamic' output of that action will also be updated to

161−-- match.

162−instance (Adjustable t m, MonadFix m, Monoid w, MonadHold t m, Reflex t) => Adjustable t (DynamicWriterT t w m) where

163− runWithReplace a0 a' = do

164− (result0, result') <- lift $ runWithReplace (runDynamicWriterT a0) $ runDynamicWriterT <$> a'

165− tellDyn . join =<< holdDyn (snd result0) (snd <$> result')

166− return (fst result0, fst <$> result')

167− traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustImpl traverseIntMapWithKeyWithAdjust mergeIntMapDynIncremental

168− traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap weakenPatchDMapWith mergeDynIncremental

169− traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove weakenPatchDMapWithMoveWith mergeDynIncrementalWithMove

170−

171−traverseDMapWithKeyWithAdjustImpl :: forall t w k v' p p' v m. (PatchTarget (p' (Some k) (Dynamic t w)) ~ Map (Some k) (Dynamic t w), PatchTarget (p' (Some k) w) ~ Map (Some k) w, Patch (p' (Some k) w), Patch (p' (Some k) (Dynamic t w)), MonadFix m, Monoid w, Reflex t, MonadHold t m)

172− => ( (forall a. k a -> v a -> m (DynamicWriterTLoweredResult t w v' a))

173− -> DMap k v

174− -> Event t (p k v)

175− -> m (DMap k (DynamicWriterTLoweredResult t w v'), Event t (p k (DynamicWriterTLoweredResult t w v')))

176− )

177− -> ((forall a. DynamicWriterTLoweredResult t w v' a -> v' a) -> p k (DynamicWriterTLoweredResult t w v') -> p k v')

178− -> ((forall a. DynamicWriterTLoweredResult t w v' a -> Dynamic t w) -> p k (DynamicWriterTLoweredResult t w v') -> p' (Some k) (Dynamic t w))

179− -> (Incremental t (p' (Some k) (Dynamic t w)) -> Incremental t (p' (Some k) w))

180− -> (forall a. k a -> v a -> DynamicWriterT t w m (v' a))

181− -> DMap k v

182− -> Event t (p k v)

183− -> DynamicWriterT t w m (DMap k v', Event t (p k v'))

184−traverseDMapWithKeyWithAdjustImpl base mapPatch weakenPatchWith mergeMyDynIncremental f (dm0 :: DMap k v) dm' = do

185− (result0, result') <- lift $ base (\k v -> fmap DynamicWriterTLoweredResult $ runDynamicWriterT $ f k v) dm0 dm'

186− let getValue (DynamicWriterTLoweredResult (v, _)) = v

187− getWritten (DynamicWriterTLoweredResult (_, w)) = w

188− liftedResult0 = DMap.map getValue result0

189− liftedResult' = ffor result' $ mapPatch getValue

190− liftedWritten0 :: Map (Some k) (Dynamic t w)

191− liftedWritten0 = weakenDMapWith getWritten result0

192− liftedWritten' = ffor result' $ weakenPatchWith getWritten

193− --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics

194− i <- holdIncremental liftedWritten0 liftedWritten'

195− tellDyn $ fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeMyDynIncremental i

196− return (liftedResult0, liftedResult')

197−

198−traverseIntMapWithKeyWithAdjustImpl :: forall t w v' p p' v m. (PatchTarget (p' (Dynamic t w)) ~ IntMap (Dynamic t w), PatchTarget (p' w) ~ IntMap w, Patch (p' w), Patch (p' (Dynamic t w)), MonadFix m, Monoid w, Reflex t, MonadHold t m, Functor p, p ~ p')

199− => ( (IntMap.Key -> v -> m (v', Dynamic t w))

200− -> IntMap v

201− -> Event t (p v)

202− -> m (IntMap (v', Dynamic t w), Event t (p (v', Dynamic t w)))

203− )

204− -> (Incremental t (p' (Dynamic t w)) -> Incremental t (p' w))

205− -> (IntMap.Key -> v -> DynamicWriterT t w m v')

206− -> IntMap v

207− -> Event t (p v)

208− -> DynamicWriterT t w m (IntMap v', Event t (p v'))

209−traverseIntMapWithKeyWithAdjustImpl base mergeMyDynIncremental f (dm0 :: IntMap v) dm' = do

210− (result0, result') <- lift $ base (\k v -> runDynamicWriterT $ f k v) dm0 dm'

211− let liftedResult0 = fmap fst result0

212− liftedResult' = fmap (fmap fst) result'

213− liftedWritten0 :: IntMap (Dynamic t w)

214− liftedWritten0 = fmap snd result0

215− liftedWritten' = fmap (fmap snd) result'

216− --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics

217− i <- holdIncremental liftedWritten0 liftedWritten'

218− tellDyn $ fmap (mconcat . IntMap.elems) $ incrementalToDynamic $ mergeMyDynIncremental i

219− return (liftedResult0, liftedResult')

220−

221−-- | Map a function over the output of a 'DynamicWriterT'.

222−withDynamicWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m, MonadFix m)

223− => (w -> w')

224− -> DynamicWriterT t w m a

225− -> DynamicWriterT t w' m a

226−withDynamicWriterT f dw = do

227− (r, d) <- lift $ do

228− (r, d) <- runDynamicWriterT dw

229− let d' = fmap f d

230− return (r, d')

231− tellDyn d

232− return r

233−

234−instance Requester t m => Requester t (DynamicWriterT t w m) where

235− type Request (DynamicWriterT t w m) = Request m

236− type Response (DynamicWriterT t w m) = Response m

237− requesting = lift . requesting

238− requesting_ = lift . requesting_

239−

240−instance (MonadQuery t q m, Monad m) => MonadQuery t q (DynamicWriterT t w m) where

241− tellQueryIncremental = lift . tellQueryIncremental

242− askQueryResult = lift askQueryResult

243− queryIncremental = lift . queryIncremental

244−

245−instance EventWriter t w m => EventWriter t w (DynamicWriterT t v m) where

246− tellEvent = lift . tellEvent

src/Reflex/DynamicWriter/Class.hsdeleted−28

@@ -1,28 +0,0 @@

1−-- | This module defines the 'DynamicWriter' class.

2−{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE CPP #-}

4−{-# LANGUAGE FlexibleInstances #-}

5−{-# LANGUAGE FunctionalDependencies #-}

6−{-# LANGUAGE UndecidableInstances #-}

7−#ifdef USE_REFLEX_OPTIMIZER

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

9−#endif

10−module Reflex.DynamicWriter.Class

11− ( MonadDynamicWriter

12− , DynamicWriter(..)

13− ) where

14−

15−import Control.Monad.Reader (ReaderT, lift)

16−import Reflex.Class (Dynamic)

17−

18−{-# DEPRECATED MonadDynamicWriter "Use 'DynamicWriter' instead" #-}

19−-- | Type synonym for 'DynamicWriter'

20−type MonadDynamicWriter = DynamicWriter

21−

22−-- | 'MonadDynamicWriter' efficiently collects 'Dynamic' values using 'tellDyn'

23−-- and combines them monoidally to provide a 'Dynamic' result.

24−class (Monad m, Monoid w) => DynamicWriter t w m | m -> t w where

25− tellDyn :: Dynamic t w -> m ()

26−

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

28− tellDyn = lift . tellDyn

src/Reflex/EventWriter.hs+167−4

@@ -1,7 +1,170 @@

1+-- | This module provides 'EventWriterT', the standard implementation of

2+-- 'EventWriter'.

3+{-# LANGUAGE CPP #-}

4+{-# LANGUAGE ExistentialQuantification #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE FunctionalDependencies #-}

7+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8+{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE Rank2Types #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TypeFamilies #-}

12+{-# LANGUAGE UndecidableInstances #-}

13+#ifdef USE_REFLEX_OPTIMIZER

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

15+#endif

1module Reflex.EventWriter

16module Reflex.EventWriter

2− {-# DEPRECATED "Use 'Reflex.EventWriter.Class' and 'Reflex.EventWriter.Base' instead, or just import 'Reflex'" #-}

17+ ( EventWriterT (..)

3− ( module X

18+ , runEventWriterT

19+ , EventWriter (..)

20+ , runWithReplaceEventWriterTWith

21+ , sequenceDMapWithAdjustEventWriterTWith

4 ) where

22 ) where

6−import Reflex.EventWriter.Base as X

24+import Reflex.Class

25+import Reflex.Host.Class

26+import Reflex.PerformEvent.Class

27+import Reflex.PostBuild.Class

7−import Reflex.EventWriter.Class as X

28+import Reflex.Requester.Class

29+import Reflex.TriggerEvent.Class

30+

31+import Control.Monad.Exception

32+import Control.Monad.Identity

33+import Control.Monad.Reader

34+import Control.Monad.Ref

35+import Control.Monad.State.Strict

36+import Data.Dependent.Map (DMap)

37+import qualified Data.Dependent.Map as DMap

38+import Data.Foldable

39+import Data.Functor.Compose

40+import Data.Functor.Misc

41+import qualified Data.List.NonEmpty as NonEmpty

42+import Data.Map (Map)

43+import Data.Semigroup

44+import Data.Sequence

45+import Data.Some (Some)

46+import Data.Tuple

47+

48+-- | 'EventWriter' efficiently collects 'Event' values using 'tellEvent'

49+-- and combines them monoidally to provide an 'Event' result.

50+class (Monad m, Monoid w) => EventWriter t w m | m -> t w where

51+ tellEvent :: Event t w -> m ()

52+

53+-- | A basic implementation of 'EventWriter'.

54+newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (Seq (Event t w)) m a }

55+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)

56+

57+-- | Run a 'EventWriterT' action.

58+runEventWriterT :: (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)

59+runEventWriterT (EventWriterT a) = do

60+ (result, requests) <- runStateT a mempty

61+ return (result, mconcat $ toList requests)

62+

63+instance (Reflex t, Monad m, Monoid w) => EventWriter t w (EventWriterT t w m) where

64+ tellEvent w = EventWriterT $ modify (|> w)

65+

66+instance EventWriter t w m => EventWriter t w (ReaderT r m) where

67+ tellEvent = lift . tellEvent

68+

69+instance MonadTrans (EventWriterT t w) where

70+ lift = EventWriterT . lift

71+

72+instance MonadSample t m => MonadSample t (EventWriterT t w m) where

73+ sample = lift . sample

74+

75+instance MonadHold t m => MonadHold t (EventWriterT t w m) where

76+ hold v0 = lift . hold v0

77+ holdDyn v0 = lift . holdDyn v0

78+ holdIncremental v0 = lift . holdIncremental v0

79+

80+instance (Reflex t, MonadAdjust t m, MonadHold t m, Monoid w, Semigroup w) => MonadAdjust t (EventWriterT t w m) where

81+ runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'

82+ traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElements mergeMapIncremental

83+ traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElements mergeMapIncrementalWithMove

84+

85+instance Requester t m => Requester t (EventWriterT t w m) where

86+ type Request (EventWriterT t w m) = Request m

87+ type Response (EventWriterT t w m) = Response m

88+ withRequesting f = EventWriterT $ withRequesting $ unEventWriterT . f

89+

90+

91+-- | Given a function like 'runWithReplace' for the underlying monad, implement

92+-- 'runWithReplace' for 'EventWriterT'. This is necessary when the underlying

93+-- monad doesn't have a 'MonadAdjust' instance or to override the default

94+-- 'MonadAdjust' behavior.

95+runWithReplaceEventWriterTWith :: forall m t w a b. (Reflex t, MonadHold t m, Monoid w)

96+ => (forall a' b'. m a' -> Event t (m b') -> EventWriterT t w m (a', Event t b'))

97+ -> EventWriterT t w m a

98+ -> Event t (EventWriterT t w m b)

99+ -> EventWriterT t w m (a, Event t b)

100+runWithReplaceEventWriterTWith f a0 a' = do

101+ let g :: EventWriterT t w m c -> m (c, Seq (Event t w))

102+ g (EventWriterT r) = runStateT r mempty

103+ (result0, result') <- f (g a0) $ fmap g a'

104+ request <- holdDyn (fmapCheap (mconcat . NonEmpty.toList) $ mergeList $ toList $ snd result0) $ fmapCheap (fmapCheap (mconcat . NonEmpty.toList) . mergeList . toList . snd) result'

105+ -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)

106+ EventWriterT $ modify $ flip (|>) $ coincidence $ updated request

107+ EventWriterT $ modify $ flip (|>) $ switch $ current request

108+ return (fst result0, fmapCheap fst result')

109+

110+-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.

111+sequenceDMapWithAdjustEventWriterTWith :: forall t m p p' w k v v'. (Reflex t, MonadHold t m, Monoid w, Semigroup w, Patch (p' (Some k) (Event t w)), PatchTarget (p' (Some k) (Event t w)) ~ Map (Some k) (Event t w))

112+ => ( (forall a. k a -> v a -> m (Compose ((,) (Seq (Event t w))) v' a))

113+ -> DMap k v

114+ -> Event t (p k v)

115+ -> EventWriterT t w m (DMap k (Compose ((,) (Seq (Event t w))) v'), Event t (p k (Compose ((,) (Seq (Event t w))) v')))

116+ )

117+ -> ((forall a. Compose ((,) (Seq (Event t w))) v' a -> v' a) -> p k (Compose ((,) (Seq (Event t w))) v') -> p k v')

118+ -> ((forall a. Compose ((,) (Seq (Event t w))) v' a -> Event t w) -> p k (Compose ((,) (Seq (Event t w))) v') -> p' (Some k) (Event t w))

119+ -> (p' (Some k) (Event t w) -> [Event t w])

120+ -> (Incremental t (p' (Some k) (Event t w)) -> Event t (Map (Some k) w))

121+ -> (forall a. k a -> v a -> EventWriterT t w m (v' a))

122+ -> DMap k v

123+ -> Event t (p k v)

124+ -> EventWriterT t w m (DMap k v', Event t (p k v'))

125+sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do

126+ let f' :: forall a. k a -> v a -> m (Compose ((,) (Seq (Event t w))) v' a)

127+ f' k v = Compose . swap <$> runStateT (unEventWriterT $ f k v) mempty

128+ (children0, children') <- base f' dm0 dm'

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

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

131+ requests0 :: Map (Some k) (Event t w)

132+ requests0 = weakenDMapWith (mconcat . toList . fst . getCompose) children0

133+ requests' :: Event t (p' (Some k) (Event t w))

134+ requests' = fforCheap children' $ weakenPatchWith $ mconcat . toList . fst . getCompose

135+ childRequestMap :: Incremental t (p' (Some k) (Event t w)) <- holdIncremental requests0 requests'

136+ -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)

137+ EventWriterT $ modify $ flip (|>) $ coincidence $ fforCheap requests' $ \p -> mconcat $ patchNewElements p --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'

138+ EventWriterT $ modify $ flip (|>) $ fold <$> mergePatchIncremental childRequestMap

139+ return (result0, result')

140+

141+instance PerformEvent t m => PerformEvent t (EventWriterT t w m) where

142+ type Performable (EventWriterT t w m) = Performable m

143+ performEvent_ = lift . performEvent_

144+ performEvent = lift . performEvent

145+

146+instance PostBuild t m => PostBuild t (EventWriterT t w m) where

147+ getPostBuild = lift getPostBuild

148+

149+instance TriggerEvent t m => TriggerEvent t (EventWriterT t w m) where

150+ newTriggerEvent = lift newTriggerEvent

151+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

152+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

153+

154+instance MonadReader r m => MonadReader r (EventWriterT t w m) where

155+ ask = lift ask

156+ local f (EventWriterT a) = EventWriterT $ mapStateT (local f) a

157+ reader = lift . reader

158+

159+instance MonadRef m => MonadRef (EventWriterT t w m) where

160+ type Ref (EventWriterT t w m) = Ref m

161+ newRef = lift . newRef

162+ readRef = lift . readRef

163+ writeRef r = lift . writeRef r

164+

165+instance MonadAtomicRef m => MonadAtomicRef (EventWriterT t w m) where

166+ atomicModifyRef r = lift . atomicModifyRef r

167+

168+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (EventWriterT t w m) where

169+ newEventWithTrigger = lift . newEventWithTrigger

170+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

src/Reflex/EventWriter/Base.hsdeleted−317

@@ -1,317 +0,0 @@

1−-- | This module provides 'EventWriterT', the standard implementation of

2−-- 'EventWriter'.

3−{-# LANGUAGE CPP #-}

4−{-# LANGUAGE ExistentialQuantification #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7−{-# LANGUAGE MultiParamTypeClasses #-}

8−{-# LANGUAGE Rank2Types #-}

9−{-# LANGUAGE ScopedTypeVariables #-}

10−{-# LANGUAGE TypeFamilies #-}

11−{-# LANGUAGE TypeOperators #-}

12−{-# LANGUAGE UndecidableInstances #-}

13−#ifdef USE_REFLEX_OPTIMIZER

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

15−#endif

16−module Reflex.EventWriter.Base

17− ( EventWriterT (..)

18− , runEventWriterT

19− , runWithReplaceEventWriterTWith

20− , sequenceDMapWithAdjustEventWriterTWith

21− , mapEventWriterT

22− , withEventWriterT

23− ) where

24−

25−import Reflex.Adjustable.Class

26−import Reflex.Class

27−import Reflex.EventWriter.Class (EventWriter, tellEvent)

28−import Reflex.DynamicWriter.Class (DynamicWriter, tellDyn)

29−import Reflex.Host.Class

30−import Reflex.PerformEvent.Class

31−import Reflex.PostBuild.Class

32−import Reflex.Query.Class

33−import Reflex.Requester.Class

34−import Reflex.TriggerEvent.Class

35−

36−import Control.Monad.Exception

37−import Control.Monad.Identity

38−import Control.Monad.Morph

39−import Control.Monad.Primitive

40−import Control.Monad.Reader

41−import Control.Monad.Ref

42−import Control.Monad.State.Strict

43−import Data.Dependent.Map (DMap)

44−import qualified Data.Dependent.Map as DMap

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

46−import Data.Functor.Compose

47−import Data.Functor.Misc

48−import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))

49−import Data.IntMap.Strict (IntMap)

50−import qualified Data.IntMap.Strict as IntMap

51−import Data.List.NonEmpty (NonEmpty (..))

52−import Data.Map (Map)

53−import qualified Data.Map as Map

54−import Data.Semigroup

55−import Data.Some (Some)

56−import Data.Tuple

57−import Data.Type.Equality

58−

59−import Unsafe.Coerce

60−

61−{-# DEPRECATED TellId "Do not construct this directly; use tellId instead" #-}

62−newtype TellId w x

63− = TellId Int -- ^ WARNING: Do not construct this directly; use 'tellId' instead

64− deriving (Show, Eq, Ord, Enum)

65−

66−tellId :: Int -> TellId w w

67−tellId = TellId

68−{-# INLINE tellId #-}

69−

70−tellIdRefl :: TellId w x -> w :~: x

71−tellIdRefl _ = unsafeCoerce Refl

72−

73−withTellIdRefl :: TellId w x -> (w ~ x => r) -> r

74−withTellIdRefl tid r = case tellIdRefl tid of

75− Refl -> r

76−

77−instance GEq (TellId w) where

78− a `geq` b =

79− withTellIdRefl a $

80− withTellIdRefl b $

81− if a == b

82− then Just Refl

83− else Nothing

84−

85−instance GCompare (TellId w) where

86− a `gcompare` b =

87− withTellIdRefl a $

88− withTellIdRefl b $

89− case a `compare` b of

90− LT -> GLT

91− EQ -> GEQ

92− GT -> GGT

93−

94−data EventWriterState t w = EventWriterState

95− { _eventWriterState_nextId :: {-# UNPACK #-} !Int -- Always negative (and decreasing over time)

96− , _eventWriterState_told :: ![DSum (TellId w) (Event t)] -- In increasing order

97− }

98−

99−-- | A basic implementation of 'EventWriter'.

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

101− deriving

102− ( Functor

103− , Applicative

104− , Monad

105− , MonadTrans

106− , MFunctor

107− , MonadFix

108− , MonadIO

109− , MonadException

110− , MonadAsyncException

111− )

112−

113−-- | Run a 'EventWriterT' action.

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

115−runEventWriterT (EventWriterT a) = do

116− (result, requests) <- runStateT a $ EventWriterState (-1) []

117− let combineResults :: DMap (TellId w) Identity -> w

118− combineResults = sconcat

119− . (\(h : t) -> h :| t) -- Unconditional; 'merge' guarantees that it will only fire with non-empty DMaps

120− . DMap.foldlWithKey (\vs tid (Identity v) -> withTellIdRefl tid $ v : vs) [] -- This is where we finally reverse the DMap to get things in the correct order

121− return (result, fmap combineResults $ merge $ DMap.fromDistinctAscList $ _eventWriterState_told requests) --TODO: We can probably make this fromDistinctAscList more efficient by knowing the length in advance, but this will require exposing internals of DMap; also converting it to use a strict list might help

122−

123−instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m) where

124− tellEvent w = EventWriterT $ modify $ \old ->

125− let myId = _eventWriterState_nextId old

126− in EventWriterState

127− { _eventWriterState_nextId = pred myId

128− , _eventWriterState_told = (tellId myId :=> w) : _eventWriterState_told old

129− }

130−

131−instance MonadSample t m => MonadSample t (EventWriterT t w m) where

132− sample = lift . sample

133−

134−instance MonadHold t m => MonadHold t (EventWriterT t w m) where

135− {-# INLINABLE hold #-}

136− hold v0 = lift . hold v0

137− {-# INLINABLE holdDyn #-}

138− holdDyn v0 = lift . holdDyn v0

139− {-# INLINABLE holdIncremental #-}

140− holdIncremental v0 = lift . holdIncremental v0

141− {-# INLINABLE buildDynamic #-}

142− buildDynamic a0 = lift . buildDynamic a0

143− {-# INLINABLE headE #-}

144− headE = lift . headE

145− {-# INLINABLE now #-}

146− now = lift now

147−

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

149− runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'

150− traverseIntMapWithKeyWithAdjust = sequenceIntMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') mergeIntIncremental coincidencePatchIntMap

151− traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith mergeMapIncremental coincidencePatchMap

152− traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith mergeMapIncrementalWithMove coincidencePatchMapWithMove

153−

154−instance Requester t m => Requester t (EventWriterT t w m) where

155− type Request (EventWriterT t w m) = Request m

156− type Response (EventWriterT t w m) = Response m

157− requesting = lift . requesting

158− requesting_ = lift . requesting_

159−

160−-- | Given a function like 'runWithReplace' for the underlying monad, implement

161−-- 'runWithReplace' for 'EventWriterT'. This is necessary when the underlying

162−-- monad doesn't have a 'Adjustable' instance or to override the default

163−-- 'Adjustable' behavior.

164−runWithReplaceEventWriterTWith :: forall m t w a b. (Reflex t, MonadHold t m, Semigroup w)

165− => (forall a' b'. m a' -> Event t (m b') -> EventWriterT t w m (a', Event t b'))

166− -> EventWriterT t w m a

167− -> Event t (EventWriterT t w m b)

168− -> EventWriterT t w m (a, Event t b)

169−runWithReplaceEventWriterTWith f a0 a' = do

170− (result0, result') <- f (runEventWriterT a0) $ fmapCheap runEventWriterT a'

171− tellEvent =<< switchHoldPromptOnly (snd result0) (fmapCheap snd result')

172− return (fst result0, fmapCheap fst result')

173−

174−-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceIntMapWithAdjust'.

175−sequenceIntMapWithAdjustEventWriterTWith

176− :: forall t m p w v v'

177− . ( Reflex t

178− , MonadHold t m

179− , Semigroup w

180− , Functor p

181− , Patch (p (Event t w))

182− , PatchTarget (p (Event t w)) ~ IntMap (Event t w)

183− , Patch (p w)

184− , PatchTarget (p w) ~ IntMap w

185− )

186− => ( (IntMap.Key -> v -> m (Event t w, v'))

187− -> IntMap v

188− -> Event t (p v)

189− -> EventWriterT t w m (IntMap (Event t w, v'), Event t (p (Event t w, v')))

190− )

191− -> (Incremental t (p (Event t w)) -> Event t (PatchTarget (p w)))

192− -> (Event t (p (Event t w)) -> Event t (p w))

193− -> (IntMap.Key -> v -> EventWriterT t w m v')

194− -> IntMap v

195− -> Event t (p v)

196− -> EventWriterT t w m (IntMap v', Event t (p v'))

197−sequenceIntMapWithAdjustEventWriterTWith base mergePatchIncremental coincidencePatch f dm0 dm' = do

198− let f' :: IntMap.Key -> v -> m (Event t w, v')

199− f' k v = swap <$> runEventWriterT (f k v)

200− (children0, children') <- base f' dm0 dm'

201− let result0 = fmap snd children0

202− result' = fmapCheap (fmap snd) children'

203− requests0 :: IntMap (Event t w)

204− requests0 = fmap fst children0

205− requests' :: Event t (p (Event t w))

206− requests' = fmapCheap (fmap fst) children'

207− e <- switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch requests0 requests'

208− tellEvent $ fforMaybeCheap e $ \m ->

209− case IntMap.elems m of

210− [] -> Nothing

211− h : t -> Just $ sconcat $ h :| t

212− return (result0, result')

213−

214−-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.

215−sequenceDMapWithAdjustEventWriterTWith

216− :: forall t m p p' w k v v'

217− . ( Reflex t

218− , MonadHold t m

219− , Semigroup w

220− , Patch (p' (Some k) (Event t w))

221− , PatchTarget (p' (Some k) (Event t w)) ~ Map (Some k) (Event t w)

222− , GCompare k

223− , Patch (p' (Some k) w)

224− , PatchTarget (p' (Some k) w) ~ Map (Some k) w

225− )

226− => ( (forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a))

227− -> DMap k v

228− -> Event t (p k v)

229− -> EventWriterT t w m (DMap k (Compose ((,) (Event t w)) v'), Event t (p k (Compose ((,) (Event t w)) v')))

230− )

231− -> ((forall a. Compose ((,) (Event t w)) v' a -> v' a) -> p k (Compose ((,) (Event t w)) v') -> p k v')

232− -> ((forall a. Compose ((,) (Event t w)) v' a -> Event t w) -> p k (Compose ((,) (Event t w)) v') -> p' (Some k) (Event t w))

233− -> (Incremental t (p' (Some k) (Event t w)) -> Event t (PatchTarget (p' (Some k) w)))

234− -> (Event t (p' (Some k) (Event t w)) -> Event t (p' (Some k) w))

235− -> (forall a. k a -> v a -> EventWriterT t w m (v' a))

236− -> DMap k v

237− -> Event t (p k v)

238− -> EventWriterT t w m (DMap k v', Event t (p k v'))

239−sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith mergePatchIncremental coincidencePatch f dm0 dm' = do

240− let f' :: forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a)

241− f' k v = Compose . swap <$> runEventWriterT (f k v)

242− (children0, children') <- base f' dm0 dm'

243− let result0 = DMap.map (snd . getCompose) children0

244− result' = fforCheap children' $ mapPatch $ snd . getCompose

245− requests0 :: Map (Some k) (Event t w)

246− requests0 = weakenDMapWith (fst . getCompose) children0

247− requests' :: Event t (p' (Some k) (Event t w))

248− requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose

249− e <- switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch requests0 requests'

250− tellEvent $ fforMaybeCheap e $ \m ->

251− case Map.elems m of

252− [] -> Nothing

253− h : t -> Just $ sconcat $ h :| t

254− return (result0, result')

255−

256−instance PerformEvent t m => PerformEvent t (EventWriterT t w m) where

257− type Performable (EventWriterT t w m) = Performable m

258− performEvent_ = lift . performEvent_

259− performEvent = lift . performEvent

260−

261−instance PostBuild t m => PostBuild t (EventWriterT t w m) where

262− getPostBuild = lift getPostBuild

263−

264−instance TriggerEvent t m => TriggerEvent t (EventWriterT t w m) where

265− newTriggerEvent = lift newTriggerEvent

266− newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

267− newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

268−

269−instance MonadReader r m => MonadReader r (EventWriterT t w m) where

270− ask = lift ask

271− local f (EventWriterT a) = EventWriterT $ mapStateT (local f) a

272− reader = lift . reader

273−

274−instance MonadRef m => MonadRef (EventWriterT t w m) where

275− type Ref (EventWriterT t w m) = Ref m

276− newRef = lift . newRef

277− readRef = lift . readRef

278− writeRef r = lift . writeRef r

279−

280−instance MonadAtomicRef m => MonadAtomicRef (EventWriterT t w m) where

281− atomicModifyRef r = lift . atomicModifyRef r

282−

283−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (EventWriterT t w m) where

284− newEventWithTrigger = lift . newEventWithTrigger

285− newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

286−

287−instance (MonadQuery t q m, Monad m) => MonadQuery t q (EventWriterT t w m) where

288− tellQueryIncremental = lift . tellQueryIncremental

289− askQueryResult = lift askQueryResult

290− queryIncremental = lift . queryIncremental

291−

292−instance DynamicWriter t w m => DynamicWriter t w (EventWriterT t v m) where

293− tellDyn = lift . tellDyn

294−

295−instance PrimMonad m => PrimMonad (EventWriterT t w m) where

296− type PrimState (EventWriterT t w m) = PrimState m

297− primitive = lift . primitive

298−

299−-- | Map a function over the output of a 'EventWriterT'.

300−withEventWriterT :: (Semigroup w, Semigroup w', Reflex t, MonadHold t m)

301− => (w -> w')

302− -> EventWriterT t w m a

303− -> EventWriterT t w' m a

304−withEventWriterT f ew = do

305− (r, e) <- lift $ do

306− (r, e) <- runEventWriterT ew

307− let e' = fmap f e

308− return (r, e')

309− tellEvent e

310− return r

311−

312−-- | Change the monad underlying an EventWriterT

313−mapEventWriterT

314− :: (forall x. m x -> n x)

315− -> EventWriterT t w m a

316− -> EventWriterT t w n a

317−mapEventWriterT f (EventWriterT a) = EventWriterT $ mapStateT f a

src/Reflex/EventWriter/Class.hsdeleted−26

@@ -1,26 +0,0 @@

1−-- | This module defines the 'EventWriter' class.

2−{-# LANGUAGE CPP #-}

3−{-# LANGUAGE FlexibleInstances #-}

4−{-# LANGUAGE FunctionalDependencies #-}

5−{-# LANGUAGE UndecidableInstances #-}

6−#ifdef USE_REFLEX_OPTIMIZER

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

8−#endif

9−module Reflex.EventWriter.Class

10− ( EventWriter (..)

11− ) where

12−

13−import Control.Monad.Reader (ReaderT, lift)

14−import Data.Semigroup (Semigroup)

15−

16−import Reflex.Class (Event)

17−

18−

19−-- | 'EventWriter' efficiently collects 'Event' values using 'tellEvent'

20−-- and combines them via 'Semigroup' to provide an 'Event' result.

21−class (Monad m, Semigroup w) => EventWriter t w m | m -> t w where

22− tellEvent :: Event t w -> m ()

23−

24−

25−instance EventWriter t w m => EventWriter t w (ReaderT r m) where

26− tellEvent = lift . tellEvent

src/Reflex/FastWeak.hsdeleted−210

@@ -1,210 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE LambdaCase #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

4−#if GHCJS_FAST_WEAK

5−{-# LANGUAGE ForeignFunctionInterface #-}

6−{-# LANGUAGE JavaScriptFFI #-}

7−#endif

8−

9−-- |

10−-- Module:

11−-- Reflex.FastWeak

12−-- Description:

13−-- 'FastWeak' is a weak pointer to some value, and 'FastWeakTicket' ensures the value

14−-- referred to by a 'FastWeak' stays live while the ticket is held (live).

15−--

16−-- On GHC or GHCJS when not built with the @fast-weak@ cabal flag, 'FastWeak' is a wrapper

17−-- around the simple version of 'System.Mem.Weak.Weak' where the key and value are the same.

18−--

19−-- On GHCJS when built with the @fast-weak@ cabal flag, 'FastWeak' is implemented directly

20−-- in JS using @h$FastWeak@ and @h$FastWeakTicket@ which are a nonstandard part of the GHCJS RTS.

21−module Reflex.FastWeak

22− ( FastWeakTicket

23− , FastWeak

24− , mkFastWeakTicket

25− , getFastWeakTicketValue

26− , getFastWeakTicketWeak

27− , getFastWeakValue

28− , getFastWeakTicket

29− , emptyFastWeak

30−#ifdef GHCJS_FAST_WEAK

31− --TODO: Move these elsewhere

32− , unsafeFromRawJSVal

33− , unsafeToRawJSVal

34− , js_isNull

35−#endif

36− ) where

37−

38−import GHC.Exts (Any)

39−import Unsafe.Coerce

40−

41−#ifdef GHCJS_FAST_WEAK

42−import GHCJS.Types

43−#else

44−import Control.Exception (evaluate)

45−import System.IO.Unsafe

46−import System.Mem.Weak

47−#endif

48−

49−

50−#ifdef GHCJS_FAST_WEAK

51−-- | A 'FastWeak' which has been promoted to a strong reference. 'getFastWeakTicketValue'

52−-- can be used to get the referred to value without fear of @Nothing,

53−-- and 'getFastWeakTicketWeak' can be used to get the weak version.

54−--

55−-- Implemented by way of special support in the GHCJS RTS, @h$FastWeakTicket@.

56−newtype FastWeakTicket a = FastWeakTicket JSVal

57−

58−-- | A reference to some value which can be garbage collected if there are only

59−-- weak references to the value left.

60−--

61−-- 'getFastWeakValue' can be used to try and obtain a strong reference to the value.

62−--

63−-- The value in a @FastWeak@ can also be kept alive by obtaining a 'FastWeakTicket' using

64−-- 'getFastWeakTicket' if the value hasn't been collected yet.

65−--

66−-- Implemented by way of special support in the GHCJS RTS, @h$FastWeak@.

67−newtype FastWeak a = FastWeak JSVal

68−

69−-- Just designed to mirror JSVal, so that we can unsafeCoerce between the two

70−data Val a = Val { unVal :: a }

71−

72−-- | Coerce a JSVal that represents the heap object of a value of type @a@ into a value of type @a@

73−unsafeFromRawJSVal :: JSVal -> a

74−unsafeFromRawJSVal v = unVal (unsafeCoerce v)

75−

76−-- | Coerce a heap object of type @a@ into a 'JSVal' which represents that object.

77−unsafeToRawJSVal :: a -> JSVal

78−unsafeToRawJSVal v = unsafeCoerce (Val v)

79−#else

80−-- | A 'FastWeak' which has been promoted to a strong reference. 'getFastWeakTicketValue'

81−-- can be used to get the referred to value without fear of @Nothing@,

82−-- and 'getFastWeakTicketWeak' can be used to get the weak version.

83−data FastWeakTicket a = FastWeakTicket

84− { _fastWeakTicket_val :: !a

85− , _fastWeakTicket_weak :: {-# UNPACK #-} !(Weak a)

86− }

87−

88−-- | A reference to some value which can be garbage collected if there are only weak references to the value left.

89−--

90−-- 'getFastWeakValue' can be used to try and obtain a strong reference to the value.

91−--

92−-- The value in a @FastWeak@ can also be kept alive by obtaining a 'FastWeakTicket' using 'getFastWeakTicket'

93−-- if the value hasn't been collected yet.

94−--

95−-- Synonymous with 'Weak'.

96−type FastWeak a = Weak a

97−#endif

98−

99−-- | Return the @a@ kept alive by the given 'FastWeakTicket'.

100−--

101−-- This needs to be in IO so we know that we've relinquished the ticket.

102−getFastWeakTicketValue :: FastWeakTicket a -> IO a

103−#ifdef GHCJS_FAST_WEAK

104−getFastWeakTicketValue t = do

105− v <- js_ticketVal t

106− return $ unsafeFromRawJSVal v

107−

108−foreign import javascript unsafe "$r = $1.val;" js_ticketVal :: FastWeakTicket a -> IO JSVal

109−#else

110−getFastWeakTicketValue = return . _fastWeakTicket_val

111−#endif

112−

113−-- | Get the value referred to by a 'FastWeak' if it hasn't yet been collected,

114−-- or @Nothing@ if it has been collected.

115−getFastWeakValue :: FastWeak a -> IO (Maybe a)

116−#ifdef GHCJS_FAST_WEAK

117−getFastWeakValue w = do

118− r <- js_weakVal w

119− case js_isNull r of

120− True -> return Nothing

121− False -> return $ Just $ unsafeFromRawJSVal r

122−

123−foreign import javascript unsafe "$1 === null" js_isNull :: JSVal -> Bool

124−

125−foreign import javascript unsafe "$r = ($1.ticket === null) ? null : $1.ticket.val;" js_weakVal :: FastWeak a -> IO JSVal

126−#else

127−getFastWeakValue = deRefWeak

128−#endif

129−

130−-- | Try to create a 'FastWeakTicket' for the given 'FastWeak' which will ensure the value referred

131−-- remains alive. Returns @Just@ if the value hasn't been collected

132−-- and a ticket can therefore be obtained, @Nothing@ if it's been collected.

133−getFastWeakTicket :: forall a. FastWeak a -> IO (Maybe (FastWeakTicket a))

134−#ifdef GHCJS_FAST_WEAK

135−getFastWeakTicket w = do

136− r <- js_weakTicket w

137− case js_isNull r of

138− True -> return Nothing

139− False -> return $ Just $ FastWeakTicket r

140−

141−foreign import javascript unsafe "$r = $1.ticket;" js_weakTicket :: FastWeak a -> IO JSVal

142−#else

143−getFastWeakTicket w = do

144− deRefWeak w >>= \case

145− Nothing -> return Nothing

146− Just v -> return $ Just $ FastWeakTicket

147− { _fastWeakTicket_val = v

148− , _fastWeakTicket_weak = w

149− }

150−#endif

151−

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

153−-- which can be obtained with 'getFastWeakTicketValue'.

154−--

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

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

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

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

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

160−--

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

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

163−{-# NOINLINE mkFastWeakTicket #-}

164−mkFastWeakTicket :: a -> IO (FastWeakTicket a)

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

166−-- associated FastWeak to actually be weak

167−#ifdef GHCJS_FAST_WEAK

168−mkFastWeakTicket v = js_fastWeakTicket (unsafeToRawJSVal v)

169−

170−foreign import javascript unsafe "$r = new h$FastWeakTicket($1);" js_fastWeakTicket :: JSVal -> IO (FastWeakTicket a)

171−#else

172−mkFastWeakTicket v = do

173− v' <- evaluate v

174− w <- mkWeakPtr v' Nothing

175− return $ FastWeakTicket

176− { _fastWeakTicket_val = v'

177− , _fastWeakTicket_weak = w

178− }

179−#endif

180−

181−-- | Demote a 'FastWeakTicket'; which ensures the value is alive, to a 'FastWeak' which doesn't.

182−-- Note that unless the ticket for the same 'FastWeak' is held in some other way

183−-- the value might be collected immediately.

184−getFastWeakTicketWeak :: FastWeakTicket a -> IO (FastWeak a)

185−-- Needs IO so that it can force the value - otherwise, could end up with a reference to the Ticket, which would retain the value

186−#ifdef GHCJS_FAST_WEAK

187−foreign import javascript unsafe "$r = $1.weak;" getFastWeakTicketWeak' :: FastWeakTicket a -> IO (FastWeak a)

188−{-# INLINE getFastWeakTicketWeak #-}

189−getFastWeakTicketWeak = getFastWeakTicketWeak'

190−#else

191−getFastWeakTicketWeak = return . _fastWeakTicket_weak

192−#endif

193−

194−-- | A weak reference that is always empty

195−emptyFastWeak :: FastWeak a

196−emptyFastWeak = unsafeCoerce w

197− where w :: FastWeak Any

198−#ifdef GHCJS_FAST_WEAK

199− w = js_emptyWeak

200−#else

201− w = unsafePerformIO $ do

202− w' <- mkWeakPtr undefined Nothing

203− finalize w'

204− return w'

205−#endif

206−{-# NOINLINE emptyFastWeak #-}

207−

208−#ifdef GHCJS_FAST_WEAK

209−foreign import javascript unsafe "$r = new h$FastWeak(null);" js_emptyWeak :: FastWeak Any

210−#endif

src/Reflex/FunctorMaybe.hs+16−34

@@ -1,47 +1,29 @@

1−{-# LANGUAGE CPP #-}

2−#if MIN_VERSION_base(4,9,0)

3−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4−{-# LANGUAGE StandaloneDeriving #-}

5−#endif

6−

7−-- |

8−-- Module:

9−-- Reflex.FunctorMaybe

10−-- Description:

11−-- This module defines the FunctorMaybe class, which extends Functors with the

1+-- | This module defines the FunctorMaybe class, which extends Functors with the

12−-- ability to delete values.

2+-- ability to delete values.

13module Reflex.FunctorMaybe

3module Reflex.FunctorMaybe

14 ( FunctorMaybe (..)

4 ( FunctorMaybe (..)

15 ) where

5 ) where

17−import Data.IntMap (IntMap)

7+import Data.Maybe

18−import Data.Map (Map)

19−#if MIN_VERSION_base(4,9,0)

20−import Data.Semigroup (Option(..))

21−#endif

22−import Data.Witherable

24--TODO: See if there's a better class in the standard libraries already

9--TODO: See if there's a better class in the standard libraries already

26-- | A class for values that combines filtering and mapping using 'Maybe'.

11-- | A class for values that combines filtering and mapping using 'Maybe'.

27−-- Morally, @'FunctorMaybe' ~ KleisliFunctor 'Maybe'@.

12+-- Morally, @'FunctorMaybe' ~ KleisliFunctor 'Maybe'@. Also similar is the

28−{-# DEPRECATED FunctorMaybe "Use 'Filterable' from Data.Witherable instead" #-}

13+-- @Witherable@ typeclass, but it requires @Foldable f@ and @Traverable f@,

14+-- and e.g. 'Event' is instance of neither.

15+--

16+-- A definition of 'fmapMaybe' must satisfy the following laws:

17+--

18+-- [/identity/]

19+-- @'fmapMaybe' 'Just' ≡ 'id'@

20+--

21+-- [/composition/]

22+-- @'fmapMaybe' (f <=< g) ≡ 'fmapMaybe' f . 'fmapMaybe' g@

29class FunctorMaybe f where

23class FunctorMaybe f where

30 -- | Combined mapping and filtering function.

24 -- | Combined mapping and filtering function.

31 fmapMaybe :: (a -> Maybe b) -> f a -> f b

25 fmapMaybe :: (a -> Maybe b) -> f a -> f b

33−instance FunctorMaybe Maybe where

34− fmapMaybe = mapMaybe

27+-- | @fmapMaybe f = catMaybes . fmap f@

35−

36−#if MIN_VERSION_base(4,9,0)

37−deriving instance FunctorMaybe Option

38−#endif

39−

40instance FunctorMaybe [] where

28instance FunctorMaybe [] where

41− fmapMaybe = mapMaybe

29+ fmapMaybe f = catMaybes . fmap f

42−

43−instance FunctorMaybe (Map k) where

44− fmapMaybe = mapMaybe

45−

46−instance FunctorMaybe IntMap where

47− fmapMaybe = mapMaybe

src/Reflex/Host/Class.hs+26−6

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

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FunctionalDependencies #-}

6{-# LANGUAGE GADTs #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE RankNTypes #-}

8{-# LANGUAGE RankNTypes #-}

8{-# LANGUAGE RoleAnnotations #-}

9{-# LANGUAGE RoleAnnotations #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE ScopedTypeVariables #-}

@@ -29,19 +30,38 @@ module Reflex.Host.Class

30import Reflex.Class

31import Reflex.Class

33+import Control.Applicative

34+import Control.Monad

32import Control.Monad.Fix

35import Control.Monad.Fix

33import Control.Monad.Identity

36import Control.Monad.Identity

34import Control.Monad.Ref

37import Control.Monad.Ref

35import Control.Monad.Trans

38import Control.Monad.Trans

36−import Control.Monad.Trans.Cont (ContT)

39+import Control.Monad.Trans.Cont (ContT ())

37−import Control.Monad.Trans.Except (ExceptT)

40+import Control.Monad.Trans.Except (ExceptT ())

38−import Control.Monad.Trans.Reader (ReaderT)

41+import Control.Monad.Trans.Reader (ReaderT ())

39−import Control.Monad.Trans.RWS (RWST)

42+import Control.Monad.Trans.RWS (RWST ())

40−import Control.Monad.Trans.State (StateT)

43+import Control.Monad.Trans.State (StateT ())

41import qualified Control.Monad.Trans.State.Strict as Strict

44import qualified Control.Monad.Trans.State.Strict as Strict

42−import Control.Monad.Trans.Writer (WriterT)

45+import Control.Monad.Trans.Writer (WriterT ())

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

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

44import Data.GADT.Compare

47import Data.GADT.Compare

48+import Data.Monoid

49+

50+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

51+import Control.Monad.Primitive (touch)

52+import Data.IORef

53+import Reflex.Spider.Internal (EventM (..), HasSpiderTimeline, RootTrigger, SpiderEventHandle (..),

54+ SpiderHost (..), SpiderHostFrame (..), Subscriber (..), newEventWithTriggerIO,

55+ newFanEventWithTriggerIO, run, runFrame, scheduleClear, subscribe)

56+import qualified Reflex.Spider.Internal

57+#endif

58+

59+-- Note: this import must come last to silence warnings from AMP

60+import Prelude hiding (foldl, mapM, mapM_, sequence, sequence_)

61+

62+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

63+#include "../Spider/SpiderTimelineHost.include.hs"

64+#endif

46-- | Framework implementation support class for the reflex implementation

66-- | Framework implementation support class for the reflex implementation

47-- represented by @t@.

67-- represented by @t@.

src/Reflex/Host/Headless.hsdeleted−128

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

1−{-# LANGUAGE LambdaCase #-}

2−{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE RankNTypes #-}

4−{-# LANGUAGE TypeFamilies #-}

5−{-# LANGUAGE ConstraintKinds #-}

6−

7−module Reflex.Host.Headless where

8−

9−import Control.Concurrent.Chan (newChan, readChan)

10−import Control.Monad (unless)

11−import Control.Monad.Fix (MonadFix, fix)

12−import Control.Monad.IO.Class (MonadIO, liftIO)

13−import Control.Monad.Primitive (PrimMonad)

14−import Control.Monad.Ref (MonadRef, Ref, readRef)

15−import Data.Dependent.Sum (DSum (..), (==>))

16−import Data.Foldable (for_)

17−import Data.Functor.Identity (Identity(..))

18−import Data.IORef (IORef, readIORef)

19−import Data.Maybe (catMaybes, fromMaybe)

20−import Data.Traversable (for)

21−

22−import Reflex

23−import Reflex.Host.Class

24−

25−type MonadHeadlessApp t m =

26− ( Adjustable t m

27− , MonadFix m

28− , MonadHold t m

29− , MonadIO (HostFrame t)

30− , MonadIO (Performable m)

31− , MonadIO m

32− , MonadRef (HostFrame t)

33− , NotReady t m

34− , PerformEvent t m

35− , PostBuild t m

36− , PrimMonad (HostFrame t)

37− , Ref (HostFrame t) ~ IORef

38− , Ref m ~ IORef

39− , Reflex t

40− , ReflexHost t

41− , TriggerEvent t m

42− )

43−

44−-- | Run a headless FRP network. Inside the action, you will most probably use

45−-- the capabilities provided by the 'TriggerEvent' and 'PerformEvent' type

46−-- classes to interface the FRP network with the outside world. Useful for

47−-- testing. Each headless network runs on its own spider timeline.

48−runHeadlessApp

49− :: (forall t m. MonadHeadlessApp t m => m (Event t ()))

50− -- ^ The action to be run in the headless FRP network. The FRP network is

51− -- closed at the first occurrence of the resulting 'Event'.

52− -> IO ()

53−runHeadlessApp guest =

54− -- We are using the 'Spider' implementation of reflex. Running the host

55− -- allows us to take actions on the FRP timeline.

56− withSpiderTimeline $ runSpiderHostForTimeline $ do

57− -- Create the "post-build" event and associated trigger. This event fires

58− -- once, when the application starts.

59− (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

60− -- Create a queue to which we will write 'Event's that need to be

61− -- processed.

62− events <- liftIO newChan

63− -- Run the "guest" application, providing the appropriate context. We'll

64− -- pure the result of the action, and a 'FireCommand' that will be used to

65− -- trigger events.

66− (result, fc@(FireCommand fire)) <- do

67− hostPerformEventT $ -- Allows the guest app to run

68− -- 'performEvent', so that actions

69− -- (e.g., IO actions) can be run when

70− -- 'Event's fire.

71−

72− flip runPostBuildT postBuild $ -- Allows the guest app to access to

73− -- a "post-build" 'Event'

74−

75− flip runTriggerEventT events $ -- Allows the guest app to create new

76− -- events and triggers and write

77− -- those triggers to a channel from

78− -- which they will be read and

79− -- processed.

80− guest

81−

82− -- Read the trigger reference for the post-build event. This will be

83− -- 'Nothing' if the guest application hasn't subscribed to this event.

84− mPostBuildTrigger <- readRef postBuildTriggerRef

85−

86− -- Subscribe to an 'Event' of that the guest application can use to

87− -- request application shutdown. We'll check whether this 'Event' is firing

88− -- to determine whether to terminate.

89− shutdown <- subscribeEvent result

90−

91− -- When there is a subscriber to the post-build event, fire the event.

92− soa <- for mPostBuildTrigger $ \postBuildTrigger ->

93− fire [postBuildTrigger :=> Identity ()] $ isFiring shutdown

94−

95− -- The main application loop. We wait for new events and fire those that

96− -- have subscribers. If we detect a shutdown request, the application

97− -- terminates.

98− unless (or (fromMaybe [] soa)) $ fix $ \loop -> do

99− -- Read the next event (blocking).

100− ers <- liftIO $ readChan events

101− stop <- do

102− -- Fire events that have subscribers.

103− fireEventTriggerRefs fc ers $

104− -- Check if the shutdown 'Event' is firing.

105− isFiring shutdown

106− if or stop

107− then pure ()

108− else loop

109− where

110− isFiring ev = readEvent ev >>= \case

111− Nothing -> pure False

112− Just _ -> pure True

113− -- Use the given 'FireCommand' to fire events that have subscribers

114− -- and call the callback for the 'TriggerInvocation' of each.

115− fireEventTriggerRefs

116− :: MonadIO m

117− => FireCommand t m

118− -> [DSum (EventTriggerRef t) TriggerInvocation]

119− -> ReadPhase m a

120− -> m [a]

121− fireEventTriggerRefs (FireCommand fire) ers rcb = do

122− mes <- liftIO $

123− for ers $ \(EventTriggerRef er :=> TriggerInvocation a _) -> do

124− me <- readIORef er

125− pure $ fmap (==> a) me

126− a <- fire (catMaybes mes) rcb

127− liftIO $ for_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb

128− pure a

src/Reflex/Network.hsdeleted−45

@@ -1,45 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE MultiParamTypeClasses #-}

3−#ifdef USE_REFLEX_OPTIMIZER

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

5−#endif

6−-- |

7−-- Module:

8−-- Reflex.Network

9−-- Description:

10−-- This module provides combinators for building FRP graphs/networks and modifying them dynamically.

11−module Reflex.Network

12− ( networkView

13− , networkHold

14− , untilReady

15− ) where

16−

17−import Reflex.Class

18−import Reflex.Adjustable.Class

19−import Reflex.NotReady.Class

20−import Reflex.PostBuild.Class

21−

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

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

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

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

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

27−networkView child = do

28− postBuild <- getPostBuild

29− let newChild = leftmost [updated child, tagCheap (current child) postBuild]

30− snd <$> runWithReplace notReady newChild

31−

32−-- | Given an initial "network" and an 'Event' of network-creating actions, create a network that is recreated whenever the Event fires.

33−-- The returned Dynamic of network results occurs when the Event does.

34−-- Note: Often, the type 'a' is an Event, in which case the return value is a Dynamic-of-Events that would typically be flattened.

35−networkHold :: (Adjustable t m, MonadHold t m) => m a -> Event t (m a) -> m (Dynamic t a)

36−networkHold child0 newChild = do

37− (result0, newResult) <- runWithReplace child0 newChild

38− holdDyn result0 newResult

39−

40−-- | Render a placeholder network to be shown while another network is not yet

41−-- done building

42−untilReady :: (Adjustable t m, PostBuild t m) => m a -> m b -> m (a, Event t b)

43−untilReady a b = do

44− postBuild <- getPostBuild

45− runWithReplace a $ b <$ postBuild

src/Reflex/NotReady/Class.hsdeleted−77

@@ -1,77 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DefaultSignatures #-}

3−{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE FlexibleInstances #-}

5−{-# LANGUAGE FunctionalDependencies #-}

6−{-# LANGUAGE TypeFamilies #-}

7−{-# LANGUAGE UndecidableInstances #-}

8−#ifdef USE_REFLEX_OPTIMIZER

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

10−#endif

11−module Reflex.NotReady.Class

12− ( NotReady(..)

13− ) where

14−

15−import Control.Monad.Reader (ReaderT)

16−import Control.Monad.Trans

17−import Control.Monad.Trans.Writer (WriterT)

18−

19−import Reflex.BehaviorWriter.Base (BehaviorWriterT)

20−import Reflex.Class

21−import Reflex.DynamicWriter.Base (DynamicWriterT)

22−import Reflex.EventWriter.Base (EventWriterT)

23−import Reflex.Host.Class

24−import Reflex.PerformEvent.Base (PerformEventT (..))

25−import Reflex.PostBuild.Base (PostBuildT)

26−import Reflex.Query.Base (QueryT)

27−import Reflex.Requester.Base (RequesterT)

28−import Reflex.TriggerEvent.Base (TriggerEventT)

29−

30−class Monad m => NotReady t m | m -> t where

31− notReadyUntil :: Event t a -> m ()

32− default notReadyUntil :: (MonadTrans f, m ~ f m', NotReady t m') => Event t a -> m ()

33− notReadyUntil = lift . notReadyUntil

34−

35− notReady :: m ()

36− default notReady :: (MonadTrans f, m ~ f m', NotReady t m') => m ()

37− notReady = lift notReady

38−

39−instance NotReady t m => NotReady t (ReaderT r m) where

40− notReadyUntil = lift . notReadyUntil

41− notReady = lift notReady

42−

43−instance (NotReady t m, Monoid w) => NotReady t (WriterT w m) where

44− notReadyUntil = lift . notReadyUntil

45− notReady = lift notReady

46−

47−instance NotReady t m => NotReady t (PostBuildT t m) where

48− notReadyUntil = lift . notReadyUntil

49− notReady = lift notReady

50−

51−instance NotReady t m => NotReady t (EventWriterT t w m) where

52− notReadyUntil = lift . notReadyUntil

53− notReady = lift notReady

54−

55−instance NotReady t m => NotReady t (DynamicWriterT t w m) where

56− notReadyUntil = lift . notReadyUntil

57− notReady = lift notReady

58−

59−instance NotReady t m => NotReady t (BehaviorWriterT t w m) where

60− notReadyUntil = lift . notReadyUntil

61− notReady = lift notReady

62−

63−instance NotReady t m => NotReady t (QueryT t q m) where

64− notReadyUntil = lift . notReadyUntil

65− notReady = lift notReady

66−

67−instance (ReflexHost t, NotReady t (HostFrame t)) => NotReady t (PerformEventT t m) where

68− notReadyUntil = PerformEventT . notReadyUntil

69− notReady = PerformEventT notReady

70−

71−instance NotReady t m => NotReady t (RequesterT t request response m) where

72− notReadyUntil = lift . notReadyUntil

73− notReady = lift notReady

74−

75−instance NotReady t m => NotReady t (TriggerEventT t m) where

76− notReadyUntil = lift . notReadyUntil

77− notReady = lift notReady

src/Reflex/Optimizer.hs+5−19

@@ -1,14 +1,10 @@

1+-- | This module provides a GHC plugin designed to improve code that uses

2+-- Reflex. Currently, it just adds an INLINABLE pragma to any top-level

3+-- definition that doesn't have an explicit inlining pragma. In the future,

4+-- additional optimizations are likely to be added.

1{-# LANGUAGE CPP #-}

5{-# LANGUAGE CPP #-}

2{-# LANGUAGE LambdaCase #-}

6{-# LANGUAGE LambdaCase #-}

3{-# LANGUAGE OverloadedStrings #-}

7{-# LANGUAGE OverloadedStrings #-}

4−-- |

5−-- Module:

6−-- Reflex.Optimizer

7−-- Description:

8−-- This module provides a GHC plugin designed to improve code that uses

9−-- Reflex. Currently, it just adds an INLINABLE pragma to any top-level

10−-- definition that doesn't have an explicit inlining pragma. In the future,

11−-- additional optimizations are likely to be added.

12module Reflex.Optimizer

8module Reflex.Optimizer

13 ( plugin

9 ( plugin

14 ) where

10 ) where

@@ -20,11 +16,6 @@ import Control.Arrow

20import CoreMonad

16import CoreMonad

21import Data.String

17import Data.String

22import GhcPlugins

18import GhcPlugins

23−

24−#if MIN_VERSION_base(4,9,0)

25−import Prelude hiding ((<>))

26−#endif

27−

28#endif

19#endif

30#ifdef ghcjs_HOST_OS

21#ifdef ghcjs_HOST_OS

@@ -40,12 +31,7 @@ plugin :: Plugin

40plugin = defaultPlugin { installCoreToDos = install }

31plugin = defaultPlugin { installCoreToDos = install }

42install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]

33install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]

43−install [] p = do

44− liftIO $ putStrLn $ showSDocUnsafe $ ppr p

45− let f = \case

46− simpl@(CoreDoSimplify _ _) -> [CoreDoSpecialising, simpl]

47− x -> [x]

48− return $ makeInlinable : concatMap f p

34+install [] p = return $ makeInlinable : p

49install options@(_:_) p = do

35install options@(_:_) p = do

50 warnMsg $ "Reflex.Optimizer: ignoring " <> fromString (show $ length options) <> " command-line options"

36 warnMsg $ "Reflex.Optimizer: ignoring " <> fromString (show $ length options) <> " command-line options"

51 install [] p

37 install [] p

src/Reflex/Patch.hsnew file+387

@@ -0,0 +1,387 @@

1+-- | This module defines the 'Patch' class, which is used by Reflex to manage

2+-- changes to 'Reflex.Class.Incremental' values.

3+{-# LANGUAGE CPP #-}

4+{-# LANGUAGE DeriveFoldable #-}

5+{-# LANGUAGE DeriveFunctor #-}

6+{-# LANGUAGE DeriveTraversable #-}

7+{-# LANGUAGE FlexibleContexts #-}

8+{-# LANGUAGE GADTs #-}

9+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

10+{-# LANGUAGE LambdaCase #-}

11+{-# LANGUAGE PolyKinds #-}

12+{-# LANGUAGE Rank2Types #-}

13+{-# LANGUAGE ScopedTypeVariables #-}

14+{-# LANGUAGE StandaloneDeriving #-}

15+{-# LANGUAGE TypeFamilies #-}

16+module Reflex.Patch

17+ ( Patch (..)

18+ , PatchDMap (..)

19+ , mapPatchDMap

20+ , traversePatchDMap

21+ , traversePatchDMapWithKey

22+ , weakenPatchDMapWith

23+ , patchDMapToPatchMapWith

24+ , const2PatchDMapWith

25+ , ComposeMaybe (..)

26+ , PatchMap (..)

27+ , patchMapNewElements

28+ , Group (..)

29+ , Additive

30+ , AdditivePatch (..)

31+ , PatchMapWithMove

32+ , unPatchMapWithMove

33+ , unsafePatchMapWithMove

34+ , patchMapWithMoveNewElements

35+ , MapEdit (..)

36+ , mapEditMoved

37+ , mapEditSetMoved

38+ , PatchDMapWithMove

39+ , unPatchDMapWithMove

40+ , unsafePatchDMapWithMove

41+ , patchThatSortsMapWith

42+ , patchThatChangesAndSortsMapWith

43+ , mapPatchDMapWithMove

44+ , traversePatchDMapWithMove

45+ , traversePatchDMapWithMoveWithKey

46+ , weakenPatchDMapWithMoveWith

47+ , patchDMapWithMoveToPatchMapWithMoveWith

48+ , const2PatchDMapWithMoveWith

49+ , DMapEdit (..)

50+ , dmapEditMoved

51+ -- * Test functions

52+ , validPatchMapWithMove

53+ , knownValidPatchMapWithMove

54+ , knownInvalidPatchMapWithMove

55+ ) where

56+

57+import Control.Arrow

58+import Control.Monad.Identity

59+import Control.Monad.State

60+import Data.Dependent.Map (DMap, DSum (..), GCompare (..))

61+import qualified Data.Dependent.Map as DMap

62+import Data.Foldable

63+import Data.Function

64+import Data.Functor.Constant

65+import Data.Functor.Misc

66+import Data.List

67+import Data.Map (Map)

68+import qualified Data.Map as Map

69+import Data.Maybe

70+import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid, (<>))

71+import qualified Data.Set as Set

72+import Data.Some (Some)

73+import qualified Data.Some as Some

74+import Data.Tuple

75+

76+-- | A 'Patch' type represents a kind of change made to a datastructure.

77+class Patch p where

78+ type PatchTarget p :: *

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

80+ -- 'Nothing'.

81+ apply :: p -> PatchTarget p -> Maybe (PatchTarget p)

82+

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

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

85+-- representational so that we can use safe 'coerce'.

86+newtype ComposeMaybe f a = ComposeMaybe { getComposeMaybe :: Maybe (f a) }

87+

88+deriving instance Functor f => Functor (ComposeMaybe f)

89+

90+instance Patch (Identity a) where

91+ type PatchTarget (Identity a) = a

92+ apply (Identity a) _ = Just a

93+

94+-- | A set of changes to a 'DMap'. Any element may be inserted/updated or

95+-- deleted.

96+newtype PatchDMap k v = PatchDMap (DMap k (ComposeMaybe v))

97+

98+deriving instance GCompare k => Semigroup (PatchDMap k v)

99+

100+deriving instance GCompare k => Monoid (PatchDMap k v)

101+

102+instance GCompare k => Patch (PatchDMap k v) where

103+ type PatchTarget (PatchDMap k v) = DMap k v

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

105+ where insertions = DMap.mapMaybeWithKey (const $ getComposeMaybe) diff

106+ deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getComposeMaybe) diff

107+ nothingToJust = \case

108+ Nothing -> Just $ Constant ()

109+ Just _ -> Nothing

110+

111+mapPatchDMap :: (forall a. v a -> v' a) -> PatchDMap k v -> PatchDMap k v'

112+mapPatchDMap f (PatchDMap p) = PatchDMap $ DMap.map (ComposeMaybe . fmap f . getComposeMaybe) p

113+

114+traversePatchDMap :: Applicative m => (forall a. v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v')

115+traversePatchDMap f = traversePatchDMapWithKey $ const f

116+

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

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

119+

120+weakenPatchDMapWith :: (forall a. v a -> v') -> PatchDMap k v -> PatchMap (Some k) v'

121+weakenPatchDMapWith f (PatchDMap p) = PatchMap $ weakenDMapWith (fmap f . getComposeMaybe) p

122+

123+patchDMapToPatchMapWith :: (f v -> v') -> PatchDMap (Const2 k v) f -> PatchMap k v'

124+patchDMapToPatchMapWith f (PatchDMap p) = PatchMap $ dmapToMapWith (fmap f . getComposeMaybe) p

125+

126+const2PatchDMapWith :: forall k v f a. (v -> f a) -> PatchMap k v -> PatchDMap (Const2 k a) f

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

128+ where g :: (k, Maybe v) -> DSum (Const2 k a) (ComposeMaybe f)

129+ g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)

130+

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

132+-- deleted.

133+newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }

134+

135+instance Ord k => Patch (PatchMap k v) where

136+ type PatchTarget (PatchMap k v) = Map k v

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

138+ where insertions = Map.mapMaybeWithKey (const id) p

139+ deletions = Map.mapMaybeWithKey (const nothingToJust) p

140+ nothingToJust = \case

141+ Nothing -> Just ()

142+ Just _ -> Nothing

143+

144+instance Ord k => Semigroup (PatchMap k v) where

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

146+ -- PatchMap is idempotent, so stimes n is id for every n

147+#if MIN_VERSION_semigroups(0,17,0)

148+ stimes = stimesIdempotentMonoid

149+#else

150+ times1p n x = case compare n 0 of

151+ LT -> error "stimesIdempotentMonoid: negative multiplier"

152+ EQ -> mempty

153+ GT -> x

154+#endif

155+

156+instance Ord k => Monoid (PatchMap k v) where

157+ mempty = PatchMap mempty

158+ mappend = (<>)

159+

160+instance Functor (PatchMap k) where

161+ fmap f = PatchMap . fmap (fmap f) . unPatchMap

162+

163+-- | Returns all the new elements that will be added to the 'Map'

164+patchMapNewElements :: PatchMap k v -> [v]

165+patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p

166+

167+---- Patches based on commutative groups

168+

169+-- | A 'Group' is a 'Monoid' where every element has an inverse.

170+class (Semigroup q, Monoid q) => Group q where

171+ negateG :: q -> q

172+ (~~) :: q -> q -> q

173+ r ~~ s = r <> negateG s

174+

175+-- | An 'Additive' 'Semigroup' is one where (<>) is commutative

176+class Semigroup q => Additive q where

177+

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

179+newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }

180+

181+instance Additive p => Patch (AdditivePatch p) where

182+ type PatchTarget (AdditivePatch p) = p

183+ apply (AdditivePatch p) q = Just $ p <> q

184+

185+data MapEdit k v

186+ = MapEdit_Insert Bool v -- ^ Insert the given value here

187+ | MapEdit_Delete Bool -- ^ Delete the existing value, if any, from here

188+ | MapEdit_Move Bool k -- ^ Move the value here from the given key

189+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)

190+

191+mapEditMoved :: MapEdit k v -> Bool

192+mapEditMoved = \case

193+ MapEdit_Insert moved _ -> moved

194+ MapEdit_Delete moved -> moved

195+ MapEdit_Move moved _ -> moved

196+

197+mapEditSetMoved :: Bool -> MapEdit k v -> MapEdit k v

198+mapEditSetMoved moved = \case

199+ MapEdit_Insert _ v -> MapEdit_Insert moved v

200+ MapEdit_Delete _ -> MapEdit_Delete moved

201+ MapEdit_Move _ k -> MapEdit_Move moved k

202+

203+-- | Patch a DMap with additions, deletions, and moves.

204+-- Invariants:

205+-- * The same source key may not be moved to two destination keys.

206+-- * Any key that is the source of a Move must also be edited

207+-- (otherwise, the Move would duplicate it)

208+data PatchMapWithMove k v = PatchMapWithMove (Map k (MapEdit k v)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable)

209+

210+unPatchMapWithMove :: PatchMapWithMove k v -> Map k (MapEdit k v)

211+unPatchMapWithMove (PatchMapWithMove p) = p

212+

213+-- | Warning: when using this function, you must ensure that the invariants of

214+-- 'PatchMapWithMove' are preserved; they will not be checked.

215+unsafePatchMapWithMove :: Map k (MapEdit k v) -> PatchMapWithMove k v

216+unsafePatchMapWithMove = PatchMapWithMove

217+

218+instance Ord k => Patch (PatchMapWithMove k v) where

219+ type PatchTarget (PatchMapWithMove k v) = Map k v

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

221+ where insertions = flip Map.mapMaybeWithKey p $ const $ \case

222+ MapEdit_Insert _ v -> Just v

223+ MapEdit_Move _ k -> Map.lookup k old

224+ MapEdit_Delete _ -> Nothing

225+ deletions = flip Map.mapMaybeWithKey p $ const $ \case

226+ MapEdit_Delete _ -> Just ()

227+ _ -> Nothing

228+

229+-- | Returns all the new elements that will be added to the 'Map'

230+patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]

231+patchMapWithMoveNewElements (PatchMapWithMove p) = catMaybes $ flip fmap (Map.elems p) $ \case

232+ MapEdit_Insert _ v -> Just v

233+ MapEdit_Move _ _ -> Nothing

234+ MapEdit_Delete _ -> Nothing

235+

236+validPatchMapWithMove :: Ord k => PatchMapWithMove k v -> Bool

237+validPatchMapWithMove (PatchMapWithMove p) =

238+ let moveSources = catMaybes $ flip fmap (Map.elems p) $ \case

239+ MapEdit_Move _ k -> Just k

240+ _ -> Nothing

241+ in and

242+ [ -- All Moves must have unique source keys - a single source key can't be moved to two destinations

243+ all (==1) $ Map.fromListWith (+) $ fmap (\k -> (k, 1 :: Integer )) moveSources

244+ , -- All Move source keys must also be patched - since the value's being moved elsewhere, the original must either be Deleted or replaced (with Insert or Move)

245+ all (isJust . flip Map.lookup p) moveSources

246+ ]

247+

248+knownValidPatchMapWithMove :: [PatchMapWithMove Int Int]

249+knownValidPatchMapWithMove =

250+ [ PatchMapWithMove mempty

251+ , PatchMapWithMove $ Map.fromList

252+ [ (1, MapEdit_Move True 2)

253+ , (2, MapEdit_Move True 1)

254+ ]

255+ ]

256+

257+knownInvalidPatchMapWithMove :: [PatchMapWithMove Int Int]

258+knownInvalidPatchMapWithMove =

259+ [ -- Invalid because we move 2 to 1, but don't specify what to do with 2

260+ PatchMapWithMove $ Map.singleton 1 $ MapEdit_Move False 2

261+ , -- Invalid because we have multiple moves from 3

262+ PatchMapWithMove $ Map.fromList

263+ [ (1, MapEdit_Move False 3)

264+ , (2, MapEdit_Move False 3)

265+ , (3, MapEdit_Delete True)

266+ ]

267+ ]

268+

269+patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v

270+patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g l $ sortBy (cmp `on` snd) l

271+ where l = Map.toList m

272+ g (to, _) (from, _) = if to == from

273+ then Nothing

274+ else Just (to, MapEdit_Move True from)

275+

276+patchThatChangesAndSortsMapWith :: (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v

277+patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patch

278+ where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex

279+ newList = Map.toList newByIndexUnsorted

280+ newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList

281+ (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do

282+ let f k v = do

283+ remainingValues <- get

284+ let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys

285+ then Map.delete v remainingValues

286+ else Map.insert v remainingKeys remainingValues

287+ case Map.lookup v remainingValues of

288+ Nothing -> return $ MapEdit_Insert True v -- There's no existing value we can take

289+ Just fromKs ->

290+ if k `Set.member` fromKs

291+ then do

292+ putRemainingKeys $ Set.delete k fromKs

293+ return $ MapEdit_Move True k -- There's an existing value, and it's here, so no patch necessary

294+ else do

295+ Just (fromK, remainingKeys) <- return $ Set.minView fromKs -- There's an existing value, but it's not here; move it here

296+ putRemainingKeys remainingKeys

297+ return $ MapEdit_Move True fromK

298+ Map.traverseWithKey f newByIndex

299+ unusedOldKeys = fold unusedValuesByValue

300+ pointlessMove k = \case

301+ MapEdit_Move _ k' | k == k' -> True

302+ _ -> False

303+ keyWasMoved k = k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)

304+ patch = unsafePatchMapWithMove $ Map.filterWithKey (\k v -> not $ pointlessMove k v) $ Map.mergeWithKey (\k a _ -> Just $ mapEditSetMoved (keyWasMoved k) a) (Map.mapWithKey $ \k -> mapEditSetMoved $ keyWasMoved k) (Map.mapWithKey $ \k _ -> MapEdit_Delete $ keyWasMoved k) insertsAndMoves oldByIndex

305+

306+data DMapEdit (k :: a -> *) (v :: a -> *) :: a -> * where

307+ -- | Insert the given value here

308+ DMapEdit_Insert :: Bool -> v a -> DMapEdit k v a

309+ -- | Delete the existing value, if any, from here

310+ DMapEdit_Delete :: Bool -> DMapEdit k v a

311+ -- | Move the value here from the given key

312+ DMapEdit_Move :: Bool -> k a -> DMapEdit k v a

313+

314+dmapEditMoved :: DMapEdit k v a -> Bool

315+dmapEditMoved = \case

316+ DMapEdit_Insert moved _ -> moved

317+ DMapEdit_Delete moved -> moved

318+ DMapEdit_Move moved _ -> moved

319+

320+-- | Like 'PatchMapWithMove', but for 'DMap'.

321+newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (DMapEdit k v))

322+

323+unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (DMapEdit k v)

324+unPatchDMapWithMove (PatchDMapWithMove p) = p

325+

326+-- | Warning: when using this function, you must ensure that the invariants of

327+-- 'PatchDMapWithMove' are preserved; they will not be checked.

328+unsafePatchDMapWithMove :: DMap k (DMapEdit k v) -> PatchDMapWithMove k v

329+unsafePatchDMapWithMove = PatchDMapWithMove

330+

331+mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'

332+mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $ DMap.map g p

333+ where g :: forall a. DMapEdit k v a -> DMapEdit k v' a

334+ g = \case

335+ DMapEdit_Insert moved v -> DMapEdit_Insert moved $ f v

336+ DMapEdit_Delete moved -> DMapEdit_Delete moved

337+ DMapEdit_Move moved k -> DMapEdit_Move moved k

338+

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

340+traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f

341+

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

343+traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey g p

344+ where g :: forall a. k a -> DMapEdit k v a -> m (DMapEdit k v' a)

345+ g k = \case

346+ DMapEdit_Insert moved v -> DMapEdit_Insert moved <$> f k v

347+ DMapEdit_Delete moved -> pure $ DMapEdit_Delete moved

348+ DMapEdit_Move moved fromKey -> pure $ DMapEdit_Move moved fromKey

349+

350+weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'

351+weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p

352+ where g :: forall a. DMapEdit k v a -> MapEdit (Some k) v'

353+ g = \case

354+ DMapEdit_Insert moved v -> MapEdit_Insert moved $ f v

355+ DMapEdit_Delete moved -> MapEdit_Delete moved

356+ DMapEdit_Move moved k -> MapEdit_Move moved $ Some.This k

357+

358+patchDMapWithMoveToPatchMapWithMoveWith :: forall k f v v'. (f v -> v') -> PatchDMapWithMove (Const2 k v) f -> PatchMapWithMove k v'

359+patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p

360+ where g :: DMapEdit (Const2 k v) f v -> MapEdit k v'

361+ g = \case

362+ DMapEdit_Insert moved v -> MapEdit_Insert moved $ f v

363+ DMapEdit_Delete moved -> MapEdit_Delete moved

364+ DMapEdit_Move moved (Const2 k) -> MapEdit_Move moved k

365+

366+const2PatchDMapWithMoveWith :: forall k v f a. (v -> f a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) f

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

368+ where g :: (k, MapEdit k v) -> DSum (Const2 k a) (DMapEdit (Const2 k a) f)

369+ g (k, e) = Const2 k :=> case e of

370+ MapEdit_Insert moved v -> DMapEdit_Insert moved $ f v

371+ MapEdit_Delete moved -> DMapEdit_Delete moved

372+ MapEdit_Move moved fromKey -> DMapEdit_Move moved $ Const2 fromKey

373+

374+instance GCompare k => Patch (PatchDMapWithMove k v) where

375+ type PatchTarget (PatchDMapWithMove k v) = DMap k v

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

377+ where insertions = DMap.mapMaybeWithKey insertFunc p

378+ insertFunc :: forall a. k a -> DMapEdit k v a -> Maybe (v a)

379+ insertFunc _ = \case

380+ DMapEdit_Insert _ v -> Just v

381+ DMapEdit_Move _ k -> DMap.lookup k old

382+ DMapEdit_Delete _ -> Nothing

383+ deletions = DMap.mapMaybeWithKey deleteFunc p

384+ deleteFunc :: forall a. k a -> DMapEdit k v a -> Maybe (Constant () a)

385+ deleteFunc _ = \case

386+ DMapEdit_Delete _ -> Just $ Constant ()

387+ _ -> Nothing

src/Reflex/PerformEvent/Base.hs+5−29

@@ -25,7 +25,6 @@ module Reflex.PerformEvent.Base

25 ) where

27import Reflex.Class

28−import Reflex.Adjustable.Class

29import Reflex.Host.Class

28import Reflex.Host.Class

30import Reflex.PerformEvent.Class

29import Reflex.PerformEvent.Class

31import Reflex.Requester.Base

30import Reflex.Requester.Base

@@ -41,9 +40,6 @@ import Data.Coerce

41import Data.Dependent.Map (DMap)

40import Data.Dependent.Map (DMap)

42import qualified Data.Dependent.Map as DMap

41import qualified Data.Dependent.Map as DMap

43import Data.Dependent.Sum

42import Data.Dependent.Sum

44−import Data.IntMap.Strict (IntMap)

45−import qualified Data.IntMap.Strict as IntMap

46−import qualified Data.Semigroup as S

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

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

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

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

@@ -61,30 +57,27 @@ deriving instance ReflexHost t => Monad (PerformEventT t m)

61deriving instance ReflexHost t => MonadFix (PerformEventT t m)

57deriving instance ReflexHost t => MonadFix (PerformEventT t m)

62deriving instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (PerformEventT t m)

58deriving instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (PerformEventT t m)

63deriving instance (ReflexHost t, MonadException (HostFrame t)) => MonadException (PerformEventT t m)

59deriving instance (ReflexHost t, MonadException (HostFrame t)) => MonadException (PerformEventT t m)

64−deriving instance (ReflexHost t, Monoid a) => Monoid (PerformEventT t m a)

65−deriving instance (ReflexHost t, S.Semigroup a) => S.Semigroup (PerformEventT t m a)

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

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

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

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

69 primitive = PerformEventT . lift . primitive

63 primitive = PerformEventT . lift . primitive

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

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

72 type Performable (PerformEventT t m) = HostFrame t

66 type Performable (PerformEventT t m) = HostFrame t

73 {-# INLINABLE performEvent_ #-}

67 {-# INLINABLE performEvent_ #-}

74 performEvent_ = PerformEventT . requesting_

68 performEvent_ = PerformEventT . requesting_

75 {-# INLINABLE performEvent #-}

69 {-# INLINABLE performEvent #-}

76 performEvent = PerformEventT . requestingIdentity

70 performEvent = PerformEventT . requestingIdentity

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

72+instance (ReflexHost t, PrimMonad (HostFrame t)) => MonadAdjust t (PerformEventT t m) where

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

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

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

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

81 f a0 a' = do

75 f a0 a' = do

82 result0 <- lift a0

76 result0 <- lift a0

83 result' <- requestingIdentity a'

77 result' <- requestingIdentity a'

84 return (result0, result')

78 return (result0, result')

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

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

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

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

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

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

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

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

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

@@ -97,17 +90,6 @@ defaultAdjustBase traversePatchWithKey f' dm0 dm' = do

97 result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f'

90 result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f'

98 return (result0, result')

91 return (result0, result')

100−defaultAdjustIntBase :: forall t v v2 p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t)

101− => ((IntMap.Key -> v -> HostFrame t v2) -> p v -> HostFrame t (p v2))

102− -> (IntMap.Key -> v -> HostFrame t v2)

103− -> IntMap v

104− -> Event t (p v)

105− -> RequesterT t (HostFrame t) Identity (HostFrame t) (IntMap v2, Event t (p v2))

106−defaultAdjustIntBase traversePatchWithKey f' dm0 dm' = do

107− result0 <- lift $ IntMap.traverseWithKey f' dm0

108− result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f'

109− return (result0, result')

110−

111instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where

93instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where

112 {-# INLINABLE newEventWithTrigger #-}

94 {-# INLINABLE newEventWithTrigger #-}

113 newEventWithTrigger = PerformEventT . lift . newEventWithTrigger

95 newEventWithTrigger = PerformEventT . lift . newEventWithTrigger

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

141 case mToPerform of

123 case mToPerform of

142 Nothing -> return [result']

124 Nothing -> return [result']

143 Just toPerform -> do

125 Just toPerform -> do

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

126+ responses <- runHostFrame $ DMap.traverseWithKey (\_ v -> Identity <$> v) toPerform

145 mrt <- readRef responseTrigger

127 mrt <- readRef responseTrigger

146 let followupEventTriggers = case mrt of

128 let followupEventTriggers = case mrt of

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

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

@@ -160,12 +142,6 @@ instance (ReflexHost t, MonadHold t m) => MonadHold t (PerformEventT t m) where

160 holdDyn v0 v' = PerformEventT $ lift $ holdDyn v0 v'

142 holdDyn v0 v' = PerformEventT $ lift $ holdDyn v0 v'

161 {-# INLINABLE holdIncremental #-}

143 {-# INLINABLE holdIncremental #-}

162 holdIncremental v0 v' = PerformEventT $ lift $ holdIncremental v0 v'

144 holdIncremental v0 v' = PerformEventT $ lift $ holdIncremental v0 v'

163− {-# INLINABLE buildDynamic #-}

164− buildDynamic getV0 v' = PerformEventT $ lift $ buildDynamic getV0 v'

165− {-# INLINABLE headE #-}

166− headE = PerformEventT . lift . headE

167− {-# INLINABLE now #-}

168− now = PerformEventT . lift $ now

169

145

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

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

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

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

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

@@ -5,9 +5,11 @@

5{-# LANGUAGE FlexibleContexts #-}

6{-# LANGUAGE FlexibleInstances #-}

7{-# LANGUAGE FunctionalDependencies #-}

8+{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE RankNTypes #-}

9{-# LANGUAGE RankNTypes #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE TypeFamilies #-}

11{-# LANGUAGE TypeFamilies #-}

12+{-# LANGUAGE TypeOperators #-}

11{-# LANGUAGE UndecidableInstances #-}

13{-# LANGUAGE UndecidableInstances #-}

12#ifdef USE_REFLEX_OPTIMIZER

14#ifdef USE_REFLEX_OPTIMIZER

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

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

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

21import Reflex.TriggerEvent.Class

23import Reflex.TriggerEvent.Class

23import Control.Monad.Reader

25import Control.Monad.Reader

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

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

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

27-- 'Event's.

28-- 'Event's.

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

61 performEvent e = do

62 performEvent e = do

62 r <- ask

63 r <- ask

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

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

64−

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

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

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

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

src/Reflex/PostBuild/Base.hs+13−69

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

9{-# LANGUAGE RecursiveDo #-}

10{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE TypeFamilies #-}

12+{-# LANGUAGE TypeOperators #-}

12{-# LANGUAGE UndecidableInstances #-}

13{-# LANGUAGE UndecidableInstances #-}

13#ifdef USE_REFLEX_OPTIMIZER

14#ifdef USE_REFLEX_OPTIMIZER

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

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

@@ -16,31 +17,23 @@

16module Reflex.PostBuild.Base

17module Reflex.PostBuild.Base

17 ( PostBuildT (..)

18 ( PostBuildT (..)

18 , runPostBuildT

19 , runPostBuildT

19− -- * Internal

20− , mapIntMapWithAdjustImpl

21− , mapDMapWithAdjustImpl

22 ) where

20 ) where

24import Reflex.Class

22import Reflex.Class

25−import Reflex.Adjustable.Class

26import Reflex.Host.Class

23import Reflex.Host.Class

27import Reflex.PerformEvent.Class

24import Reflex.PerformEvent.Class

28import Reflex.PostBuild.Class

25import Reflex.PostBuild.Class

29import Reflex.TriggerEvent.Class

26import Reflex.TriggerEvent.Class

31−import Control.Applicative (liftA2)

32import Control.Monad.Exception

28import Control.Monad.Exception

33import Control.Monad.Identity

29import Control.Monad.Identity

34import Control.Monad.Primitive

30import Control.Monad.Primitive

35import Control.Monad.Reader

31import Control.Monad.Reader

36import Control.Monad.Ref

32import Control.Monad.Ref

37−import qualified Control.Monad.Trans.Control as TransControl

33+import Control.Monad.Trans.Control

38import Data.Dependent.Map (DMap)

34import Data.Dependent.Map (DMap)

39import qualified Data.Dependent.Map as DMap

35import qualified Data.Dependent.Map as DMap

40import Data.Functor.Compose

36import Data.Functor.Compose

41−import Data.IntMap.Strict (IntMap)

42−import qualified Data.IntMap.Strict as IntMap

43−import qualified Data.Semigroup as S

45-- | Provides a basic implementation of 'PostBuild'.

38-- | Provides a basic implementation of 'PostBuild'.

46newtype PostBuildT t m a = PostBuildT { unPostBuildT :: ReaderT (Event t ()) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadTrans, MonadException, MonadAsyncException)

39newtype PostBuildT t m a = PostBuildT { unPostBuildT :: ReaderT (Event t ()) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadTrans, MonadException, MonadAsyncException)

@@ -52,18 +45,17 @@ newtype PostBuildT t m a = PostBuildT { unPostBuildT :: ReaderT (Event t ()) m a

52runPostBuildT :: PostBuildT t m a -> Event t () -> m a

45runPostBuildT :: PostBuildT t m a -> Event t () -> m a

53runPostBuildT (PostBuildT a) = runReaderT a

46runPostBuildT (PostBuildT a) = runReaderT a

55−-- TODO: Monoid and Semigroup can likely be derived once ReaderT has them.

56−instance (Monoid a, Applicative m) => Monoid (PostBuildT t m a) where

57− mempty = pure mempty

58− mappend = liftA2 mappend

59−

60−instance (S.Semigroup a, Applicative m) => S.Semigroup (PostBuildT t m a) where

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

62−

63instance PrimMonad m => PrimMonad (PostBuildT x m) where

48instance PrimMonad m => PrimMonad (PostBuildT x m) where

64 type PrimState (PostBuildT x m) = PrimState m

49 type PrimState (PostBuildT x m) = PrimState m

65 primitive = lift . primitive

50 primitive = lift . primitive

52+instance MonadTransControl (PostBuildT t) where

53+ type StT (PostBuildT t) a = StT (ReaderT (Event t ())) a

54+ {-# INLINABLE liftWith #-}

55+ liftWith = defaultLiftWith PostBuildT unPostBuildT

56+ {-# INLINABLE restoreT #-}

57+ restoreT = defaultRestoreT PostBuildT

58+

67instance (Reflex t, Monad m) => PostBuild t (PostBuildT t m) where

59instance (Reflex t, Monad m) => PostBuild t (PostBuildT t m) where

68 {-# INLINABLE getPostBuild #-}

60 {-# INLINABLE getPostBuild #-}

69 getPostBuild = PostBuildT ask

61 getPostBuild = PostBuildT ask

@@ -79,19 +71,13 @@ instance MonadHold t m => MonadHold t (PostBuildT t m) where

79 holdDyn v0 = lift . holdDyn v0

71 holdDyn v0 = lift . holdDyn v0

80 {-# INLINABLE holdIncremental #-}

72 {-# INLINABLE holdIncremental #-}

81 holdIncremental v0 = lift . holdIncremental v0

73 holdIncremental v0 = lift . holdIncremental v0

82− {-# INLINABLE buildDynamic #-}

83− buildDynamic a0 = lift . buildDynamic a0

84− {-# INLINABLE headE #-}

85− headE = lift . headE

86− {-# INLINABLE now #-}

87− now = lift now

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

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

90− type Performable (PostBuildT t m) = Performable m

76+ type Performable (PostBuildT t m) = PostBuildT t (Performable m)

91 {-# INLINABLE performEvent_ #-}

77 {-# INLINABLE performEvent_ #-}

92− performEvent_ = lift . performEvent_

78+ performEvent_ e = liftWith $ \run -> performEvent_ $ fmap run e

93 {-# INLINABLE performEvent #-}

79 {-# INLINABLE performEvent #-}

94− performEvent = lift . performEvent

80+ performEvent e = liftWith $ \run -> performEvent $ fmap run e

96instance (ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (PostBuildT t m) where

82instance (ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (PostBuildT t m) where

97 {-# INLINABLE newEventWithTrigger #-}

83 {-# INLINABLE newEventWithTrigger #-}

@@ -119,46 +105,16 @@ instance MonadAtomicRef m => MonadAtomicRef (PostBuildT t m) where

119 {-# INLINABLE atomicModifyRef #-}

105 {-# INLINABLE atomicModifyRef #-}

120 atomicModifyRef r = lift . atomicModifyRef r

106 atomicModifyRef r = lift . atomicModifyRef r

121

107

122−instance (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, PerformEvent t m) => Adjustable t (PostBuildT t m) where

108+instance (Reflex t, MonadHold t m, MonadFix m, MonadAdjust t m, PerformEvent t m) => MonadAdjust t (PostBuildT t m) where

123 runWithReplace a0 a' = do

109 runWithReplace a0 a' = do

124 postBuild <- getPostBuild

110 postBuild <- getPostBuild

125 lift $ do

111 lift $ do

126 rec result@(_, result') <- runWithReplace (runPostBuildT a0 postBuild) $ fmap (\v -> runPostBuildT v =<< headE voidResult') a'

112 rec result@(_, result') <- runWithReplace (runPostBuildT a0 postBuild) $ fmap (\v -> runPostBuildT v =<< headE voidResult') a'

127 let voidResult' = fmapCheap (\_ -> ()) result'

113 let voidResult' = fmapCheap (\_ -> ()) result'

128 return result

114 return result

129− {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}

130− traverseIntMapWithKeyWithAdjust = mapIntMapWithAdjustImpl traverseIntMapWithKeyWithAdjust

131− {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

132 traverseDMapWithKeyWithAdjust = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap

115 traverseDMapWithKeyWithAdjust = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap

133 traverseDMapWithKeyWithAdjustWithMove = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove

116 traverseDMapWithKeyWithAdjustWithMove = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove

134

117

135−{-# INLINABLE mapIntMapWithAdjustImpl #-}

136−mapIntMapWithAdjustImpl :: forall t m v v' p. (Reflex t, MonadFix m, MonadHold t m, Functor p)

137− => ( (IntMap.Key -> (Event t (), v) -> m v')

138− -> IntMap (Event t (), v)

139− -> Event t (p (Event t (), v))

140− -> m (IntMap v', Event t (p v'))

141− )

142− -> (IntMap.Key -> v -> PostBuildT t m v')

143− -> IntMap v

144− -> Event t (p v)

145− -> PostBuildT t m (IntMap v', Event t (p v'))

146−mapIntMapWithAdjustImpl base f dm0 dm' = do

147− postBuild <- getPostBuild

148− let loweredDm0 = fmap ((,) postBuild) dm0

149− f' :: IntMap.Key -> (Event t (), v) -> m v'

150− f' k (e, v) = do

151− runPostBuildT (f k v) e

152− lift $ do

153− rec (result0, result') <- base f' loweredDm0 loweredDm'

154− cohortDone <- numberOccurrencesFrom_ 1 result'

155− numberedDm' <- numberOccurrencesFrom 1 dm'

156− let postBuild' = fanInt $ fmapCheap (`IntMap.singleton` ()) cohortDone

157− loweredDm' = flip pushAlways numberedDm' $ \(n, p) -> do

158− return $ fmap ((,) (selectInt postBuild' n)) p

159− return (result0, result')

160−

161−{-# INLINABLE mapDMapWithAdjustImpl #-}

162mapDMapWithAdjustImpl :: forall t m k v v' p. (Reflex t, MonadFix m, MonadHold t m)

118mapDMapWithAdjustImpl :: forall t m k v v' p. (Reflex t, MonadFix m, MonadHold t m)

163 => ( (forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a))

119 => ( (forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a))

164 -> DMap k (Compose ((,) (Bool, Event t ())) v)

120 -> DMap k (Compose ((,) (Bool, Event t ())) v)

@@ -184,15 +140,3 @@ mapDMapWithAdjustImpl base mapPatch f dm0 dm' = do

184 let voidResult' = fmapCheap (\_ -> ()) result'

140 let voidResult' = fmapCheap (\_ -> ()) result'

185 let loweredDm' = ffor dm' $ mapPatch (Compose . (,) (True, voidResult'))

141 let loweredDm' = ffor dm' $ mapPatch (Compose . (,) (True, voidResult'))

186 return (result0, result')

142 return (result0, result')

187−

188−--------------------------------------------------------------------------------

189−-- Deprecated functionality

190−--------------------------------------------------------------------------------

191−

192−-- | Deprecated

193−instance TransControl.MonadTransControl (PostBuildT t) where

194− type StT (PostBuildT t) a = TransControl.StT (ReaderT (Event t ())) a

195− {-# INLINABLE liftWith #-}

196− liftWith = TransControl.defaultLiftWith PostBuildT unPostBuildT

197− {-# INLINABLE restoreT #-}

198− restoreT = TransControl.defaultRestoreT PostBuildT

src/Reflex/PostBuild/Class.hs+2−8

@@ -4,8 +4,10 @@

4{-# LANGUAGE DataKinds #-}

5{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE FunctionalDependencies #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE TypeFamilies #-}

9{-# LANGUAGE TypeFamilies #-}

10+{-# LANGUAGE TypeOperators #-}

9{-# LANGUAGE UndecidableInstances #-}

11{-# LANGUAGE UndecidableInstances #-}

10#ifdef USE_REFLEX_OPTIMIZER

12#ifdef USE_REFLEX_OPTIMIZER

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

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

@@ -17,8 +19,6 @@ module Reflex.PostBuild.Class

17import Reflex.Class

19import Reflex.Class

19import Control.Monad.Reader

21import Control.Monad.Reader

20−import Control.Monad.State

21−import qualified Control.Monad.State.Strict as Strict

23-- | 'PostBuild' represents an action that is notified via an 'Event' when it

24-- has finished executing. Note that the specific definition of "finished" is

@@ -32,9 +32,3 @@ class (Reflex t, Monad m) => PostBuild t m | m -> t where

33instance PostBuild t m => PostBuild t (ReaderT r m) where

34 getPostBuild = lift getPostBuild

35−

36−instance PostBuild t m => PostBuild t (StateT s m) where

37− getPostBuild = lift getPostBuild

38−

39−instance PostBuild t m => PostBuild t (Strict.StateT s m) where

40− getPostBuild = lift getPostBuild

src/Reflex/Profiled.hsdeleted−281

@@ -1,281 +0,0 @@

1−{-# LANGUAGE EmptyDataDecls #-}

2−{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE FlexibleInstances #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5−{-# LANGUAGE InstanceSigs #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

7−{-# LANGUAGE ScopedTypeVariables #-}

8−{-# LANGUAGE StandaloneDeriving #-}

9−{-# LANGUAGE TypeFamilies #-}

10−{-# LANGUAGE UndecidableInstances #-}

11−{-# LANGUAGE PolyKinds #-}

12−{-# LANGUAGE TypeApplications #-}

13−{-# LANGUAGE RankNTypes #-}

14−-- |

15−-- Module:

16−-- Reflex.Profiled

17−-- Description:

18−-- This module contains an instance of the 'Reflex' class that provides

19−-- profiling/cost-center information.

20−module Reflex.Profiled where

21−

22−import Control.Monad

23−import Control.Monad.Exception

24−import Control.Monad.Fix

25−import Control.Monad.Primitive

26−import Control.Monad.Reader

27−import Control.Monad.Ref

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

29−import Data.Bifunctor

30−import Data.Coerce

31−import Data.Dependent.Map (DMap)

32−import Data.GADT.Compare (GCompare)

33−import Data.FastMutableIntMap

34−import Data.IORef

35−import Data.List

36−import Data.Map (Map)

37−import qualified Data.Map.Strict as Map

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

39−import Data.Ord

40−import Data.Profunctor.Unsafe ((#.))

41−import qualified Data.Semigroup as S

42−import Data.Type.Coercion

43−import Foreign.Ptr

44−import GHC.Foreign

45−import GHC.IO.Encoding

46−import GHC.Stack

47−import Reflex.Adjustable.Class

48−import Reflex.BehaviorWriter.Class

49−import Reflex.Class

50−import Reflex.DynamicWriter.Class

51−import Reflex.EventWriter.Class

52−import Reflex.Host.Class

53−import Reflex.NotReady.Class

54−import Reflex.PerformEvent.Class

55−import Reflex.PostBuild.Class

56−import Reflex.Query.Class

57−import Reflex.Requester.Class

58−import Reflex.TriggerEvent.Class

59−

60−import System.IO.Unsafe

61−

62−data ProfiledTimeline t

63−

64−{-# NOINLINE profilingData #-}

65−profilingData :: IORef (Map (Ptr CostCentreStack) Int)

66−profilingData = unsafePerformIO $ newIORef Map.empty

67−

68−data CostCentreTree = CostCentreTree

69− { _costCentreTree_ownEntries :: !Int

70− , _costCentreTree_cumulativeEntries :: !Int

71− , _costCentreTree_children :: !(Map (Ptr CostCentre) CostCentreTree)

72− }

73− deriving (Show, Eq, Ord)

74−

75−instance S.Semigroup CostCentreTree where

76− (CostCentreTree oa ea ca) <> (CostCentreTree ob eb cb) =

77− CostCentreTree (oa + ob) (ea + eb) $ Map.unionWith (S.<>) ca cb

78−

79−instance Monoid CostCentreTree where

80− mempty = CostCentreTree 0 0 mempty

81− mappend = (S.<>)

82−

83−getCostCentreStack :: Ptr CostCentreStack -> IO [Ptr CostCentre]

84−getCostCentreStack = go []

85− where go l ccs = if ccs == nullPtr

86− then return l

87− else do

88− cc <- ccsCC ccs

89− parent <- ccsParent ccs

90− go (cc : l) parent

91−

92−toCostCentreTree :: Ptr CostCentreStack -> Int -> IO CostCentreTree

93−toCostCentreTree ccs n =

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

95− <$> getCostCentreStack ccs

96−

97−getCostCentreTree :: IO CostCentreTree

98−getCostCentreTree = do

99− vals <- readIORef profilingData

100− mconcat <$> mapM (uncurry toCostCentreTree) (Map.toList vals)

101−

102−formatCostCentreTree :: CostCentreTree -> IO String

103−formatCostCentreTree cct0 = unlines . reverse <$> execStateT (go 0 cct0) []

104− where go :: Int -> CostCentreTree -> StateT [String] IO ()

105− go depth cct = do

106− let children = sortOn (Down . _costCentreTree_cumulativeEntries . snd) $ Map.toList $ _costCentreTree_children cct

107− indent = mconcat $ replicate depth " "

108− forM_ children $ \(cc, childCct) -> do

109− lbl <- liftIO $ peekCString utf8 =<< ccLabel cc

110− mdl <- liftIO $ peekCString utf8 =<< ccModule cc

111− loc <- liftIO $ peekCString utf8 =<< ccSrcSpan cc

112− let description = mdl <> "." <> lbl <> " (" <> loc <> ")"

113− modify $ (:) $ indent <> description <> "\t" <> show (_costCentreTree_cumulativeEntries childCct) <> "\t" <> show (_costCentreTree_ownEntries childCct)

114− go (succ depth) childCct

115−

116−showProfilingData :: IO ()

117−showProfilingData = do

118− putStr =<< formatCostCentreTree =<< getCostCentreTree

119−

120−writeProfilingData :: FilePath -> IO ()

121−writeProfilingData p = do

122− writeFile p =<< formatCostCentreTree =<< getCostCentreTree

123−

124−newtype ProfiledM m a = ProfiledM { runProfiledM :: m a }

125− deriving (Functor, Applicative, Monad, MonadFix, MonadException, MonadAsyncException)

126−

127−profileEvent :: Reflex t => Event t a -> Event t a

128−profileEvent e = unsafePerformIO $ do

129− stack <- getCurrentCCS e

130− let f x = unsafePerformIO $ do

131− modifyIORef' profilingData $ Map.insertWith (+) stack 1

132− return $ return $ Just x

133− return $ pushCheap f e

134−

135−--TODO: Instead of profiling just the input or output of each one, profile all the inputs and all the outputs

136−

137−instance Reflex t => Reflex (ProfiledTimeline t) where

138− newtype Behavior (ProfiledTimeline t) a = Behavior_Profiled { unBehavior_Profiled :: Behavior t a }

139− newtype Event (ProfiledTimeline t) a = Event_Profiled { unEvent_Profiled :: Event t a }

140− newtype Dynamic (ProfiledTimeline t) a = Dynamic_Profiled { unDynamic_Profiled :: Dynamic t a }

141− newtype Incremental (ProfiledTimeline t) p = Incremental_Profiled { unIncremental_Profiled :: Incremental t p }

142− type PushM (ProfiledTimeline t) = ProfiledM (PushM t)

143− type PullM (ProfiledTimeline t) = ProfiledM (PullM t)

144− never = Event_Profiled never

145− constant = Behavior_Profiled . constant

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

147− pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e

148− pull = Behavior_Profiled . pull . coerce

149− fanG (Event_Profiled e) = EventSelectorG $ coerce $ selectG (fanG $ profileEvent e)

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

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

152− -> DMap k q -> Event (ProfiledTimeline t) (DMap k v)

153− mergeG nt = Event_Profiled #. mergeG (coerce nt)

154− switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b)

155− coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e)

156− current (Dynamic_Profiled d) = coerce $ current d

157− updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d

158− unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'

159− unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'

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

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

162− currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i

163− updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i

164− incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i

165− behaviorCoercion c =

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

167− eventCoercion c =

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

169− dynamicCoercion c =

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

171− incrementalCoercion c d =

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

173− mergeIntIncremental = Event_Profiled . mergeIntIncremental .

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

175− fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e

176−

177−deriving instance Functor (Dynamic t) => Functor (Dynamic (ProfiledTimeline t))

178−deriving instance Applicative (Dynamic t) => Applicative (Dynamic (ProfiledTimeline t))

179−deriving instance Monad (Dynamic t) => Monad (Dynamic (ProfiledTimeline t))

180−

181−instance MonadHold t m => MonadHold (ProfiledTimeline t) (ProfiledM m) where

182− hold v0 (Event_Profiled v') = ProfiledM $ Behavior_Profiled <$> hold v0 v'

183− holdDyn v0 (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> holdDyn v0 v'

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

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

186− headE (Event_Profiled e) = ProfiledM $ Event_Profiled <$> headE e

187− now = ProfiledM $ Event_Profiled <$> now

188−

189−instance MonadSample t m => MonadSample (ProfiledTimeline t) (ProfiledM m) where

190− sample (Behavior_Profiled b) = ProfiledM $ sample b

191−

192−instance Adjustable t m => Adjustable (ProfiledTimeline t) (ProfiledM m) where

193− runWithReplace a0 a' = (fmap . fmap) coerce . lift $

194− runWithReplace (coerce a0) (coerce $ coerce <$> a')

195− traverseIntMapWithKeyWithAdjust f dm0 dm' = (fmap . fmap) coerce . lift $

196− traverseIntMapWithKeyWithAdjust (\k v -> coerce $ f k v) dm0 (coerce dm')

197− traverseDMapWithKeyWithAdjust f dm0 dm' = (fmap . fmap) coerce . lift $

198− traverseDMapWithKeyWithAdjust (\k v -> coerce $ f k v) dm0 (coerce dm')

199− traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = (fmap . fmap) coerce . lift $

200− traverseDMapWithKeyWithAdjustWithMove (\k v -> coerce $ f k v) dm0 (coerce dm')

201−

202−instance MonadTrans ProfiledM where

203− lift = ProfiledM

204−

205−instance MonadIO m => MonadIO (ProfiledM m) where

206− liftIO = lift . liftIO

207−

208−instance PerformEvent t m => PerformEvent (ProfiledTimeline t) (ProfiledM m) where

209− type Performable (ProfiledM m) = Performable m

210− performEvent_ = lift . performEvent_ . coerce

211− performEvent = lift . fmap coerce . performEvent . coerce

212−

213−instance TriggerEvent t m => TriggerEvent (ProfiledTimeline t) (ProfiledM m) where

214− newTriggerEvent = first coerce <$> lift newTriggerEvent

215− newTriggerEventWithOnComplete = first coerce <$> lift newTriggerEventWithOnComplete

216− newEventWithLazyTriggerWithOnComplete f = coerce <$> lift (newEventWithLazyTriggerWithOnComplete f)

217−

218−instance PostBuild t m => PostBuild (ProfiledTimeline t) (ProfiledM m) where

219− getPostBuild = coerce <$> lift getPostBuild

220−

221−instance NotReady t m => NotReady (ProfiledTimeline t) (ProfiledM m) where

222− notReady = lift notReady

223− notReadyUntil = lift . notReadyUntil . coerce

224−

225−instance BehaviorWriter t w m => BehaviorWriter (ProfiledTimeline t) w (ProfiledM m) where

226− tellBehavior = lift . tellBehavior . coerce

227−

228−instance DynamicWriter t w m => DynamicWriter (ProfiledTimeline t) w (ProfiledM m) where

229− tellDyn = lift . tellDyn . coerce

230−

231−instance EventWriter t w m => EventWriter (ProfiledTimeline t) w (ProfiledM m) where

232− tellEvent = lift . tellEvent . coerce

233−

234−instance MonadQuery t q m => MonadQuery (ProfiledTimeline t) q (ProfiledM m) where

235− tellQueryIncremental = lift . tellQueryIncremental . coerce

236− askQueryResult = coerce <$> lift askQueryResult

237− queryIncremental = fmap coerce . lift . queryIncremental . coerce

238−

239−instance Requester t m => Requester (ProfiledTimeline t) (ProfiledM m) where

240− type Request (ProfiledM m) = Request m

241− type Response (ProfiledM m) = Response m

242−

243− requesting = fmap coerce . lift . requesting . coerce

244− requesting_ = lift . requesting_ . coerce

245−

246−instance MonadRef m => MonadRef (ProfiledM m) where

247− type Ref (ProfiledM m) = Ref m

248− newRef = lift . newRef

249− readRef = lift . readRef

250− writeRef r = lift . writeRef r

251−

252−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger (ProfiledTimeline t) (ProfiledM m) where

253− newEventWithTrigger = lift . fmap coerce . newEventWithTrigger

254− newFanEventWithTrigger f = do

255− es <- lift $ newFanEventWithTrigger f

256− return $ EventSelector $ \k -> coerce $ select es k

257−

258−instance MonadReader r m => MonadReader r (ProfiledM m) where

259− ask = lift ask

260− local f (ProfiledM a) = ProfiledM $ local f a

261− reader = lift . reader

262−

263−instance ReflexHost t => ReflexHost (ProfiledTimeline t) where

264− type EventTrigger (ProfiledTimeline t) = EventTrigger t

265− type EventHandle (ProfiledTimeline t) = EventHandle t

266− type HostFrame (ProfiledTimeline t) = ProfiledM (HostFrame t)

267−

268−instance MonadSubscribeEvent t m => MonadSubscribeEvent (ProfiledTimeline t) (ProfiledM m) where

269− subscribeEvent = lift . subscribeEvent . coerce

270−

271−instance PrimMonad m => PrimMonad (ProfiledM m) where

272− type PrimState (ProfiledM m) = PrimState m

273− primitive = lift . primitive

274−

275−instance MonadReflexHost t m => MonadReflexHost (ProfiledTimeline t) (ProfiledM m) where

276− type ReadPhase (ProfiledM m) = ProfiledM (ReadPhase m)

277− fireEventsAndRead ts r = lift $ fireEventsAndRead ts $ coerce r

278− runHostFrame = lift . runHostFrame . coerce

279−

280−instance MonadReadEvent t m => MonadReadEvent (ProfiledTimeline t) (ProfiledM m) where

281− readEvent = lift . fmap coerce . readEvent

src/Reflex/Pure.hs+30−58

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

5{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE TypeFamilies #-}

8−{-# LANGUAGE RankNTypes #-}

9−{-# LANGUAGE PolyKinds #-}

10−

11#ifdef USE_REFLEX_OPTIMIZER

8#ifdef USE_REFLEX_OPTIMIZER

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

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

13#endif

10#endif

@@ -16,13 +13,11 @@

16-- * MonadSample (Pure t) ((->) t)

13-- * MonadSample (Pure t) ((->) t)

17-- * MonadHold (Pure t) ((->) t)

14-- * MonadHold (Pure t) ((->) t)

18{-# OPTIONS_GHC -fno-warn-orphans #-}

15{-# OPTIONS_GHC -fno-warn-orphans #-}

19−-- |

16+

20−-- Module: Reflex.Pure

21−-- Description:

22−-- This module provides a pure implementation of Reflex, which is intended to

17+-- | This module provides a pure implementation of Reflex, which is intended to

23−-- serve as a reference for the semantics of the Reflex class. All

18+-- serve as a reference for the semantics of the Reflex class. All

24−-- implementations of Reflex should produce the same results as this

19+-- implementations of Reflex should produce the same results as this

25−-- implementation, although performance and laziness/strictness may differ.

20+-- implementation, although performance and laziness/strictness may differ.

26module Reflex.Pure

21module Reflex.Pure

27 ( Pure

22 ( Pure

28 , Behavior (..)

23 , Behavior (..)

@@ -31,26 +26,27 @@ module Reflex.Pure

31 , Incremental (..)

26 , Incremental (..)

32 ) where

27 ) where

29+#if !MIN_VERSION_base(4,8,0)

30+import Control.Applicative

31+#endif

32+

34import Control.Monad

33import Control.Monad

35−import Data.Dependent.Map (DMap)

34+import Data.Dependent.Map (DMap, GCompare)

36−import Data.GADT.Compare (GCompare)

37import qualified Data.Dependent.Map as DMap

35import qualified Data.Dependent.Map as DMap

38−import Data.IntMap (IntMap)

36+import Data.Functor.Identity

39−import qualified Data.IntMap as IntMap

40import Data.Maybe

37import Data.Maybe

41import Data.MemoTrie

38import Data.MemoTrie

42import Data.Monoid

39import Data.Monoid

43import Data.Type.Coercion

40import Data.Type.Coercion

44import Reflex.Class

41import Reflex.Class

45−import Data.Kind (Type)

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

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

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

44+-- with the type @t@.

49−data Pure (t :: Type)

45+data Pure t

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

47+-- | The Enum instance of t must be dense: for all x :: t, there must not exist

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

48+-- any y :: t such that pred x < y < x. The HasTrie instance will be used

53−-- exclusively to memoize functions of @/t/@, not for any of its other capabilities.

49+-- exclusively to memoize functions of t, not for any of its other capabilities.

54instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where

50instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where

56 newtype Behavior (Pure t) a = Behavior { unBehavior :: t -> a }

52 newtype Behavior (Pure t) a = Behavior { unBehavior :: t -> a }

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

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

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

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

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

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

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

82− -- being present in the original class definition.

78+ -- being present in the original class definition

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

80+ --merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity)

85− -- -> DMap k q -> Event (Pure t) (DMap k v)

86− mergeG nt events = Event $ memo $ \t ->

81+ merge events = Event $ memo $ \t ->

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

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

88 in if DMap.null currentOccurrences

83 in if DMap.null currentOccurrences

89 then Nothing

84 then Nothing

90 else Just currentOccurrences

85 else Just currentOccurrences

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

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

87+ fan :: GCompare k => Event (Pure t) (DMap k Identity) -> EventSelector (Pure t) k

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

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

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

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

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

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

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

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

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

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

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

116

110

117− mergeIncrementalG = mergeIncrementalImpl

111+ mergeIncremental = mergeIncrementalImpl

118− mergeIncrementalWithMoveG = mergeIncrementalImpl

112+ mergeIncrementalWithMove = mergeIncrementalImpl

119

113

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

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

121

115

@@ -130,28 +124,14 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where

130 behaviorCoercion Coercion = Coercion

124 behaviorCoercion Coercion = Coercion

131 eventCoercion Coercion = Coercion

125 eventCoercion Coercion = Coercion

132 dynamicCoercion Coercion = Coercion

126 dynamicCoercion Coercion = Coercion

133− incrementalCoercion Coercion Coercion = Coercion

134

127

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

136−

137− mergeIntIncremental = mergeIntIncrementalImpl

138−

139−mergeIncrementalImpl :: (PatchTarget p ~ DMap k q, GCompare k)

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

140− => (forall a. q a -> Event (Pure t) (v a))

141− -> Incremental (Pure t) p -> Event (Pure t) (DMap k v)

142−mergeIncrementalImpl nt i = Event $ \t ->

129+mergeIncrementalImpl i = Event $ \t ->

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

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

144 in if DMap.null results

131 in if DMap.null results

145 then Nothing

132 then Nothing

146 else Just results

133 else Just results

147

134

148−mergeIntIncrementalImpl :: (PatchTarget p ~ IntMap (Event (Pure t) a)) => Incremental (Pure t) p -> Event (Pure t) (IntMap a)

149−mergeIntIncrementalImpl i = Event $ \t ->

150− let results = IntMap.mapMaybeWithKey (\_ (Event e) -> e t) $ fst $ unIncremental i t

151− in if IntMap.null results

152− then Nothing

153− else Just results

154−

155instance Functor (Dynamic (Pure t)) where

135instance Functor (Dynamic (Pure t)) where

156 fmap f d = Dynamic $ \t -> let (cur, upd) = unDynamic d t

136 fmap f d = Dynamic $ \t -> let (cur, upd) = unDynamic d t

157 in (f cur, fmap f upd)

137 in (f cur, fmap f upd)

@@ -189,11 +169,9 @@ instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where

189 else let lastTime = pred sampleTime

169 else let lastTime = pred sampleTime

190 in fromMaybe (f lastTime) $ unEvent e lastTime

170 in fromMaybe (f lastTime) $ unEvent e lastTime

191

171

192− holdDyn v0 = buildDynamic (return v0)

193−

194− buildDynamic :: (t -> a) -> Event (Pure t) a -> t -> Dynamic (Pure t) a

172+ holdDyn :: a -> Event (Pure t) a -> t -> Dynamic (Pure t) a

195− buildDynamic initialValue e initialTime =

173+ holdDyn initialValue e initialTime =

196− let Behavior f = hold (initialValue initialTime) e initialTime

174+ let Behavior f = hold initialValue e initialTime

197 in Dynamic $ \t -> (f t, unEvent e t)

175 in Dynamic $ \t -> (f t, unEvent e t)

198

176

199 holdIncremental :: Patch p => PatchTarget p -> Event (Pure t) p -> t -> Incremental (Pure t) p

177 holdIncremental :: Patch p => PatchTarget p -> Event (Pure t) p -> t -> Incremental (Pure t) p

@@ -209,9 +187,3 @@ instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where

209 in case unEvent e lastTime of

187 in case unEvent e lastTime of

210 Nothing -> lastValue

188 Nothing -> lastValue

211 Just x -> fromMaybe lastValue $ apply x lastValue

189 Just x -> fromMaybe lastValue $ apply x lastValue

212−

213− headE = slowHeadE

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

215−

216−

217−

src/Reflex/Query/Base.hsdeleted−346

@@ -1,346 +0,0 @@

1−{-# LANGUAGE FlexibleInstances #-}

2−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3−{-# LANGUAGE InstanceSigs #-}

4−{-# LANGUAGE LambdaCase #-}

5−{-# LANGUAGE MultiParamTypeClasses #-}

6−{-# LANGUAGE RankNTypes #-}

7−{-# LANGUAGE ScopedTypeVariables #-}

8−{-# LANGUAGE TypeFamilies #-}

9−{-# LANGUAGE UndecidableInstances #-}

10−{-# LANGUAGE StandaloneDeriving #-}

11−

12−module Reflex.Query.Base

13− ( QueryT (..)

14− , runQueryT

15− , mapQuery

16− , mapQueryResult

17− , dynWithQueryT

18− , withQueryT

19− , mapQueryT

20− ) where

21−

22−import Control.Applicative (liftA2)

23−import Control.Monad.Exception

24−import Control.Monad.Fix

25−import Control.Monad.Morph

26−import Control.Monad.Primitive

27−import Control.Monad.Reader

28−import Control.Monad.Ref

29−import Control.Monad.State.Strict

30−import Data.Align

31−import Data.Dependent.Map (DMap)

32−import qualified Data.Dependent.Map as DMap

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

34−import Data.Foldable

35−import Data.Functor.Compose

36−import Data.Functor.Misc

37−import Data.GADT.Compare (GCompare)

38−import Data.IntMap (IntMap)

39−import qualified Data.IntMap as IntMap

40−import Data.Map (Map)

41−import qualified Data.Map as Map

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

43−import qualified Data.Semigroup as S

44−import Data.Some (Some(Some))

45−import Data.These

46−

47−import Reflex.Class

48−import Reflex.Adjustable.Class

49−import Reflex.DynamicWriter.Class

50−import Reflex.EventWriter.Base

51−import Reflex.EventWriter.Class

52−import Reflex.Host.Class

53−import qualified Data.Patch.MapWithMove as MapWithMove

54−import Reflex.PerformEvent.Class

55−import Reflex.PostBuild.Class

56−import Reflex.Query.Class

57−import Reflex.Requester.Class

58−import Reflex.TriggerEvent.Class

59−

60−newtype QueryT t q m a = QueryT { unQueryT :: StateT [Behavior t q] (EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m)) a }

61− deriving (Functor, Applicative, Monad, MonadException, MonadFix, MonadIO, MonadAtomicRef)

62−

63−deriving instance MonadHold t m => MonadHold t (QueryT t q m)

64−deriving instance MonadSample t m => MonadSample t (QueryT t q m)

65−

66−runQueryT :: (MonadFix m, Additive q, Group q, Reflex t) => QueryT t q m a -> Dynamic t (QueryResult q) -> m (a, Incremental t (AdditivePatch q))

67−runQueryT (QueryT a) qr = do

68− ((r, bs), es) <- runReaderT (runEventWriterT (runStateT a mempty)) qr

69− return (r, unsafeBuildIncremental (foldlM (\b c -> (b <>) <$> sample c) mempty bs) (fmapCheap AdditivePatch es))

70−

71−newtype QueryTLoweredResult t q v = QueryTLoweredResult (v, [Behavior t q])

72−

73−getQueryTLoweredResultValue :: QueryTLoweredResult t q v -> v

74−getQueryTLoweredResultValue (QueryTLoweredResult (v, _)) = v

75−

76−getQueryTLoweredResultWritten :: QueryTLoweredResult t q v -> [Behavior t q]

77−getQueryTLoweredResultWritten (QueryTLoweredResult (_, w)) = w

78−

79−maskMempty :: (Eq a, Monoid a) => a -> Maybe a

80−maskMempty x = if x == mempty then Nothing else Just x

81−

82−instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t m, Adjustable t m) => Adjustable t (QueryT t q m) where

83− runWithReplace (QueryT a0) a' = do

84− ((r0, bs0), r') <- QueryT $ lift $ runWithReplace (runStateT a0 []) $ fmapCheap (flip runStateT [] . unQueryT) a'

85− let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q

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

87− bs' = fmapCheap snd $ r'

88− bbs <- hold bs0 bs'

89− let patches = flip pushCheap bs' $ \newBs -> do

90− oldBs <- sample bbs

91− maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)

92− QueryT $ modify $ (:) $ pull $ sampleBs =<< sample bbs

93− QueryT $ lift $ tellEvent patches

94− return (r0, fmapCheap fst r')

95−

96− traverseIntMapWithKeyWithAdjust :: forall v v'. (IntMap.Key -> v -> QueryT t q m v') -> IntMap v -> Event t (PatchIntMap v) -> QueryT t q m (IntMap v', Event t (PatchIntMap v'))

97− traverseIntMapWithKeyWithAdjust f im0 im' = do

98− let f' :: IntMap.Key -> v -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (QueryTLoweredResult t q v')

99− f' k v = fmap QueryTLoweredResult $ flip runStateT [] $ unQueryT $ f k v

100− (result0, result') <- QueryT $ lift $ traverseIntMapWithKeyWithAdjust f' im0 im'

101− let liftedResult0 = IntMap.map getQueryTLoweredResultValue result0

102− liftedResult' = fforCheap result' $ \(PatchIntMap p) -> PatchIntMap $

103− IntMap.map (fmap getQueryTLoweredResultValue) p

104− liftedBs0 :: IntMap [Behavior t q]

105− liftedBs0 = IntMap.map getQueryTLoweredResultWritten result0

106− liftedBs' :: Event t (PatchIntMap [Behavior t q])

107− liftedBs' = fforCheap result' $ \(PatchIntMap p) -> PatchIntMap $

108− IntMap.map (fmap getQueryTLoweredResultWritten) p

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

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

111− accumBehaviors :: forall m'. MonadHold t m'

112− => IntMap [Behavior t q]

113− -> PatchIntMap [Behavior t q]

114− -> m' ( Maybe (IntMap [Behavior t q])

115− , Maybe (AdditivePatch q))

116− -- f accumulates the child behavior state we receive from running traverseIntMapWithKeyWithAdjust for the underlying monad.

117− -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.

118− -- bs0 is a Map denoting the behaviors of the current children.

119− -- pbs is a PatchMap denoting an update to the behaviors of the current children

120− accumBehaviors bs0 pbs@(PatchIntMap bs') = do

121− let p k bs = case IntMap.lookup k bs0 of

122− Nothing -> case bs of

123− -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.

124− Nothing -> return mempty

125− -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.

126− Just newBs -> sampleBs newBs

127− Just oldBs -> case bs of

128− -- If the update is to delete the state for a child that already exists, the patch is the negation of the child's current state

129− Nothing -> negateG <$> sampleBs oldBs

130− -- If the update is to update the state for a child that already exists, the patch is the negation of sampling the child's current state

131− -- composed with the sampling the child's new state.

132− Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs

133− -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the

134− -- child patches and wrap them in AdditivePatch.

135− patch <- AdditivePatch . fold <$> IntMap.traverseWithKey p bs'

136− return (apply pbs bs0, Just patch)

137− (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'

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

139− return (liftedResult0, liftedResult')

140−

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

142− traverseDMapWithKeyWithAdjust f dm0 dm' = do

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

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

145− (result0, result') <- QueryT $ lift $ traverseDMapWithKeyWithAdjust f' dm0 dm'

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

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

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

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

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

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

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

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

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

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

156− accumBehaviors :: forall m'. MonadHold t m'

157− => Map (Some k) [Behavior t q]

158− -> PatchMap (Some k) [Behavior t q]

159− -> m' ( Maybe (Map (Some k) [Behavior t q])

160− , Maybe (AdditivePatch q))

161− -- f accumulates the child behavior state we receive from running traverseDMapWithKeyWithAdjust for the underlying monad.

162− -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.

163− -- bs0 is a Map denoting the behaviors of the current children.

164− -- pbs is a PatchMap denoting an update to the behaviors of the current children

165− accumBehaviors bs0 pbs@(PatchMap bs') = do

166− let p k bs = case Map.lookup k bs0 of

167− Nothing -> case bs of

168− -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.

169− Nothing -> return Nothing

170− -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.

171− Just newBs -> maskMempty <$> sampleBs newBs

172− Just oldBs -> case bs of

173− -- If the update is to delete the state for a child that already exists, the patch is the negation of the child's current state

174− Nothing -> maskMempty . negateG <$> sampleBs oldBs

175− -- If the update is to update the state for a child that already exists, the patch is the negation of sampling the child's current state

176− -- composed with the sampling the child's new state.

177− Just newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)

178− -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the

179− -- child patches and wrap them in AdditivePatch.

180− patch <- fold <$> Map.traverseWithKey p bs'

181− return (apply pbs bs0, AdditivePatch <$> patch)

182− (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'

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

184− return (liftedResult0, liftedResult')

185−

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

187− traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do

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

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

190− (result0, result') <- QueryT $ lift $ traverseDMapWithKeyWithAdjustWithMove f' dm0 dm'

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

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

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

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

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

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

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

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

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

200− accumBehaviors' :: forall m'. MonadHold t m'

201− => Map (Some k) [Behavior t q]

202− -> PatchMapWithMove (Some k) [Behavior t q]

203− -> m' ( Maybe (Map (Some k) [Behavior t q])

204− , Maybe (AdditivePatch q))

205− -- f accumulates the child behavior state we receive from running traverseDMapWithKeyWithAdjustWithMove for the underlying monad.

206− -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.

207− -- bs0 is a Map denoting the behaviors of the current children.

208− -- pbs is a PatchMapWithMove denoting an update to the behaviors of the current children

209− accumBehaviors' bs0 pbs = do

210− let bs' = unPatchMapWithMove pbs

211− p k bs = case Map.lookup k bs0 of

212− Nothing -> case MapWithMove._nodeInfo_from bs of

213− -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.

214− MapWithMove.From_Delete -> return Nothing

215− -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.

216− MapWithMove.From_Insert newBs -> maskMempty <$> sampleBs newBs

217− MapWithMove.From_Move k' -> case Map.lookup k' bs0 of

218− Nothing -> return Nothing

219− Just newBs -> maskMempty <$> sampleBs newBs

220− Just oldBs -> case MapWithMove._nodeInfo_from bs of

221− -- If the update is to delete the state for a child that already exists, the patch is the negation of the child's current state

222− MapWithMove.From_Delete -> maskMempty . negateG <$> sampleBs oldBs

223− -- If the update is to update the state for a child that already exists, the patch is the negation of sampling the child's current state

224− -- composed with the sampling the child's new state.

225− MapWithMove.From_Insert newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)

226− MapWithMove.From_Move k'

227− | k' == k -> return Nothing

228− | otherwise -> case Map.lookup k' bs0 of

229− -- If we are moving from a non-existent key, that is a delete

230− Nothing -> maskMempty . negateG <$> sampleBs oldBs

231− Just newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)

232− -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the

233− -- child patches and wrap them in AdditivePatch.

234− patch <- fold <$> Map.traverseWithKey p bs'

235− return (apply pbs bs0, AdditivePatch <$> patch)

236− (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors' liftedBs0 liftedBs'

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

238− return (liftedResult0, liftedResult')

239−

240−instance MonadTrans (QueryT t q) where

241− lift = QueryT . lift . lift . lift

242−

243−instance MFunctor (QueryT t q) where

244− hoist = mapQueryT

245−

246−instance PrimMonad m => PrimMonad (QueryT t q m) where

247− type PrimState (QueryT t q m) = PrimState m

248− primitive = lift . primitive

249−

250−instance PostBuild t m => PostBuild t (QueryT t q m) where

251− getPostBuild = lift getPostBuild

252−

253−instance (MonadAsyncException m) => MonadAsyncException (QueryT t q m) where

254− mask f = QueryT $ mask $ \unMask -> unQueryT $ f $ QueryT . unMask . unQueryT

255−

256−instance TriggerEvent t m => TriggerEvent t (QueryT t q m) where

257− newTriggerEvent = lift newTriggerEvent

258− newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

259− newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

260−

261−instance PerformEvent t m => PerformEvent t (QueryT t q m) where

262− type Performable (QueryT t q m) = Performable m

263− performEvent_ = lift . performEvent_

264− performEvent = lift . performEvent

265−

266−instance MonadRef m => MonadRef (QueryT t q m) where

267− type Ref (QueryT t q m) = Ref m

268− newRef = QueryT . newRef

269− readRef = QueryT . readRef

270− writeRef r = QueryT . writeRef r

271−

272−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (QueryT t q m) where

273− newEventWithTrigger = QueryT . newEventWithTrigger

274− newFanEventWithTrigger a = QueryT . lift $ newFanEventWithTrigger a

275−

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

277−instance (Monoid a, Monad m) => Monoid (QueryT t q m a) where

278− mempty = pure mempty

279− mappend = (<>)

280−

281−instance (S.Semigroup a, Monad m) => S.Semigroup (QueryT t q m a) where

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

283−

284−-- | withQueryT's QueryMorphism argument needs to be a group homomorphism in order to behave correctly

285−withQueryT :: (MonadFix m, PostBuild t m, Group q, Group q', Additive q, Additive q', Query q')

286− => QueryMorphism q q'

287− -> QueryT t q m a

288− -> QueryT t q' m a

289−withQueryT f a = do

290− r' <- askQueryResult

291− (result, q) <- lift $ runQueryT a $ mapQueryResult f <$> r'

292− tellQueryIncremental $ unsafeBuildIncremental

293− (fmap (mapQuery f) (sample (currentIncremental q)))

294− (fmapCheap (AdditivePatch . mapQuery f . unAdditivePatch) $ updatedIncremental q)

295− return result

296−

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

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

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

300−

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

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

303− => Dynamic t (QueryMorphism q q')

304− -> QueryT t q m a

305− -> QueryT t q' m a

306−dynWithQueryT f q = do

307− r' <- askQueryResult

308− (result, q') <- lift $ runQueryT q $ zipDynWith mapQueryResult f r'

309− tellQueryIncremental $ zipDynIncrementalWith mapQuery f q'

310− return result

311− where zipDynIncrementalWith g da ib =

312− let eab = align (updated da) (updatedIncremental ib)

313− ec = flip push eab $ \case

314− This a -> do

315− aOld <- sample $ current da

316− b <- sample $ currentIncremental ib

317− return $ Just $ AdditivePatch (g a b ~~ g aOld b)

318− That (AdditivePatch b) -> do

319− a <- sample $ current da

320− return $ Just $ AdditivePatch $ g a b

321− These a (AdditivePatch b) -> do

322− aOld <- sample $ current da

323− bOld <- sample $ currentIncremental ib

324− return $ Just $ AdditivePatch $ mconcat [ g a bOld, negateG (g aOld bOld), g a b]

325− in unsafeBuildIncremental (g <$> sample (current da) <*> sample (currentIncremental ib)) ec

326−

327−instance (Monad m, Group q, Additive q, Query q, Reflex t) => MonadQuery t q (QueryT t q m) where

328− tellQueryIncremental q = do

329− QueryT (modify (currentIncremental q:))

330− QueryT (lift (tellEvent (fmapCheap unAdditivePatch (updatedIncremental q))))

331− askQueryResult = QueryT ask

332− queryIncremental q = do

333− tellQueryIncremental q

334− zipDynWith crop (incrementalToDynamic q) <$> askQueryResult

335−

336−instance Requester t m => Requester t (QueryT t q m) where

337− type Request (QueryT t q m) = Request m

338− type Response (QueryT t q m) = Response m

339− requesting = lift . requesting

340− requesting_ = lift . requesting_

341−

342−instance EventWriter t w m => EventWriter t w (QueryT t q m) where

343− tellEvent = lift . tellEvent

344−

345−instance DynamicWriter t w m => DynamicWriter t w (QueryT t q m) where

346− tellDyn = lift . tellDyn

src/Reflex/Query/Class.hsdeleted−158

@@ -1,158 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveDataTypeable #-}

3−{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE FlexibleInstances #-}

5−{-# LANGUAGE FunctionalDependencies #-}

6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7−{-# LANGUAGE TypeFamilies #-}

8−{-# LANGUAGE UndecidableInstances #-}

9−-- |

10−-- Module:

11−-- Reflex.Query.Class

12−-- Description:

13−-- A class that ties together queries to some data source and their results,

14−-- providing methods for requesting data from the source and accumulating

15−-- streamed results.

16−module Reflex.Query.Class

17− ( Query (..)

18− , QueryMorphism (..)

19− , SelectedCount (..)

20− , combineSelectedCounts

21−

22− , MonadQuery (..)

23− , tellQueryDyn

24− , queryDyn

25− , subQuery

26− , mapQuery

27− , mapQueryResult

28− ) where

29−

30−import Control.Category (Category)

31−import qualified Control.Category as Cat

32−import Control.Monad.Reader

33−import Data.Bits

34−import Data.Data

35−import Data.Ix

36−import Data.Map.Monoidal (MonoidalMap)

37−import qualified Data.Map.Monoidal as MonoidalMap

38−import Data.Semigroup (Semigroup(..))

39−import Foreign.Storable

40−import Data.Void

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

42−import Control.Applicative

43−

44−import Reflex.Class

45−

46−-- | A 'Query' can be thought of as a declaration of interest in some set of data.

47−-- A 'QueryResult' is the set of data associated with that interest set.

48−-- The @crop@ function provides a way to determine what part of a given 'QueryResult'

49−-- is relevant to a given 'Query'.

50−class (Monoid (QueryResult a), Semigroup (QueryResult a)) => Query a where

51− type QueryResult a :: *

52− crop :: a -> QueryResult a -> QueryResult a

53−

54−instance (Ord k, Query v) => Query (MonoidalMap k v) where

55− type QueryResult (MonoidalMap k v) = MonoidalMap k (QueryResult v)

56− crop q r = MonoidalMap.intersectionWith (flip crop) r q

57−

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

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

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

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

62−

63−-- | Trivial queries have trivial results.

64−instance Query () where

65− type QueryResult () = ()

66− crop _ _ = ()

67−

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

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

70−--

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

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

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

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

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

76−-- uninhabited as desired.

77−instance Query Void where

78− type QueryResult Void = ()

79− crop = absurd

80−

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

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

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

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

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

86− crop = liftA2 crop

87−#endif

88−

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

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

91−data QueryMorphism q q' = QueryMorphism

92− { _queryMorphism_mapQuery :: q -> q'

93− , _queryMorphism_mapQueryResult :: QueryResult q' -> QueryResult q

94− }

95−

96−instance Category QueryMorphism where

97− id = QueryMorphism id id

98− qm . qm' = QueryMorphism

99− { _queryMorphism_mapQuery = mapQuery qm . mapQuery qm'

100− , _queryMorphism_mapQueryResult = mapQueryResult qm' . mapQueryResult qm

101− }

102−

103−-- | Apply a 'QueryMorphism' to a 'Query'

104−mapQuery :: QueryMorphism q q' -> q -> q'

105−mapQuery = _queryMorphism_mapQuery

106−

107−-- | Map a 'QueryMorphism' to a 'QueryResult'

108−mapQueryResult :: QueryMorphism q q' -> QueryResult q' -> QueryResult q

109−mapQueryResult = _queryMorphism_mapQueryResult

110−

111−-- | This type can be used to track of the frequency of interest in a given 'Query'. See note on

112−-- 'combineSelectedCounts'

113−newtype SelectedCount = SelectedCount { unSelectedCount :: Int }

114− deriving (Eq, Ord, Show, Read, Integral, Num, Bounded, Enum, Real, Ix, Bits, FiniteBits, Storable, Data)

115−

116−instance Semigroup SelectedCount where

117− SelectedCount a <> SelectedCount b = SelectedCount (a + b)

118−

119−instance Monoid SelectedCount where

120− mempty = SelectedCount 0

121− mappend = (<>)

122−

123−instance Group SelectedCount where

124− negateG (SelectedCount a) = SelectedCount (negate a)

125−

126−instance Additive SelectedCount

127−

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

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

130−-- of the 'Query' that are no longer wanted.

131−combineSelectedCounts :: SelectedCount -> SelectedCount -> Maybe SelectedCount

132−combineSelectedCounts (SelectedCount i) (SelectedCount j) = if i == negate j then Nothing else Just $ SelectedCount (i + j)

133−

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

135−-- used interface.

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

137− tellQueryIncremental :: Incremental t (AdditivePatch q) -> m ()

138− askQueryResult :: m (Dynamic t (QueryResult q))

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

140−

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

142− tellQueryIncremental = lift . tellQueryIncremental

143− askQueryResult = lift askQueryResult

144− queryIncremental = lift . queryIncremental

145−

146−-- | Produce and send an 'Incremental' 'Query' from a 'Dynamic' 'Query'.

147−tellQueryDyn :: (Reflex t, MonadQuery t q m) => Dynamic t q -> m ()

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

149−

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

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

152−queryDyn q = do

153− tellQueryDyn q

154− zipDynWith crop q <$> askQueryResult

155−

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

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

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

src/Reflex/Requester/Base.hs+51−507

@@ -1,373 +1,84 @@

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

2-- 'Requester'.

3−{-# LANGUAGE AllowAmbiguousTypes #-}

3+{-# LANGUAGE BangPatterns #-}

4−{-# LANGUAGE ApplicativeDo #-}

5{-# LANGUAGE CPP #-}

4{-# LANGUAGE CPP #-}

6−{-# LANGUAGE EmptyDataDecls #-}

7{-# LANGUAGE ExistentialQuantification #-}

5{-# LANGUAGE ExistentialQuantification #-}

8{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE FlexibleInstances #-}

9−{-# LANGUAGE GADTs #-}

10{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7{-# LANGUAGE GeneralizedNewtypeDeriving #-}

11{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

12{-# LANGUAGE Rank2Types #-}

9{-# LANGUAGE Rank2Types #-}

13−{-# LANGUAGE RecursiveDo #-}

14{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE ScopedTypeVariables #-}

15−{-# LANGUAGE StandaloneDeriving #-}

16{-# LANGUAGE TypeFamilies #-}

11{-# LANGUAGE TypeFamilies #-}

17−{-# LANGUAGE TypeOperators #-}

18{-# LANGUAGE UndecidableInstances #-}

12{-# LANGUAGE UndecidableInstances #-}

13+{-# LANGUAGE StandaloneDeriving #-}

19#ifdef USE_REFLEX_OPTIMIZER

14#ifdef USE_REFLEX_OPTIMIZER

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

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

21#endif

16#endif

22module Reflex.Requester.Base

17module Reflex.Requester.Base

23 ( RequesterT (..)

18 ( RequesterT (..)

24 , runRequesterT

19 , runRequesterT

25− , withRequesterT

26 , runWithReplaceRequesterTWith

20 , runWithReplaceRequesterTWith

27− , traverseIntMapWithKeyWithAdjustRequesterTWith

21+ , sequenceDMapWithAdjustRequesterTWith

28− , traverseDMapWithKeyWithAdjustRequesterTWith

29− , RequesterData

30− , RequesterDataKey

31− , traverseRequesterData

32− , forRequesterData

33− , requesterDataToList

34− , singletonRequesterData

35− , matchResponsesWithRequests

36− , matchResponseMapWithRequests

37− , multiEntry

38− , unMultiEntry

39− , requesting'

40 ) where

22 ) where

42import Reflex.Class

24import Reflex.Class

43−import Reflex.Adjustable.Class

25+import Reflex.EventWriter

44−import Reflex.Dynamic

45import Reflex.Host.Class

26import Reflex.Host.Class

46import Reflex.PerformEvent.Class

27import Reflex.PerformEvent.Class

47import Reflex.PostBuild.Class

28import Reflex.PostBuild.Class

48import Reflex.Requester.Class

29import Reflex.Requester.Class

49import Reflex.TriggerEvent.Class

30import Reflex.TriggerEvent.Class

51−import Control.Applicative (liftA2)

52import Control.Monad.Exception

32import Control.Monad.Exception

53import Control.Monad.Identity

33import Control.Monad.Identity

54−import Control.Monad.Morph

55import Control.Monad.Primitive

34import Control.Monad.Primitive

56import Control.Monad.Reader

35import Control.Monad.Reader

57import Control.Monad.Ref

36import Control.Monad.Ref

58import Control.Monad.State.Strict

37import Control.Monad.State.Strict

59−import Data.Bits

60import Data.Coerce

38import Data.Coerce

61−import Data.Constraint

62−import Data.Dependent.Map (DMap)

39+import Data.Dependent.Map (DMap, DSum (..))

63import qualified Data.Dependent.Map as DMap

40import qualified Data.Dependent.Map as DMap

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

65−import Data.Functor.Compose

66import Data.Functor.Misc

41import Data.Functor.Misc

67−import Data.IntMap.Strict (IntMap)

68−import qualified Data.IntMap.Strict as IntMap

69import Data.Map (Map)

42import Data.Map (Map)

70−import qualified Data.Map as Map

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

72−import Data.Proxy

73−import qualified Data.Semigroup as S

74−import Data.Some (Some(Some))

75−import Data.Type.Equality

76import Data.Unique.Tag

43import Data.Unique.Tag

77−

44+import Data.Some (Some)

78−import GHC.Exts (Any)

79−import Unsafe.Coerce

80−

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

82−

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

84−

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

86−

87−emptyRequesterData :: RequesterData f

88−emptyRequesterData = RequesterData $ TagMap IntMap.empty

89−

90−data RequesterDataKey a where

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

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

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

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

95−

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

97−singletonRequesterData rdk v = case rdk of

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

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

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

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

102− , _multi2Contents_dict = Dict

103− }

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

105−

106−mergeRequesterData :: RequesterData f -> RequesterData f -> RequesterData f

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

108−

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

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

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

112− where

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

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

115− MyTagType_Single -> a

116− MyTagType_Multi -> IntMap.unionWith mergeRequesterData a b

117− MyTagType_Multi2 -> case _multi2Contents_dict a of

118− Dict -> Multi2Contents

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

120− , _multi2Contents_dict = Dict

121− }

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

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

124− g' f rawKey a b =

125− let k = MyTag rawKey :: MyTag a

126− fromAny :: Any -> Entry f a

127− fromAny = unsafeCoerce

128− toAny :: Entry f a -> Any

129− toAny = unsafeCoerce

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

131−

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

133−requesterDataToList (RequesterData m) = do

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

135− case myKeyType k of

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

137− MyTagType_Multi -> do

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

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

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

141− MyTagType_Multi2 -> case _multi2Contents_dict e of

142− Dict -> do

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

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

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

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

147− MyTagType_Multi3 -> do

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

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

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

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

152−

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

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

155−

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

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

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

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

160−

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

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

163− where

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

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

166−

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

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

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

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

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

172− MyTagType_Single -> f request

173− MyTagType_Multi -> traverse (traverseRequesterData f) request

174− MyTagType_Multi2 -> case request of

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

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

177− pure $ Multi2Contents

178− { _multi2Contents_values = v

179− , _multi2Contents_dict = Dict

180− }

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

182−

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

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

185−forRequesterData r f = traverseRequesterData f r

186−

187−data MyTagType :: * -> * where

188− MyTagType_Single :: MyTagType (Single a)

189− MyTagType_Multi :: MyTagType Multi

190− MyTagType_Multi2 :: MyTagType (Multi2 k)

191− MyTagType_Multi3 :: MyTagType Multi3

192−

193−myKeyType :: MyTag x -> MyTagType x

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

195− 0x0 -> unsafeCoerce MyTagType_Single

196− 0x1 -> unsafeCoerce MyTagType_Multi

197− 0x2 -> unsafeCoerce MyTagType_Multi2

198− 0x3 -> unsafeCoerce MyTagType_Multi3

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

200−

201−data Single a

202−data Multi

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

204−data Multi3

205−

206−class MyTagTypeOffset x where

207− myTagTypeOffset :: proxy x -> Int

208−

209−instance MyTagTypeOffset (Single a) where

210− myTagTypeOffset _ = 0x0

211−

212−instance MyTagTypeOffset Multi where

213− myTagTypeOffset _ = 0x1

214−

215−instance MyTagTypeOffset (Multi2 k) where

216− myTagTypeOffset _ = 0x2

217−

218−instance MyTagTypeOffset Multi3 where

219− myTagTypeOffset _ = 0x3

220−

221−type family EntryContents request a where

222− EntryContents request (Single a) = request a

223− EntryContents request Multi = IntMap (RequesterData request)

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

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

226−

227−data Multi2Contents k request = Multi2Contents

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

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

230− }

231−

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

233−

234−{-# INLINE singleEntry #-}

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

236−singleEntry = Entry

237−

238−{-# INLINE multiEntry #-}

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

240−multiEntry = Entry

241−

242−{-# INLINE unMultiEntry #-}

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

244−unMultiEntry = unEntry

245−

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

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

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

249−

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

251−

252−{-# INLINE castMyTagWrap #-}

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

254−castMyTagWrap = coerce

255−

256−instance GEq MyTag where

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

258− if a == b

259− then Just $ unsafeCoerce Refl

260− else Nothing

261−

262−instance GCompare MyTag where

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

264− case a `compare` b of

265− LT -> GLT

266− EQ -> unsafeCoerce GEQ

267− GT -> GGT

268−

269−instance GEq (MyTagWrap f) where

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

271− if a == b

272− then Just $ unsafeCoerce Refl

273− else Nothing

274−

275−instance GCompare (MyTagWrap f) where

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

277− case a `compare` b of

278− LT -> GLT

279− EQ -> unsafeCoerce GEQ

280− GT -> GGT

281−

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

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

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

285− }

286

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

46-- | A basic implementation of 'Requester'.

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

47+newtype RequesterT t request response m a = RequesterT { unRequesterT :: EventWriterT t (DMap (Tag (PrimState m)) request) (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m) a }

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

48+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException)

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

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

292− , MonadAsyncException

293−#endif

294− )

295

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

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

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

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

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

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

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

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

300

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

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

303− primitive = lift . primitive

304−

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

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

307− mempty = pure mempty

308− mappend = liftA2 mappend

309−

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

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

312−

313−

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

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

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

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

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

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

317-- requests were issued.

58-- requests were issued.

59+

318runRequesterT :: (Reflex t, Monad m)

60runRequesterT :: (Reflex t, Monad m)

319 => RequesterT t request response m a

61 => RequesterT t request response m a

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

62+ -> Event t (DMap (Tag (PrimState m)) response)

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

63+ -> m (a, Event t (DMap (Tag (PrimState m)) request))

322runRequesterT (RequesterT a) responses = do

64runRequesterT (RequesterT a) responses = do

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

65+ (result, requests) <- runReaderT (runEventWriterT a) $ fan $

324− coerceEvent responses

66+ mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e) <$> responses

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

67+ return (result, requests)

326−

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

328−withRequesterT

329− :: (Reflex t, MonadFix m)

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

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

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

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

334−withRequesterT freq frsp child = do

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

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

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

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

339− return a

340

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

69+instance (Reflex t, PrimMonad m) => Requester t (RequesterT t request response m) where

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

70 type Request (RequesterT t request response m) = request

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

71 type Response (RequesterT t request response m) = response

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

72+ withRequesting a = do

345− requesting_ = void . tagRequest . fmapCheap singleEntry

73+ !t <- lift newTag --TODO: Fix this upstream

346−

347−{-# INLINE tagRequest #-}

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

349−tagRequest req = do

350− old <- RequesterT get

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

352− t = MyTagWrap n

353− RequesterT $ put $ RequesterState

354− { _requesterState_nextMyTag = _requesterState_nextMyTag old - 0x4

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

356− }

357− return t

358−

359−{-# INLINE responseFromTag #-}

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

361−responseFromTag (MyTagWrap t) = do

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

74+ s <- RequesterT ask

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

75+ (req, result) <- a $ select s $ WrapArg t

76+ RequesterT $ tellEvent $ fmapCheap (DMap.singleton t) req

77+ return result

364

365instance MonadTrans (RequesterT t request response) where

79instance MonadTrans (RequesterT t request response) where

366 lift = RequesterT . lift . lift

80 lift = RequesterT . lift . lift

367

368−instance MFunctor (RequesterT t request response) where

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

370−

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

82instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where

372 type Performable (RequesterT t request response m) = Performable m

83 type Performable (RequesterT t request response m) = Performable m

373 performEvent_ = lift . performEvent_

84 performEvent_ = lift . performEvent_

@@ -385,88 +96,34 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT

385

386instance MonadReader r m => MonadReader r (RequesterT t request response m) where

97instance MonadReader r m => MonadReader r (RequesterT t request response m) where

387 ask = lift ask

98 ask = lift ask

388− local f (RequesterT a) = RequesterT $ mapStateT (mapReaderT $ local f) a

99+ local f (RequesterT (EventWriterT a)) = RequesterT $ EventWriterT $ mapStateT (mapReaderT $ local f) a

389 reader = lift . reader

100 reader = lift . reader

390

101

391−instance (Reflex t, Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (RequesterT t request response m) where

102+instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (RequesterT t request response m) where

392− runWithReplace = runWithReplaceRequesterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'

103+ runWithReplace (RequesterT a) em = RequesterT $ runWithReplace a (coerceEvent em)

393− traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElementsMap mergeIntIncremental

104+ traverseDMapWithKeyWithAdjust f dm edm = RequesterT $ traverseDMapWithKeyWithAdjust (\k v -> unRequesterT $ f k v) (coerce dm) (coerceEvent edm)

394− {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

395− traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental

396− traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove

105+ traverseDMapWithKeyWithAdjustWithMove f dm edm = RequesterT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unRequesterT $ f k v) (coerce dm) (coerceEvent edm)

397−

398−requesting' :: (MyTagTypeOffset x, Monad m) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x))

399−requesting' = responseFromTag . castMyTagWrap <=< tagRequest

400

106

401−{-# INLINABLE runWithReplaceRequesterTWith #-}

402−runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m

107+runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m)

403− , MonadFix m

404− )

405 => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))

108 => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))

406 -> RequesterT t request response m a

109 -> RequesterT t request response m a

407 -> Event t (RequesterT t request response m b)

110 -> Event t (RequesterT t request response m b)

408 -> RequesterT t request response m (a, Event t b)

111 -> RequesterT t request response m (a, Event t b)

409−runWithReplaceRequesterTWith f a0 a' = do

112+runWithReplaceRequesterTWith f a0 a' =

410− rec na' <- numberOccurrencesFrom 1 a'

113+ let f' :: forall a' b'. ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m a'

411− responses <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here

114+ -> Event t (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m b')

412− let responses' = fanInt responses

115+ -> EventWriterT t (DMap (Tag (PrimState m)) request) (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m) (a', Event t b')

413− ((result0, requests0), v') <- f (runRequesterT a0 (selectInt responses' 0)) $ fmapCheap (\(n, a) -> fmap ((,) n) $ runRequesterT a $ selectInt responses' n) na'

116+ f' x y = do

414− requests <- holdDyn (fmapCheap (IntMap.singleton 0) requests0) $ fmapCheap (\(n, (_, reqs)) -> fmapCheap (IntMap.singleton n) reqs) v'

117+ r <- EventWriterT $ ask

415− return (result0, fmapCheap (fst . snd) v')

118+ unRequesterT (f (runReaderT x r) (fmapCheap (`runReaderT` r) y))

416−

119+ in RequesterT $ runWithReplaceEventWriterTWith f' (coerce a0) (coerceEvent a')

417−{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}

120+

418−traverseIntMapWithKeyWithAdjustRequesterTWith :: forall t request response m v v' p.

121+sequenceDMapWithAdjustRequesterTWith :: forall k t request response m v v' p p'.

419− ( Reflex t

420− , MonadHold t m

421− , PatchTarget (p (Event t (IntMap (RequesterData request)))) ~ IntMap (Event t (IntMap (RequesterData request)))

422− , Patch (p (Event t (IntMap (RequesterData request))))

423− , Functor p

424− , MonadFix m

425− )

426− => ( (IntMap.Key -> (IntMap.Key, v) -> m (Event t (IntMap (RequesterData request)), v'))

427− -> IntMap (IntMap.Key, v)

428− -> Event t (p (IntMap.Key, v))

429− -> RequesterT t request response m (IntMap (Event t (IntMap (RequesterData request)), v'), Event t (p (Event t (IntMap (RequesterData request)), v')))

430− )

431− -> (p (Event t (IntMap (RequesterData request))) -> IntMap (Event t (IntMap (RequesterData request))))

432− -> (Incremental t (p (Event t (IntMap (RequesterData request)))) -> Event t (IntMap (IntMap (RequesterData request))))

433− -> (IntMap.Key -> v -> RequesterT t request response m v')

434− -> IntMap v

435− -> Event t (p v)

436− -> RequesterT t request response m (IntMap v', Event t (p v'))

437−traverseIntMapWithKeyWithAdjustRequesterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do

438− rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here

439− let responses :: EventSelectorInt t (IntMap (RequesterData response))

440− responses = fanInt $ fmapCheap unpack response

441− unpack :: Entry response Multi3 -> IntMap (IntMap (RequesterData response))

442− unpack = unEntry

443− pack :: IntMap (IntMap (RequesterData request)) -> Entry request Multi3

444− pack = Entry

445− f' :: IntMap.Key -> (Int, v) -> m (Event t (IntMap (RequesterData request)), v')

446− f' k (n, v) = do

447− (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ selectInt responses k --TODO: Instead of doing mapMaybeCheap, can we share a fanInt across all instances of a given key, or at least the ones that are adjacent in time?

448− return (fmapCheap (IntMap.singleton n) myRequests, result)

449− ndm' <- numberOccurrencesFrom 1 dm'

450− (children0, children') <- base f' (fmap ((,) 0) dm0) $ fmap (\(n, dm) -> fmap ((,) n) dm) ndm' --TODO: Avoid this somehow, probably by adding some sort of per-cohort information passing to Adjustable

451− let result0 = fmap snd children0

452− result' = fforCheap children' $ fmap snd

453− requests0 :: IntMap (Event t (IntMap (RequesterData request)))

454− requests0 = fmap fst children0

455− requests' :: Event t (p (Event t (IntMap (RequesterData request))))

456− requests' = fforCheap children' $ fmap fst

457− promptRequests :: Event t (IntMap (IntMap (RequesterData request)))

458− promptRequests = coincidence $ fmapCheap (mergeInt . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'

459− requests <- holdIncremental requests0 requests'

460− return (result0, result')

461−

462−{-# INLINE traverseDMapWithKeyWithAdjustRequesterTWith #-}

463−traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v' p p'.

464 ( GCompare k

122 ( GCompare k

465 , Reflex t

123 , Reflex t

466 , MonadHold t m

124 , MonadHold t m

467− , PatchTarget (p' (Some k) (Event t (IntMap (RequesterData request)))) ~ Map (Some k) (Event t (IntMap (RequesterData request)))

125+ , PatchTarget (p' (Some k) (Event t (DMap (Tag (PrimState m)) request))) ~ Map (Some k) (Event t (DMap (Tag (PrimState m)) request))

468− , Patch (p' (Some k) (Event t (IntMap (RequesterData request))))

126+ , Patch (p' (Some k) (Event t (DMap (Tag (PrimState m)) request)))

469− , MonadFix m

470 )

127 )

471 => (forall k' v1 v2. GCompare k'

128 => (forall k' v1 v2. GCompare k'

472 => (forall a. k' a -> v1 a -> m (v2 a))

129 => (forall a. k' a -> v1 a -> m (v2 a))

@@ -474,134 +131,21 @@ traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v

474 -> Event t (p k' v1)

131 -> Event t (p k' v1)

475 -> RequesterT t request response m (DMap k' v2, Event t (p k' v2))

132 -> RequesterT t request response m (DMap k' v2, Event t (p k' v2))

476 )

133 )

477− -> (forall v1 v2. (forall a. v1 a -> v2 a) -> p k v1 -> p k v2)

134+ -> (forall v1. (forall a. v1 a -> v' a) -> p k v1 -> p k v')

478 -> (forall v1 v2. (forall a. v1 a -> v2) -> p k v1 -> p' (Some k) v2)

135 -> (forall v1 v2. (forall a. v1 a -> v2) -> p k v1 -> p' (Some k) v2)

479− -> (forall v2. p' (Some k) v2 -> Map (Some k) v2)

136+ -> (forall v2. p' (Some k) v2 -> [v2])

480 -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a))

137 -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a))

481 -> (forall a. k a -> v a -> RequesterT t request response m (v' a))

138 -> (forall a. k a -> v a -> RequesterT t request response m (v' a))

482 -> DMap k v

139 -> DMap k v

483 -> Event t (p k v)

140 -> Event t (p k v)

484 -> RequesterT t request response m (DMap k v', Event t (p k v'))

141 -> RequesterT t request response m (DMap k v', Event t (p k v'))

485−traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do

142+sequenceDMapWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' =

486− rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here

143+ let base' :: forall v1 v2.

487− let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))

144+ (forall a. k a -> v1 a -> ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m (v2 a))

488− responses = fanMap $ fmapCheap unpack response

145+ -> DMap k v1

489− unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))

146+ -> Event t (p k v1)

490− unpack = _multi2Contents_values . unEntry

147+ -> EventWriterT t (DMap (Tag (PrimState m)) request) (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m) (DMap k v2, Event t (p k v2))

491− pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)

148+ base' f' x y = do

492− pack m = Entry $ Multi2Contents { _multi2Contents_values = m, _multi2Contents_dict = Dict }

149+ r <- EventWriterT ask

493− f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)

150+ unRequesterT $ base (\k v -> runReaderT (f' k v) r) x y

494− f' k (Compose (n, v)) = do

151+ in RequesterT $ sequenceDMapWithAdjustEventWriterTWith base' mapPatch weakenPatchWith patchNewElements mergePatchIncremental (\k v -> unRequesterT $ f k v) (coerce dm0) (coerceEvent dm')

495− (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some k))

496− return $ Compose (fmapCheap (IntMap.singleton n) myRequests, result)

497− ndm' <- numberOccurrencesFrom 1 dm'

498− (children0, children') <- base f' (DMap.map (\v -> Compose (0, v)) dm0) $ fmap (\(n, dm) -> mapPatch (\v -> Compose (n, v)) dm) ndm'

499− let result0 = DMap.map (snd . getCompose) children0

500− result' = fforCheap children' $ mapPatch $ snd . getCompose

501− requests0 :: Map (Some k) (Event t (IntMap (RequesterData request)))

502− requests0 = weakenDMapWith (fst . getCompose) children0

503− requests' :: Event t (p' (Some k) (Event t (IntMap (RequesterData request))))

504− requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose

505− promptRequests :: Event t (Map (Some k) (IntMap (RequesterData request)))

506− promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'

507− requests <- holdIncremental requests0 requests'

508− return (result0, result')

509−

510−data Decoder rawResponse response =

511− forall a. Decoder (RequesterDataKey a) (rawResponse -> response a)

512−

513−matchResponsesWithRequests

514− :: forall t rawRequest rawResponse request response m.

515− ( MonadFix m

516− , MonadHold t m

517− , Reflex t

518− )

519− => (forall a. request a -> (rawRequest, rawResponse -> response a))

520− -- ^ Given a request (from 'Requester'), produces the wire format of the

521− -- request and a function used to process the associated response

522− -> Event t (RequesterData request)

523− -- ^ The outgoing requests

524− -> Event t (Int, rawResponse)

525− -- ^ The incoming responses, tagged by an identifying key

526− -> m ( Event t (Map Int rawRequest)

527− , Event t (RequesterData response)

528− )

529− -- ^ A map of outgoing wire-format requests and an event of responses keyed

530− -- by the 'RequesterData' key of the associated outgoing request

531−matchResponsesWithRequests f send recv = matchResponseMapWithRequests f send $ uncurry Map.singleton <$> recv

532−

533−-- | Matches incoming responses with previously-sent requests

534−-- and uses the provided request "decoder" function to process

535−-- incoming responses.

536−matchResponseMapWithRequests

537− :: forall t rawRequest rawResponse request response m.

538− ( MonadFix m

539− , MonadHold t m

540− , Reflex t

541− )

542− => (forall a. request a -> (rawRequest, rawResponse -> response a))

543− -- ^ Given a request (from 'Requester'), produces the wire format of the

544− -- request and a function used to process the associated response

545− -> Event t (RequesterData request)

546− -- ^ The outgoing requests

547− -> Event t (Map Int rawResponse)

548− -- ^ A map of incoming responses, tagged by an identifying key

549− -> m ( Event t (Map Int rawRequest)

550− , Event t (RequesterData response)

551− )

552− -- ^ A map of outgoing wire-format requests and an event of responses keyed

553− -- by the 'RequesterData' key of the associated outgoing request

554−matchResponseMapWithRequests f send recv = do

555− rec nextId <- hold 1 $ fmap (\(next, _, _) -> next) outgoing

556− waitingFor :: Incremental t (PatchMap Int (Decoder rawResponse response)) <-

557− holdIncremental mempty $ leftmost

558− [ fmap (\(_, outstanding, _) -> outstanding) outgoing

559− , snd <$> incoming

560− ]

561− let outgoing = processOutgoing nextId send

562− incoming = processIncoming waitingFor recv

563− return (fmap (\(_, _, rawReqs) -> rawReqs) outgoing, fst <$> incoming)

564− where

565− -- Tags each outgoing request with an identifying integer key

566− -- and returns the next available key, a map of response decoders

567− -- for requests for which there are outstanding responses, and the

568− -- raw requests to be sent out.

569− processOutgoing

570− :: Behavior t Int

571− -- The next available key

572− -> Event t (RequesterData request)

573− -- The outgoing request

574− -> Event t ( Int

575− , PatchMap Int (Decoder rawResponse response)

576− , Map Int rawRequest )

577− -- The new next-available-key, a map of requests expecting responses, and the tagged raw requests

578− processOutgoing nextId out = flip pushAlways out $ \dm -> do

579− oldNextId <- sample nextId

580− let (result, newNextId) = flip runState oldNextId $ forM (requesterDataToList dm) $ \(k :=> v) -> do

581− n <- get

582− put $ succ n

583− let (rawReq, rspF) = f v

584− return (n, rawReq, Decoder k rspF)

585− patchWaitingFor = PatchMap $ Map.fromList $

586− (\(n, _, dec) -> (n, Just dec)) <$> result

587− toSend = Map.fromList $ (\(n, rawReq, _) -> (n, rawReq)) <$> result

588− return (newNextId, patchWaitingFor, toSend)

589− -- Looks up the each incoming raw response in a map of response

590− -- decoders and returns the decoded response and a patch that can

591− -- be used to clear the ID of the consumed response out of the queue

592− -- of expected responses.

593− processIncoming

594− :: Incremental t (PatchMap Int (Decoder rawResponse response))

595− -- A map of outstanding expected responses

596− -> Event t (Map Int rawResponse)

597− -- A incoming response paired with its identifying key

598− -> Event t (RequesterData response, PatchMap Int v)

599− -- The decoded response and a patch that clears the outstanding responses queue

600− processIncoming waitingFor inc = flip push inc $ \rspMap -> do

601− wf <- sample $ currentIncremental waitingFor

602− let match rawRsp (Decoder k rspF) =

603− let rsp = rspF rawRsp

604− in singletonRequesterData k rsp

605− matches = Map.intersectionWith match rspMap wf

606− pure $ if Map.null matches then Nothing else Just

607− (Map.foldl' mergeRequesterData emptyRequesterData matches, PatchMap $ Nothing <$ matches)

src/Reflex/Requester/Class.hs+35−20

@@ -6,7 +6,7 @@

6{-# LANGUAGE CPP #-}

7{-# LANGUAGE FlexibleInstances #-}

8{-# LANGUAGE FunctionalDependencies #-}

9−{-# LANGUAGE RecursiveDo #-}

9+{-# LANGUAGE MultiParamTypeClasses #-}

10{-# LANGUAGE TypeFamilies #-}

11{-# LANGUAGE UndecidableInstances #-}

12#ifdef USE_REFLEX_OPTIMIZER

@@ -14,7 +14,8 @@

14#endif

15module Reflex.Requester.Class

16 ( Requester (..)

17− , withRequesting

17+ , requesting

18+ , requesting_

18 , requestingIdentity

19 , requestingIdentity

19 ) where

20 ) where

@@ -35,38 +36,52 @@ class (Reflex t, Monad m) => Requester t m | m -> t where

35 type Request m :: * -> *

36 type Request m :: * -> *

36 -- | The type of responses that this 'Requester' can receive

37 -- | The type of responses that this 'Requester' can receive

37 type Response m :: * -> *

38 type Response m :: * -> *

38− -- | Emit a request whenever the given 'Event' fires, and return responses in

39+ -- | Usually, end-user code should use 'requesting', 'requesting_', or

39− -- the resulting 'Event'.

40+ -- 'requestingIdentity'. For implementers of 'Requester', this function

40− requesting :: Event t (Request m a) -> m (Event t (Response m a))

41+ -- provides a convenient way to define instances of the typeclass that

41− -- | Emit a request whenever the given 'Event' fires, and ignore all responses.

42+ -- efficiently support the underlying operations without needing to use

42− requesting_ :: Event t (Request m a) -> m ()

43+ -- 'Control.Monad.Fix.MonadFix'.

43−

44+ withRequesting :: (Event t (Response m a) -> m (Event t (Request m a), r)) -> m r

45instance Requester t m => Requester t (ReaderT r m) where

46instance Requester t m => Requester t (ReaderT r m) where

46 type Request (ReaderT r m) = Request m

47 type Request (ReaderT r m) = Request m

47 type Response (ReaderT r m) = Response m

48 type Response (ReaderT r m) = Response m

48− requesting = lift . requesting

49+ withRequesting f = do

49− requesting_ = lift . requesting_

50+ r <- ask

51+ lift $ withRequesting $ (`runReaderT` r) . f

51instance Requester t m => Requester t (StateT s m) where

53instance Requester t m => Requester t (StateT s m) where

52 type Request (StateT s m) = Request m

54 type Request (StateT s m) = Request m

53 type Response (StateT s m) = Response m

55 type Response (StateT s m) = Response m

54− requesting = lift . requesting

56+ withRequesting f = do

55− requesting_ = lift . requesting_

57+ old <- get

58+ (result, new) <- lift $ withRequesting $ \x -> do

59+ ((request, result), new) <- runStateT (f x) old

60+ return (request, (result, new))

61+ put new

62+ return result

57instance Requester t m => Requester t (Lazy.StateT s m) where

64instance Requester t m => Requester t (Lazy.StateT s m) where

58 type Request (Lazy.StateT s m) = Request m

65 type Request (Lazy.StateT s m) = Request m

59 type Response (Lazy.StateT s m) = Response m

66 type Response (Lazy.StateT s m) = Response m

60− requesting = lift . requesting

67+ withRequesting f = do

61− requesting_ = lift . requesting_

68+ old <- Lazy.get

69+ (result, new) <- lift $ withRequesting $ \x -> do

70+ ((request, result), new) <- Lazy.runStateT (f x) old

71+ return (request, (result, new))

72+ Lazy.put new

73+ return result

74+

75+-- | Emit a request whenever the given 'Event' fires, and return responses in

76+-- the resulting 'Event'.

77+requesting :: Requester t m => Event t (Request m a) -> m (Event t (Response m a))

78+requesting req = withRequesting $ return . (,) req

79+

80+-- | Emit a request whenever the given 'Event' fires, and ignore all responses.

81+requesting_ :: Requester t m => Event t (Request m a) -> m ()

82+requesting_ req = withRequesting $ \_ -> return (req, ())

63-- | Emit a request whenever the given 'Event' fires, and unwrap the responses

84-- | Emit a request whenever the given 'Event' fires, and unwrap the responses

64-- before returning them. @Response m@ must be 'Identity'.

85-- before returning them. @Response m@ must be 'Identity'.

65requestingIdentity :: (Requester t m, Response m ~ Identity) => Event t (Request m a) -> m (Event t a)

86requestingIdentity :: (Requester t m, Response m ~ Identity) => Event t (Request m a) -> m (Event t a)

66requestingIdentity = fmap coerceEvent . requesting

87requestingIdentity = fmap coerceEvent . requesting

67−

68−withRequesting :: (Requester t m, MonadFix m) => (Event t (Response m a) -> m (Event t (Request m a), r)) -> m r

69−withRequesting f = do

70− rec response <- requesting request

71− (request, result) <- f response

72− return result

src/Reflex/Spider.hs+7−5

@@ -1,20 +1,22 @@

1{-# LANGUAGE CPP #-}

2−-- |

2+-- | This module exports all of the user-facing functionality of the 'Spider'

3−-- Module:

3+-- 'Reflex' engine

4−-- Reflex.Spider

5−-- Description:

6−-- This module exports all of the user-facing functionality of the 'Spider' 'Reflex' engine

7module Reflex.Spider

4module Reflex.Spider

8 ( Spider

5 ( Spider

9 , SpiderTimeline

6 , SpiderTimeline

10 , Global

7 , Global

11 , SpiderHost

8 , SpiderHost

12 , runSpiderHost

9 , runSpiderHost

10+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

13 , runSpiderHostForTimeline

11 , runSpiderHostForTimeline

14 , newSpiderTimeline

12 , newSpiderTimeline

15 , withSpiderTimeline

13 , withSpiderTimeline

14+#endif

16 -- * Deprecated

15 -- * Deprecated

17 , SpiderEnv

16 , SpiderEnv

18 ) where

17 ) where

19+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

20+import Reflex.Class

21+#endif

20import Reflex.Spider.Internal

22import Reflex.Spider.Internal

src/Reflex/Spider/Internal.hs+546−1290

@@ -9,49 +9,40 @@

9{-# LANGUAGE GADTs #-}

10{-# LANGUAGE GeneralizedNewtypeDeriving #-}

11{-# LANGUAGE LambdaCase #-}

12+{-# LANGUAGE MagicHash #-}

13+{-# LANGUAGE MultiParamTypeClasses #-}

14+{-# LANGUAGE MultiWayIf #-}

12{-# LANGUAGE RankNTypes #-}

15{-# LANGUAGE RankNTypes #-}

13{-# LANGUAGE RoleAnnotations #-}

16{-# LANGUAGE RoleAnnotations #-}

14{-# LANGUAGE ScopedTypeVariables #-}

17{-# LANGUAGE ScopedTypeVariables #-}

15{-# LANGUAGE TypeFamilies #-}

18{-# LANGUAGE TypeFamilies #-}

16{-# LANGUAGE TypeOperators #-}

19{-# LANGUAGE TypeOperators #-}

17{-# LANGUAGE UndecidableInstances #-}

20{-# LANGUAGE UndecidableInstances #-}

18−{-# LANGUAGE PolyKinds #-}

19−{-# LANGUAGE DeriveFunctor #-}

20−{-# LANGUAGE StandaloneDeriving #-}

21−{-# LANGUAGE InstanceSigs #-}

22−{-# LANGUAGE MultiWayIf #-}

23−

24#ifdef USE_REFLEX_OPTIMIZER

21#ifdef USE_REFLEX_OPTIMIZER

25{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

22{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

26#endif

23#endif

27−{-# OPTIONS_GHC -Wunused-binds #-}

24+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

25+{-# OPTIONS_GHC -fno-warn-orphans #-}

26+#endif

28-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses

27-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses

29-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.

28-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.

30module Reflex.Spider.Internal (module Reflex.Spider.Internal) where

29module Reflex.Spider.Internal (module Reflex.Spider.Internal) where

32−#if MIN_VERSION_base(4,10,0)

31+import Control.Applicative

33−import Control.Applicative (liftA2)

34−#endif

35import Control.Concurrent

32import Control.Concurrent

36import Control.Exception

33import Control.Exception

37−import Control.Monad hiding (forM, forM_, mapM, mapM_)

34+import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)

38import Control.Monad.Exception

35import Control.Monad.Exception

39−import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)

36+import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence)

40import Control.Monad.Primitive

37import Control.Monad.Primitive

41−import Control.Monad.Reader.Class

38+import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence)

42−import Control.Monad.IO.Class

43−import Control.Monad.ReaderIO

44import Control.Monad.Ref

39import Control.Monad.Ref

45−import Control.Monad.Fail (MonadFail)

46−import qualified Control.Monad.Fail as MonadFail

47import Data.Align

40import Data.Align

48import Data.Coerce

41import Data.Coerce

49−import Data.Dependent.Map (DMap)

42+import Data.Dependent.Map (DMap, DSum (..))

50import qualified Data.Dependent.Map as DMap

43import qualified Data.Dependent.Map as DMap

51−import Data.Dependent.Sum (DSum (..))

52−import Data.FastMutableIntMap (FastMutableIntMap, PatchIntMap (..))

53−import qualified Data.FastMutableIntMap as FastMutableIntMap

54import Data.Foldable hiding (concat, elem, sequence_)

44import Data.Foldable hiding (concat, elem, sequence_)

45+import Data.Function

55import Data.Functor.Constant

46import Data.Functor.Constant

56import Data.Functor.Misc

47import Data.Functor.Misc

57import Data.Functor.Product

48import Data.Functor.Product

@@ -59,73 +50,56 @@ import Data.GADT.Compare

59import Data.IntMap.Strict (IntMap)

50import Data.IntMap.Strict (IntMap)

60import qualified Data.IntMap.Strict as IntMap

51import qualified Data.IntMap.Strict as IntMap

61import Data.IORef

52import Data.IORef

62−import Data.Kind (Type)

53+import Data.List hiding (foldl')

63−import Data.Maybe hiding (mapMaybe)

54+import Data.Maybe

64−import Data.Monoid (mempty, (<>))

55+import Data.Monoid ((<>))

65import Data.Proxy

56import Data.Proxy

66import Data.These

57import Data.These

67import Data.Traversable

58import Data.Traversable

68−import Data.Type.Equality ((:~:)(Refl))

59+import Data.Word

69−import Data.Witherable (Filterable, mapMaybe)

60+import GHC.Exts

70−import GHC.Exts hiding (toList)

71import GHC.IORef (IORef (..))

61import GHC.IORef (IORef (..))

72import GHC.Stack

62import GHC.Stack

73−import Reflex.FastWeak

63+import Reflex.FunctorMaybe

74import System.IO.Unsafe

64import System.IO.Unsafe

75import System.Mem.Weak

65import System.Mem.Weak

76import Unsafe.Coerce

66import Unsafe.Coerce

78−#ifdef MIN_VERSION_semialign

79−#if MIN_VERSION_these(0,8,0)

80−import Data.These.Combinators (justThese)

81−#endif

82−#if MIN_VERSION_semialign(1,1,0)

83−import Data.Zip (Zip (..))

84−#endif

85−#endif

86−

87#ifdef DEBUG_CYCLES

68#ifdef DEBUG_CYCLES

88import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)

69import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)

89−#endif

90−

91import Data.List.NonEmpty (NonEmpty (..), nonEmpty)

70import Data.List.NonEmpty (NonEmpty (..), nonEmpty)

92import qualified Data.List.NonEmpty as NonEmpty

71import qualified Data.List.NonEmpty as NonEmpty

72+import Data.Monoid (mempty)

93import Data.Tree (Forest, Tree (..), drawForest)

73import Data.Tree (Forest, Tree (..), drawForest)

94−import Data.List (isPrefixOf)

74+#endif

95−

96−import Data.FastWeakBag (FastWeakBag, FastWeakBagTicket)

97−import qualified Data.FastWeakBag as FastWeakBag

99−import Data.Reflection

100−import Data.Some (Some(Some))

101−import Data.Type.Coercion

102−import Data.Profunctor.Unsafe ((#.), (.#))

103import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)

76import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)

104import qualified Data.WeakBag as WeakBag

77import qualified Data.WeakBag as WeakBag

78+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

79+import Data.Reflection

80+import Data.Some (Some)

81+import qualified Data.Some as Some

82+import Data.Type.Coercion

105import qualified Reflex.Class

83import qualified Reflex.Class

106import qualified Reflex.Class as R

84import qualified Reflex.Class as R

107import qualified Reflex.Host.Class

85import qualified Reflex.Host.Class

108−import Reflex.NotReady.Class

86+#endif

109−import Data.Patch

87+import Reflex.Patch

110−import qualified Data.Patch.DMapWithMove as PatchDMapWithMove

88+

111−import Reflex.PerformEvent.Base (PerformEventT)

89+-- Note: must come last to silence warnings due to AMP on GHC < 7.10

90+import Prelude hiding (any, concat, mapM, mapM_, sequence)

112

113#ifdef DEBUG_TRACE_EVENTS

92#ifdef DEBUG_TRACE_EVENTS

114−import qualified Data.ByteString.Char8 as BS8

115import System.IO (stderr)

93import System.IO (stderr)

116−import Data.List (isPrefixOf)

94+import qualified Data.ByteString.Char8 as BS8

117#endif

95#endif

118

119−-- TODO stdout might not be the best channel for debug output

120−debugStrLn :: String -> IO ()

121−debugStrLn = putStrLn

122−

123#ifdef DEBUG_TRACE_EVENTS

97#ifdef DEBUG_TRACE_EVENTS

98+

124withStackOneLine :: (BS8.ByteString -> a) -> a

99withStackOneLine :: (BS8.ByteString -> a) -> a

125withStackOneLine expr = unsafePerformIO $ do

100withStackOneLine expr = unsafePerformIO $ do

126 stack <- currentCallStack

101 stack <- currentCallStack

127− return (expr . BS8.pack . unwords . dropInternal . reverse $ stack)

102+ return (expr (BS8.pack (unwords (reverse stack))))

128− where dropInternal = filterStack "Reflex.Spider.Internal"

129

103

130#endif

104#endif

131

105

@@ -136,42 +110,28 @@ debugInvalidateHeight :: Bool

136debugInvalidate :: Bool

110debugInvalidate :: Bool

137

111

138#ifdef DEBUG

112#ifdef DEBUG

113+

139#define DEBUG_NODEIDS

114#define DEBUG_NODEIDS

140

115

141−#ifdef DEBUG_TRACE_PROPAGATION

142debugPropagate = True

116debugPropagate = True

143−#else

144−debugPropagate = False

145−#endif

146

117

147−#ifdef DEBUG_TRACE_HEIGHT

148−debugInvalidateHeight = True

149−#else

150debugInvalidateHeight = False

118debugInvalidateHeight = False

151−#endif

152

119

153−#ifdef DEBUG_TRACE_INVALIDATION

154debugInvalidate = True

120debugInvalidate = True

155−#else

156−debugInvalidate = False

157−#endif

158

121

159class HasNodeId a where

122class HasNodeId a where

160 getNodeId :: a -> Int

123 getNodeId :: a -> Int

161

124

162−instance HasNodeId (CacheSubscribed x a) where

125+instance HasNodeId (Hold x p a) where

163− getNodeId = _cacheSubscribed_nodeId

164−

165−instance HasNodeId (FanInt x a) where

166− getNodeId = _fanInt_nodeId

167−

168−instance HasNodeId (Hold x p) where

169 getNodeId = holdNodeId

126 getNodeId = holdNodeId

170

127

128+instance HasNodeId (PushSubscribed x a b) where

129+ getNodeId = pushSubscribedNodeId

130+

171instance HasNodeId (SwitchSubscribed x a) where

131instance HasNodeId (SwitchSubscribed x a) where

172 getNodeId = switchSubscribedNodeId

132 getNodeId = switchSubscribedNodeId

173

133

174−instance HasNodeId (FanSubscribed x v a) where

134+instance HasNodeId (FanSubscribed x a) where

175 getNodeId = fanSubscribedNodeId

135 getNodeId = fanSubscribedNodeId

176

136

177instance HasNodeId (CoincidenceSubscribed x a) where

137instance HasNodeId (CoincidenceSubscribed x a) where

@@ -185,16 +145,41 @@ instance HasNodeId (Pull x a) where

185

145

186{-# INLINE showNodeId #-}

146{-# INLINE showNodeId #-}

187showNodeId :: HasNodeId a => a -> String

147showNodeId :: HasNodeId a => a -> String

188−showNodeId = showNodeId' . getNodeId

148+showNodeId = ("#"<>) . show . getNodeId

189−

149+

190−showNodeId' :: Int -> String

150+showSubscriberType :: Subscriber x a -> String

191−showNodeId' = ("#"<>) . show

151+showSubscriberType = \case

192−

152+ SubscriberPush _ _ -> "SubscriberPush"

153+ SubscriberMerge _ _ -> "SubscriberMerge"

154+ SubscriberFan _ -> "SubscriberFan"

155+ SubscriberMergeChange _ -> "SubscriberMergeChange"

156+ SubscriberHold _ -> "SubscriberHold"

157+ SubscriberHoldIdentity _ -> "SubscriberHoldIdentity"

158+ SubscriberSwitch _ -> "SubscriberSwitch"

159+ SubscriberCoincidenceOuter _ -> "SubscriberCoincidenceOuter"

160+ SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"

161+ SubscriberHandle -> "SubscriberHandle"

162+

163+showEventType :: Event x a -> String

164+showEventType = \case

165+ EventRoot _ _ -> "EventRoot"

166+ EventNever -> "EventNever"

167+ EventPush _ -> "EventPush"

168+ EventMerge _ -> "EventMerge"

169+ EventFan _ _ -> "EventFan"

170+ EventSwitch _ -> "EventSwitch"

171+ EventCoincidence _ -> "EventCoincidence"

172+ EventHold _ -> "EventHold"

173+ EventDyn _ -> "EventDyn"

174+ EventHoldIdentity _ -> "EventHoldIdentity"

175+ EventDynIdentity _ -> "EventDynIdentity"

193

176

194#else

177#else

195

178

196debugPropagate = False

179debugPropagate = False

180+

197debugInvalidateHeight = False

181debugInvalidateHeight = False

182+

198debugInvalidate = False

183debugInvalidate = False

199

184

200-- This must be inline, or error messages will cause memory leaks due to retaining the node in question

185-- This must be inline, or error messages will cause memory leaks due to retaining the node in question

@@ -202,10 +187,6 @@ debugInvalidate = False

202showNodeId :: a -> String

187showNodeId :: a -> String

203showNodeId _ = ""

188showNodeId _ = ""

204

189

205−{-# INLINE showNodeId' #-}

206−showNodeId' :: Int -> String

207−showNodeId' _ = ""

208−

209#endif

190#endif

210

191

211#ifdef DEBUG_NODEIDS

192#ifdef DEBUG_NODEIDS

@@ -215,6 +196,12 @@ nextNodeIdRef = unsafePerformIO $ newIORef 1

215

196

216newNodeId :: IO Int

197newNodeId :: IO Int

217newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)

198newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)

199+

200+{-# NOINLINE unsafeNodeId #-}

201+unsafeNodeId :: a -> Int

202+unsafeNodeId a = unsafePerformIO $ do

203+ touch a

204+ newNodeId

218#endif

205#endif

219

206

220--------------------------------------------------------------------------------

207--------------------------------------------------------------------------------

@@ -250,165 +237,85 @@ subscribeAndRead = unEvent

250-- | Construct an 'Event' equivalent to that constructed by 'push', but with no

237-- | Construct an 'Event' equivalent to that constructed by 'push', but with no

251-- caching; if the computation function is very cheap, this is (much) more

238-- caching; if the computation function is very cheap, this is (much) more

252-- efficient than 'push'

239-- efficient than 'push'

253−{-# INLINE [1] pushCheap #-}

240+{-# NOINLINE pushCheap #-}

254pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b

241pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b

255−pushCheap !f e = Event $ \sub -> do

242+pushCheap f e = Event $ \sub -> do

256− (subscription, occ) <- subscribeAndRead e $ debugSubscriber' "push" $ sub

243+ (subscription, occ) <- subscribeAndRead e $ sub

257 { subscriberPropagate = \a -> do

244 { subscriberPropagate = \a -> do

258− mb <- f a

245+ mb <- runComputeM $ f a

259 mapM_ (subscriberPropagate sub) mb

246 mapM_ (subscriberPropagate sub) mb

260 }

247 }

261− occ' <- join <$> mapM f occ

248+ occ' <- join <$> mapM (runComputeM . f) occ

262 return (subscription, occ')

249 return (subscription, occ')

263

250

264−-- | A subscriber that never triggers other 'Event's

265−{-# INLINE terminalSubscriber #-}

266−terminalSubscriber :: (a -> EventM x ()) -> Subscriber x a

267−terminalSubscriber p = Subscriber

268− { subscriberPropagate = p

269− , subscriberInvalidateHeight = \_ -> return ()

270− , subscriberRecalculateHeight = \_ -> return ()

271− }

272−

273−-- | Subscribe to an Event only for the duration of one occurrence

274−{-# INLINE subscribeAndReadHead #-}

275−subscribeAndReadHead :: HasSpiderTimeline x => Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)

276−subscribeAndReadHead e sub = do

277− subscriptionRef <- liftIO $ newIORef $ error "subscribeAndReadHead: not initialized"

278− (subscription, occ) <- subscribeAndRead e $ debugSubscriber' "head" $ sub

279− { subscriberPropagate = \a -> do

280− liftIO $ unsubscribe =<< readIORef subscriptionRef

281− subscriberPropagate sub a

282− }

283− liftIO $ case occ of

284− Nothing -> writeIORef subscriptionRef $! subscription

285− Just _ -> unsubscribe subscription

286− return (subscription, occ)

287−

288−--TODO: Make this lazy in its input event

289−headE :: (MonadIO m, Defer (SomeMergeInit x) m, HasSpiderTimeline x) => Event x a -> m (Event x a)

290−headE originalE = do

291− parent <- liftIO $ newIORef $ Just originalE

292− defer $ SomeMergeInit $ do --TODO: Rename SomeMergeInit appropriately

293− let clearParent = liftIO $ writeIORef parent Nothing

294− (_, occ) <- subscribeAndReadHead originalE $ terminalSubscriber $ const clearParent

295− when (isJust occ) clearParent

296− return $ Event $ \sub ->

297− liftIO (readIORef parent) >>= \case

298− Nothing -> subscribeAndReadNever

299− Just e -> subscribeAndReadHead e sub

300−

301data CacheSubscribed x a

251data CacheSubscribed x a

302− = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(FastWeakBag (Subscriber x a))

252+ = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(WeakBag (Subscriber x a))

253+ , _cacheSubscribed_weakSelf :: {-# UNPACK #-} !(IORef (Weak (CacheSubscribed x a)))

303 , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)

254 , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)

255+ , _cacheSubscribed_cached :: {-# UNPACK #-} !(IORef (Maybe (CacheSubscribed x a)))

304 , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))

256 , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))

305−#ifdef DEBUG_NODEIDS

306− , _cacheSubscribed_nodeId :: {-# UNPACK #-} !Int

307−#endif

308 }

257 }

309

258

310−nowSpiderEventM :: (HasSpiderTimeline x) => EventM x (R.Event (SpiderTimeline x) ())

311−nowSpiderEventM =

312− SpiderEvent <$> now

313−

314−now :: (MonadIO m, Defer (Some Clear) m, HasSpiderTimeline x

315− ) => m (Event x ())

316−now = do

317− nowOrNot <- liftIO $ newIORef $ Just ()

318− scheduleClear nowOrNot

319− return . Event $ \_ -> do

320− occ <- liftIO . readIORef $ nowOrNot

321− return ( EventSubscription (return ()) eventSubscribedNow

322− , occ

323− )

324−

325-- | Construct an 'Event' whose value is guaranteed not to be recomputed

259-- | Construct an 'Event' whose value is guaranteed not to be recomputed

326-- repeatedly

260-- repeatedly

327--

261--

328--TODO: Try a caching strategy where we subscribe directly to the parent when

262--TODO: Try a caching strategy where we subscribe directly to the parent when

329−--there's only one subscriber, and then build our own FastWeakBag only when a second

263+--there's only one subscriber, and then build our own WeakBag only when a second

330--subscriber joins

264--subscriber joins

331−{-# NOINLINE [0] cacheEvent #-}

265+{-# NOINLINE cacheEvent #-}

332−cacheEvent :: forall x a. HasSpiderTimeline x => Event x a -> Event x a

266+cacheEvent :: HasSpiderTimeline x => Event x a -> Event x a

333cacheEvent e =

267cacheEvent e =

334#ifdef DEBUG_TRACE_EVENTS

268#ifdef DEBUG_TRACE_EVENTS

335 withStackOneLine $ \callSite -> Event $

269 withStackOneLine $ \callSite -> Event $

336#else

270#else

337 Event $

271 Event $

338#endif

272#endif

339− unsafePerformIO $ do

273+ let !mSubscribedRef = unsafeNewIORef e Nothing

340− mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))

274+ in \sub -> {-# SCC "cacheEvent" #-} do

341− <- newIORef emptyFastWeak

342− pure $ \sub -> {-# SCC "cacheEvent" #-} do

343#ifdef DEBUG_TRACE_EVENTS

275#ifdef DEBUG_TRACE_EVENTS

344 unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite

276 unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite

345#endif

277#endif

346− subscribedTicket <- liftIO (readIORef mSubscribedRef >>= getFastWeakTicket) >>= \case

278+ mSubscribed <- liftIO $ readIORef mSubscribedRef

347− Just subscribedTicket -> return subscribedTicket

279+ case mSubscribed of

280+ Just subscribed -> liftIO $ do

281+ ticket <- WeakBag.insert sub (_cacheSubscribed_subscribers subscribed) (_cacheSubscribed_weakSelf subscribed) cleanupCacheSubscribed

282+ occ <- readIORef $ _cacheSubscribed_occurrence subscribed

283+ let es = EventSubscribed

284+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed

285+ , eventSubscribedRetained = toAny subscribed

286+ }

287+ return (EventSubscription (WeakBag.remove ticket >> touch ticket) es, occ)

348 Nothing -> do

288 Nothing -> do

349−#ifdef DEBUG_NODEIDS

289+ weakSelf <- liftIO $ newIORef $ error "cacheEvent: weakSelf not yet intialized"

350− nodeId <- liftIO newNodeId

290+ (subscribers, ticket) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCacheSubscribed

351−#endif

291+ occRef <- liftIO $ newIORef undefined

352− subscribers <- liftIO FastWeakBag.empty

353− occRef <- liftIO $ newIORef Nothing -- This should never be read prior to being set below

354−#ifdef DEBUG_NODEIDS

355− (parentSub, occ) <- subscribeAndRead e $ debugSubscriber' ("cacheEvent" <> showNodeId' nodeId) $ Subscriber

356−#else

357 (parentSub, occ) <- subscribeAndRead e $ Subscriber

292 (parentSub, occ) <- subscribeAndRead e $ Subscriber

358−#endif

293+ { subscriberPropagate = \a -> do

359− { subscriberPropagate = \a -> do

294+ liftIO $ writeIORef occRef $ Just a

360− liftIO $ writeIORef occRef (Just a)

295+ scheduleClear occRef

361− scheduleClear occRef

296+ propagate a subscribers

362− propagateFast a subscribers

297+ , subscriberInvalidateHeight = \old -> do

363− , subscriberInvalidateHeight = FastWeakBag.traverse_ subscribers . invalidateSubscriberHeight

298+ WeakBag.traverse subscribers $ invalidateSubscriberHeight old

364− , subscriberRecalculateHeight = FastWeakBag.traverse_ subscribers . recalculateSubscriberHeight

299+ , subscriberRecalculateHeight = \new -> do

365− }

300+ WeakBag.traverse subscribers $ recalculateSubscriberHeight new

366− when (isJust occ) $ do

301+ }

367− liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing

302+ liftIO $ writeIORef occRef occ

368− scheduleClear occRef

303+ when (isJust occ) $ scheduleClear occRef

369 let !subscribed = CacheSubscribed

304 let !subscribed = CacheSubscribed

370 { _cacheSubscribed_subscribers = subscribers

305 { _cacheSubscribed_subscribers = subscribers

306+ , _cacheSubscribed_weakSelf = weakSelf

371 , _cacheSubscribed_parent = parentSub

307 , _cacheSubscribed_parent = parentSub

308+ , _cacheSubscribed_cached = mSubscribedRef

372 , _cacheSubscribed_occurrence = occRef

309 , _cacheSubscribed_occurrence = occRef

373−#ifdef DEBUG_NODEIDS

374− , _cacheSubscribed_nodeId = nodeId

375−#endif

376 }

310 }

377− subscribedTicket <- liftIO $ mkFastWeakTicket subscribed

311+ liftIO $ writeIORef mSubscribedRef $ Just subscribed

378− liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket

312+ liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "PushSubscribed"

379− return subscribedTicket

313+ return (EventSubscription (WeakBag.remove ticket >> touch ticket) (EventSubscribed (eventSubscribedHeightRef $ _eventSubscription_subscribed parentSub) (toAny subscribed)), occ)

380− liftIO $ cacheSubscription sub mSubscribedRef subscribedTicket

381−

382−cacheSubscription :: Subscriber x a -> IORef (FastWeak (CacheSubscribed x a))

383− -> FastWeakTicket (CacheSubscribed x a) -> IO (EventSubscription x, Maybe a)

384−cacheSubscription sub mSubscribedRef subscribedTicket = do

385− subscribed <- getFastWeakTicketValue subscribedTicket

386− ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed

387− occ <- readIORef $ _cacheSubscribed_occurrence subscribed

388−

389− let parentSub = _cacheSubscribed_parent subscribed

390− es = EventSubscription

391− { _eventSubscription_unsubscribe = do

392− FastWeakBag.remove ticket

393−

394− isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed

395− when isEmpty $ do

396− writeIORef mSubscribedRef emptyFastWeak

397− unsubscribe parentSub

398− touch ticket

399− touch subscribedTicket

400− , _eventSubscription_subscribed = EventSubscribed

401− { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed parentSub

402− , eventSubscribedRetained = toAny subscribedTicket

403−#ifdef DEBUG_CYCLES

404− , eventSubscribedGetParents = return [_eventSubscription_subscribed parentSub]

405− , eventSubscribedHasOwnHeightRef = False

406− , eventSubscribedWhoCreated = whoCreatedIORef mSubscribedRef

407−#endif

408− }

409− }

410− return (es, occ)

411

314

315+cleanupCacheSubscribed :: CacheSubscribed x a -> IO ()

316+cleanupCacheSubscribed self = do

317+ unsubscribe $ _cacheSubscribed_parent self

318+ writeIORef (_cacheSubscribed_cached self) Nothing

412

319

413subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)

320subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)

414subscribe e s = fst <$> subscribeAndRead e s

321subscribe e s = fst <$> subscribeAndRead e s

@@ -420,16 +327,13 @@ wrap tag getSpecificSubscribed sub = do

420 let es = tag subd

327 let es = tag subd

421 return (EventSubscription (WeakBag.remove sln >> touch sln) es, occ)

328 return (EventSubscription (WeakBag.remove sln >> touch sln) es, occ)

422

329

423−eventRoot :: (GCompare k, HasSpiderTimeline x) => k a -> Root x k -> Event x a

330+eventRoot :: GCompare k => k a -> Root x k -> Event x a

424eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r

331eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r

425

332

426−subscribeAndReadNever :: EventM x (EventSubscription x, Maybe a)

427−subscribeAndReadNever = return (EventSubscription (return ()) eventSubscribedNever, Nothing)

428−

429eventNever :: Event x a

333eventNever :: Event x a

430−eventNever = Event $ const subscribeAndReadNever

334+eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)

431

335

432−eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k v -> Event x (v a)

336+eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k -> Event x a

433eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f

337eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f

434

338

435eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a

339eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a

@@ -438,14 +342,14 @@ eventSwitch !s = Event $ wrap eventSubscribedSwitch $ getSwitchSubscribed s

438eventCoincidence :: HasSpiderTimeline x => Coincidence x a -> Event x a

342eventCoincidence :: HasSpiderTimeline x => Coincidence x a -> Event x a

439eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSubscribed c

343eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSubscribed c

440

344

441−eventHold :: Hold x p -> Event x p

345+eventHold :: HasSpiderTimeline x => Hold x p -> Event x p

442eventHold !h = Event $ subscribeHoldEvent h

346eventHold !h = Event $ subscribeHoldEvent h

443

347

444eventDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Event x p

348eventDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Event x p

445eventDyn !j = Event $ \sub -> getDynHold j >>= \h -> subscribeHoldEvent h sub

349eventDyn !j = Event $ \sub -> getDynHold j >>= \h -> subscribeHoldEvent h sub

446

350

447{-# INLINE subscribeCoincidenceInner #-}

351{-# INLINE subscribeCoincidenceInner #-}

448−subscribeCoincidenceInner :: HasSpiderTimeline x => Event x a -> Height -> CoincidenceSubscribed x a -> EventM x (Maybe a, Height, EventSubscribed x)

352+subscribeCoincidenceInner :: CanSubscribe x m => Event x a -> Height -> CoincidenceSubscribed x a -> m (Maybe a, Height, EventSubscribed x)

449subscribeCoincidenceInner inner outerHeight subscribedUnsafe = do

353subscribeCoincidenceInner inner outerHeight subscribedUnsafe = do

450 subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe

354 subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe

451 (subscription@(EventSubscription _ innerSubd), innerOcc) <- subscribeAndRead inner subInner

355 (subscription@(EventSubscription _ innerSubd), innerOcc) <- subscribeAndRead inner subInner

@@ -464,6 +368,16 @@ data Subscriber x a = Subscriber

464 , subscriberRecalculateHeight :: !(Height -> IO ())

368 , subscriberRecalculateHeight :: !(Height -> IO ())

465 }

369 }

466

370

371+--TODO: Move this comment to WeakBag

372+-- These function are constructor functions that are marked NOINLINE so they are

373+-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away

374+-- so any weak references that are attached to the constructors will have their

375+-- finalizer run. Using the opaque constructor, does not see the

376+-- constructor application, so it behaves like an IORef and cannot be fused away.

377+--

378+-- The result is also evaluated to WHNF, since forcing a thunk invalidates

379+-- the weak pointer to it in some cases.

380+

467newSubscriberHold :: (HasSpiderTimeline x, Patch p) => Hold x p -> IO (Subscriber x p)

381newSubscriberHold :: (HasSpiderTimeline x, Patch p) => Hold x p -> IO (Subscriber x p)

468newSubscriberHold h = return $ Subscriber

382newSubscriberHold h = return $ Subscriber

469 { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h

383 { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h

@@ -471,68 +385,85 @@ newSubscriberHold h = return $ Subscriber

471 , subscriberRecalculateHeight = \_ -> return ()

385 , subscriberRecalculateHeight = \_ -> return ()

472 }

386 }

473

387

474−newSubscriberFan :: forall x k v. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k v -> IO (Subscriber x (DMap k v))

388+newSubscriberFan :: forall x k. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k -> IO (Subscriber x (DMap k Identity))

475−newSubscriberFan subscribed = debugSubscriber ("SubscriberFan " <> showNodeId subscribed) $ Subscriber

389+newSubscriberFan subscribed = return $ Subscriber

476 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do

390 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do

477 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed

391 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed

478− tracePropagate (Proxy :: Proxy x) $ show (DMap.size subs) <> " keys subscribed, " <> show (DMap.size a) <> " keys firing"

392+ tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"

479 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a

393 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a

480 scheduleClear $ fanSubscribedOccurrence subscribed

394 scheduleClear $ fanSubscribedOccurrence subscribed

481− let f _ (Pair v subsubs) = do

395+ let f _ (Pair (Identity v) subsubs) = do

482 propagate v $ _fanSubscribedChildren_list subsubs

396 propagate v $ _fanSubscribedChildren_list subsubs

483 return $ Constant ()

397 return $ Constant ()

484 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_

398 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_

485 return ()

399 return ()

486 , subscriberInvalidateHeight = \old -> do

400 , subscriberInvalidateHeight = \old -> do

401+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed

487 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

402 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

488− forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old

403+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old

404+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"

489 , subscriberRecalculateHeight = \new -> do

405 , subscriberRecalculateHeight = \new -> do

406+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed

490 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

407 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

491− forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new

408+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new

409+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"

492 }

410 }

493

411

494newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)

412newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)

495−newSubscriberSwitch subscribed = debugSubscriber ("SubscriberCoincidenceOuter" <> showNodeId subscribed) $ Subscriber

413+newSubscriberSwitch subscribed = return $ Subscriber

496 { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do

414 { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do

415+ tracePropagate (Proxy :: Proxy x) $ "SubscriberSwitch" <> showNodeId subscribed

497 liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a

416 liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a

498 scheduleClear $ switchSubscribedOccurrence subscribed

417 scheduleClear $ switchSubscribedOccurrence subscribed

499 propagate a $ switchSubscribedSubscribers subscribed

418 propagate a $ switchSubscribedSubscribers subscribed

500 , subscriberInvalidateHeight = \_ -> do

419 , subscriberInvalidateHeight = \_ -> do

420+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed

501 oldHeight <- readIORef $ switchSubscribedHeight subscribed

421 oldHeight <- readIORef $ switchSubscribedHeight subscribed

502 when (oldHeight /= invalidHeight) $ do

422 when (oldHeight /= invalidHeight) $ do

503 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight

423 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight

504− WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

424+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

505− , subscriberRecalculateHeight = (`updateSwitchHeight` subscribed)

425+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"

506− }

426+ , subscriberRecalculateHeight = \new -> do

427+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed

428+ updateSwitchHeight new subscribed

429+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"

430+ }

507

431

508newSubscriberCoincidenceOuter :: forall x b. HasSpiderTimeline x => CoincidenceSubscribed x b -> IO (Subscriber x (Event x b))

432newSubscriberCoincidenceOuter :: forall x b. HasSpiderTimeline x => CoincidenceSubscribed x b -> IO (Subscriber x (Event x b))

509−newSubscriberCoincidenceOuter subscribed = debugSubscriber ("SubscriberCoincidenceOuter" <> showNodeId subscribed) $ Subscriber

433+newSubscriberCoincidenceOuter subscribed = return $ Subscriber

510 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do

434 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do

435+ tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceOuter" <> showNodeId subscribed

511 outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed

436 outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed

512 tracePropagate (Proxy :: Proxy x) $ " outerHeight = " <> show outerHeight

437 tracePropagate (Proxy :: Proxy x) $ " outerHeight = " <> show outerHeight

513 (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed

438 (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed

514 tracePropagate (Proxy :: Proxy x) $ " isJust occ = " <> show (isJust occ)

439 tracePropagate (Proxy :: Proxy x) $ " isJust occ = " <> show (isJust occ)

515 tracePropagate (Proxy :: Proxy x) $ " innerHeight = " <> show innerHeight

440 tracePropagate (Proxy :: Proxy x) $ " innerHeight = " <> show innerHeight

516−

517 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd

441 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd

518 scheduleClear $ coincidenceSubscribedInnerParent subscribed

442 scheduleClear $ coincidenceSubscribedInnerParent subscribed

519 case occ of

443 case occ of

520− Nothing ->

444+ Nothing -> do

521 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height

445 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height

522 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight

446 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight

523− WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight

447+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight

524− WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight

448+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight

525 Just o -> do -- Since it's already firing, no need to adjust height

449 Just o -> do -- Since it's already firing, no need to adjust height

526 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ

450 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ

527 scheduleClear $ coincidenceSubscribedOccurrence subscribed

451 scheduleClear $ coincidenceSubscribedOccurrence subscribed

528 propagate o $ coincidenceSubscribedSubscribers subscribed

452 propagate o $ coincidenceSubscribedSubscribers subscribed

529− , subscriberInvalidateHeight = \_ -> invalidateCoincidenceHeight subscribed

453+ , subscriberInvalidateHeight = \_ -> do

530− , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed

454+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed

455+ invalidateCoincidenceHeight subscribed

456+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"

457+ , subscriberRecalculateHeight = \_ -> do

458+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed

459+ recalculateCoincidenceHeight subscribed

460+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"

531 }

461 }

532

462

533newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)

463newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)

534−newSubscriberCoincidenceInner subscribed = debugSubscriber ("SubscriberCoincidenceInner" <> showNodeId subscribed) $ Subscriber

464+newSubscriberCoincidenceInner subscribed = return $ Subscriber

535 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do

465 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do

466+ tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceInner" <> showNodeId subscribed

536 occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed

467 occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed

537 case occ of

468 case occ of

538 Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event

469 Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event

@@ -540,8 +471,14 @@ newSubscriberCoincidenceInner subscribed = debugSubscriber ("SubscriberCoinciden

540 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a

471 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a

541 scheduleClear $ coincidenceSubscribedOccurrence subscribed

472 scheduleClear $ coincidenceSubscribedOccurrence subscribed

542 propagate a $ coincidenceSubscribedSubscribers subscribed

473 propagate a $ coincidenceSubscribedSubscribers subscribed

543− , subscriberInvalidateHeight = \_ -> invalidateCoincidenceHeight subscribed

474+ , subscriberInvalidateHeight = \_ -> do

544− , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed

475+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed

476+ invalidateCoincidenceHeight subscribed

477+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"

478+ , subscriberRecalculateHeight = \_ -> do

479+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed

480+ recalculateCoincidenceHeight subscribed

481+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"

545 }

482 }

546

483

547invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()

484invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()

@@ -551,18 +488,11 @@ recalculateSubscriberHeight :: Height -> Subscriber x a -> IO ()

551recalculateSubscriberHeight = flip subscriberRecalculateHeight

488recalculateSubscriberHeight = flip subscriberRecalculateHeight

552

489

553-- | Propagate everything at the current height

490-- | Propagate everything at the current height

554−propagate :: forall x a. HasSpiderTimeline x => a -> WeakBag (Subscriber x a) -> EventM x ()

491+propagate :: a -> WeakBag (Subscriber x a) -> EventM x ()

555−propagate a subscribers = withIncreasedDepth (Proxy::Proxy x) $

492+propagate a subscribers = withIncreasedDepth $ do

556 -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them

493 -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them

557 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work

494 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work

558− WeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a

495+ WeakBag.traverse subscribers $ \s -> subscriberPropagate s a

559−

560−-- | Propagate everything at the current height

561−propagateFast :: forall x a. HasSpiderTimeline x => a -> FastWeakBag (Subscriber x a) -> EventM x ()

562−propagateFast a subscribers = withIncreasedDepth (Proxy::Proxy x) $

563− -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them

564− --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work

565− FastWeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a

566

496

567--------------------------------------------------------------------------------

497--------------------------------------------------------------------------------

568-- EventSubscribed

498-- EventSubscribed

@@ -571,16 +501,11 @@ propagateFast a subscribers = withIncreasedDepth (Proxy::Proxy x) $

571toAny :: a -> Any

501toAny :: a -> Any

572toAny = unsafeCoerce

502toAny = unsafeCoerce

573

503

574−-- Why do we use Any here, instead of just giving eventSubscribedRetained an

575−-- existential type? Sadly, GHC does not currently know how to unbox types

576−-- with existentially quantified fields. So instead we just coerce values

577−-- to type Any on the way in. Since we never coerce them back, this is

578−-- perfectly safe.

579data EventSubscribed x = EventSubscribed

504data EventSubscribed x = EventSubscribed

580 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)

505 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)

581 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any

506 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any

582#ifdef DEBUG_CYCLES

507#ifdef DEBUG_CYCLES

583− , eventSubscribedGetParents :: !(IO [EventSubscribed x]) -- For debugging loops

508+ , eventSubscribedGetParents :: !(IO [Some (EventSubscribed x)]) -- For debugging loops

584 , eventSubscribedHasOwnHeightRef :: !Bool

509 , eventSubscribedHasOwnHeightRef :: !Bool

585 , eventSubscribedWhoCreated :: !(IO [String])

510 , eventSubscribedWhoCreated :: !(IO [String])

586#endif

511#endif

@@ -607,23 +532,13 @@ eventSubscribedNever = EventSubscribed

607 , eventSubscribedWhoCreated = return ["never"]

532 , eventSubscribedWhoCreated = return ["never"]

608#endif

533#endif

609 }

534 }

610−eventSubscribedNow :: EventSubscribed x

611−eventSubscribedNow = EventSubscribed

612− { eventSubscribedHeightRef = zeroRef

613− , eventSubscribedRetained = toAny ()

614−#ifdef DEBUG_CYCLES

615− , eventSubscribedGetParents = return []

616− , eventSubscribedHasOwnHeightRef = False

617− , eventSubscribedWhoCreated = return ["now"]

618−#endif

619− }

620

535

621−eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x

536+eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x

622eventSubscribedFan !subscribed = EventSubscribed

537eventSubscribedFan !subscribed = EventSubscribed

623 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed

538 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed

624 , eventSubscribedRetained = toAny subscribed

539 , eventSubscribedRetained = toAny subscribed

625#ifdef DEBUG_CYCLES

540#ifdef DEBUG_CYCLES

626− , eventSubscribedGetParents = return [_eventSubscription_subscribed $ fanSubscribedParent subscribed]

541+ , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]

627 , eventSubscribedHasOwnHeightRef = False

542 , eventSubscribedHasOwnHeightRef = False

628 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed

543 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed

629#endif

544#endif

@@ -636,7 +551,7 @@ eventSubscribedSwitch !subscribed = EventSubscribed

636#ifdef DEBUG_CYCLES

551#ifdef DEBUG_CYCLES

637 , eventSubscribedGetParents = do

552 , eventSubscribedGetParents = do

638 s <- readIORef $ switchSubscribedCurrentParent subscribed

553 s <- readIORef $ switchSubscribedCurrentParent subscribed

639− return [_eventSubscription_subscribed s]

554+ return [Some.This $ _eventSubscription_subscribed s]

640 , eventSubscribedHasOwnHeightRef = True

555 , eventSubscribedHasOwnHeightRef = True

641 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed

556 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed

642#endif

557#endif

@@ -649,8 +564,8 @@ eventSubscribedCoincidence !subscribed = EventSubscribed

649#ifdef DEBUG_CYCLES

564#ifdef DEBUG_CYCLES

650 , eventSubscribedGetParents = do

565 , eventSubscribedGetParents = do

651 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed

566 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed

652− let outerParent = _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed

567+ let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed

653− innerParents = maybeToList $ innerSubscription

568+ innerParents = maybeToList $ fmap Some.This innerSubscription

654 return $ outerParent : innerParents

569 return $ outerParent : innerParents

655 , eventSubscribedHasOwnHeightRef = True

570 , eventSubscribedHasOwnHeightRef = True

656 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed

571 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed

@@ -664,20 +579,20 @@ getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es

664whoCreatedEventSubscribed :: EventSubscribed x -> IO [String]

579whoCreatedEventSubscribed :: EventSubscribed x -> IO [String]

665whoCreatedEventSubscribed = eventSubscribedWhoCreated

580whoCreatedEventSubscribed = eventSubscribedWhoCreated

666

581

667−walkInvalidHeightParents :: EventSubscribed x -> IO [EventSubscribed x]

582+walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)]

668walkInvalidHeightParents s0 = do

583walkInvalidHeightParents s0 = do

669− subscribers <- flip execStateT mempty $ ($ s0) $ fix $ \loop s -> do

584+ subscribers <- flip execStateT mempty $ ($ Some.This s0) $ fix $ \loop (Some.This s) -> do

670 h <- liftIO $ readIORef $ eventSubscribedHeightRef s

585 h <- liftIO $ readIORef $ eventSubscribedHeightRef s

671 when (h == invalidHeight) $ do

586 when (h == invalidHeight) $ do

672 when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed

587 when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed

673− modify (s :)

588+ modify (Some.This s :)

674 mapM_ loop =<< liftIO (eventSubscribedGetParents s)

589 mapM_ loop =<< liftIO (eventSubscribedGetParents s)

675− forM_ subscribers $ \s -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight

590+ forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight

676 return subscribers

591 return subscribers

677#endif

592#endif

678

593

679{-# INLINE subscribeHoldEvent #-}

594{-# INLINE subscribeHoldEvent #-}

680−subscribeHoldEvent :: Hold x p -> Subscriber x p -> EventM x (EventSubscription x, Maybe p)

595+subscribeHoldEvent :: CanSubscribe x m => Hold x p -> Subscriber x p -> m (EventSubscription x, Maybe p)

681subscribeHoldEvent = subscribeAndRead . holdEvent

596subscribeHoldEvent = subscribeAndRead . holdEvent

682

597

683--------------------------------------------------------------------------------

598--------------------------------------------------------------------------------

@@ -700,7 +615,7 @@ behaviorPull !p = Behavior $ do

700 val <- liftIO $ readIORef $ pullValue p

615 val <- liftIO $ readIORef $ pullValue p

701 case val of

616 case val of

702 Just subscribed -> do

617 Just subscribed -> do

703− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedPull subscribed)) :))

618+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))

704 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))

619 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))

705 liftIO $ touch $ pullSubscribedOwnInvalidator subscribed

620 liftIO $ touch $ pullSubscribedOwnInvalidator subscribed

706 return $ pullSubscribedValue subscribed

621 return $ pullSubscribedValue subscribed

@@ -709,7 +624,7 @@ behaviorPull !p = Behavior $ do

709 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"

624 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"

710 parentsRef <- liftIO $ newIORef []

625 parentsRef <- liftIO $ newIORef []

711 holdInits <- askBehaviorHoldInits

626 holdInits <- askBehaviorHoldInits

712− a <- liftIO $ runReaderIO (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)

627+ a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)

713 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator

628 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator

714 parents <- liftIO $ readIORef parentsRef

629 parents <- liftIO $ readIORef parentsRef

715 let subscribed = PullSubscribed

630 let subscribed = PullSubscribed

@@ -719,7 +634,7 @@ behaviorPull !p = Behavior $ do

719 , pullSubscribedParents = parents

634 , pullSubscribedParents = parents

720 }

635 }

721 liftIO $ writeIORef (pullValue p) $ Just subscribed

636 liftIO $ writeIORef (pullValue p) $ Just subscribed

722− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedPull subscribed)) :))

637+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))

723 return a

638 return a

724

639

725behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p)

640behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p)

@@ -730,8 +645,7 @@ readHoldTracked :: Hold x p -> BehaviorM x (PatchTarget p)

730readHoldTracked h = do

645readHoldTracked h = do

731 result <- liftIO $ readIORef $ holdValue h

646 result <- liftIO $ readIORef $ holdValue h

732 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))

647 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))

733− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedHold h)) :))

648+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))

734− liftIO $ touch h -- Otherwise, if this gets inlined enough, the hold's parent reference may get collected

735 return result

649 return result

736

650

737{-# INLINABLE readBehaviorUntracked #-}

651{-# INLINABLE readBehaviorUntracked #-}

@@ -744,46 +658,42 @@ readBehaviorUntracked b = do

744-- Dynamic

658-- Dynamic

745--------------------------------------------------------------------------------

659--------------------------------------------------------------------------------

746

660

747−type DynamicS x p = Dynamic x (PatchTarget p) p

661+data Dynamic x p = Dynamic

748−

662+ { dynamicCurrent :: !(Behavior x (PatchTarget p))

749−data Dynamic x target p = Dynamic

663+ , dynamicUpdated :: !(Event x p)

750− { dynamicCurrent :: !(Behavior x target)

751− , dynamicUpdated :: Event x p -- This must be lazy; see the comment on holdEvent --TODO: Would this let us eliminate `Dyn`?

752 }

664 }

753

665

754−deriving instance (HasSpiderTimeline x) => Functor (Dynamic x target)

666+dynamicHold :: HasSpiderTimeline x => Hold x p -> Dynamic x p

755−

756−

757−

758−

759−dynamicHold :: Hold x p -> DynamicS x p

760dynamicHold !h = Dynamic

667dynamicHold !h = Dynamic

761 { dynamicCurrent = behaviorHold h

668 { dynamicCurrent = behaviorHold h

762 , dynamicUpdated = eventHold h

669 , dynamicUpdated = eventHold h

763 }

670 }

764

671

765−dynamicHoldIdentity :: Hold x (Identity a) -> DynamicS x (Identity a)

672+dynamicHoldIdentity :: HasSpiderTimeline x => Hold x (Identity a) -> Dynamic x (Identity a)

766dynamicHoldIdentity = dynamicHold

673dynamicHoldIdentity = dynamicHold

767

674

768−dynamicConst :: PatchTarget p -> DynamicS x p

675+dynamicConst :: PatchTarget p -> Dynamic x p

769dynamicConst !a = Dynamic

676dynamicConst !a = Dynamic

770 { dynamicCurrent = behaviorConst a

677 { dynamicCurrent = behaviorConst a

771 , dynamicUpdated = eventNever

678 , dynamicUpdated = eventNever

772 }

679 }

773

680

774−dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> DynamicS x p

681+dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p

775dynamicDyn !d = Dynamic

682dynamicDyn !d = Dynamic

776 { dynamicCurrent = behaviorDyn d

683 { dynamicCurrent = behaviorDyn d

777 , dynamicUpdated = eventDyn d

684 , dynamicUpdated = eventDyn d

778 }

685 }

779

686

780−dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> DynamicS x (Identity a)

687+dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a)

781dynamicDynIdentity = dynamicDyn

688dynamicDynIdentity = dynamicDyn

782

689

783--------------------------------------------------------------------------------

690--------------------------------------------------------------------------------

784-- Combinators

691-- Combinators

785--------------------------------------------------------------------------------

692--------------------------------------------------------------------------------

786

693

694+--TODO: Figure out why certain things are not 'representational', then make them

695+--representational so we can use coerce

696+

787--type role Hold representational

697--type role Hold representational

788data Hold x p

698data Hold x p

789 = Hold { holdValue :: !(IORef (PatchTarget p))

699 = Hold { holdValue :: !(IORef (PatchTarget p))

@@ -795,7 +705,9 @@ data Hold x p

795#endif

705#endif

796 }

706 }

797

707

798−-- | A statically allocated 'SpiderTimeline'

708+-- | A statically allocated 'SpiderTimeline'; this is the only instance of

709+-- 'SpiderTimeline' that can used when using

710+-- -fspecialize-to-spidertimeline-global.

799data Global

711data Global

800

712

801{-# NOINLINE globalSpiderTimelineEnv #-}

713{-# NOINLINE globalSpiderTimelineEnv #-}

@@ -804,37 +716,27 @@ globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv

804

716

805-- | Stores all global data relevant to a particular Spider timeline; only one

717-- | Stores all global data relevant to a particular Spider timeline; only one

806-- value should exist for each type @x@

718-- value should exist for each type @x@

807−newtype SpiderTimelineEnv x = STE {unSTE :: SpiderTimelineEnv' x}

719+data SpiderTimelineEnv x = SpiderTimelineEnv

808−-- We implement SpiderTimelineEnv with a newtype wrapper so

809−-- we can get the coercions we want safely.

810−type role SpiderTimelineEnv nominal

811−

812−data SpiderTimelineEnv' x = SpiderTimelineEnv

813 { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())

720 { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())

814 , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)

721 , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)

815#ifdef DEBUG

722#ifdef DEBUG

816 , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)

723 , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)

817#endif

724#endif

818 }

725 }

819−type role SpiderTimelineEnv' phantom

726+type role SpiderTimelineEnv nominal

820−

821−instance Eq (SpiderTimelineEnv x) where

822− _ == _ = True -- Since only one exists of each type

823

727

824instance GEq SpiderTimelineEnv where

728instance GEq SpiderTimelineEnv where

825− a `geq` b = if _spiderTimeline_lock (unSTE a) == _spiderTimeline_lock (unSTE b)

729+ a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b

826 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments

730 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments

827 else Nothing

731 else Nothing

828

732

829data EventEnv x

733data EventEnv x

830 = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe

734 = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe

831 , eventEnvHoldInits :: !(IORef [SomeHoldInit x]) -- Needed for Subscribe

735 , eventEnvHoldInits :: !(IORef [SomeHoldInit x]) -- Needed for Subscribe

832− , eventEnvDynInits :: !(IORef [SomeDynInit x])

833 , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])

736 , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])

834 , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe

737 , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe

835− , eventEnvClears :: !(IORef [Some Clear]) -- Needed for Subscribe

738+ , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe

836− , eventEnvIntClears :: !(IORef [Some IntClear])

739+ , eventEnvRootClears :: !(IORef [SomeRootClear])

837− , eventEnvRootClears :: !(IORef [Some RootClear])

838 , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe

740 , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe

839 , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe

741 , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe

840 , eventEnvDelayedMerges :: !(IORef (IntMap [EventM x ()]))

742 , eventEnvDelayedMerges :: !(IORef (IntMap [EventM x ()]))

@@ -845,7 +747,7 @@ runEventM :: EventM x a -> IO a

845runEventM = unEventM

747runEventM = unEventM

846

748

847asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a

749asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a

848−asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (unSTE (spiderTimeline :: SpiderTimelineEnv x))

750+asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)

849

751

850class MonadIO m => Defer a m where

752class MonadIO m => Defer a m where

851 getDeferralQueue :: m (IORef [a])

753 getDeferralQueue :: m (IORef [a])

@@ -864,10 +766,6 @@ instance HasSpiderTimeline x => Defer (SomeHoldInit x) (EventM x) where

864 {-# INLINE getDeferralQueue #-}

766 {-# INLINE getDeferralQueue #-}

865 getDeferralQueue = asksEventEnv eventEnvHoldInits

767 getDeferralQueue = asksEventEnv eventEnvHoldInits

866

768

867−instance HasSpiderTimeline x => Defer (SomeDynInit x) (EventM x) where

868− {-# INLINE getDeferralQueue #-}

869− getDeferralQueue = asksEventEnv eventEnvDynInits

870−

871instance Defer (SomeHoldInit x) (BehaviorM x) where

769instance Defer (SomeHoldInit x) (BehaviorM x) where

872 {-# INLINE getDeferralQueue #-}

770 {-# INLINE getDeferralQueue #-}

873 getDeferralQueue = BehaviorM $ asks snd

771 getDeferralQueue = BehaviorM $ asks snd

@@ -894,7 +792,11 @@ instance HasSpiderTimeline x => HasCurrentHeight x (EventM x) where

894 delayedRef <- asksEventEnv eventEnvDelayedMerges

792 delayedRef <- asksEventEnv eventEnvDelayedMerges

895 liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [subscribed]

793 liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [subscribed]

896

794

795+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

796+class x ~ Global => HasSpiderTimeline x where

797+#else

897class HasSpiderTimeline x where

798class HasSpiderTimeline x where

799+#endif

898 -- | Retrieve the current SpiderTimelineEnv

800 -- | Retrieve the current SpiderTimelineEnv

899 spiderTimeline :: SpiderTimelineEnv x

801 spiderTimeline :: SpiderTimelineEnv x

900

802

@@ -906,29 +808,21 @@ putCurrentHeight h = do

906 heightRef <- asksEventEnv eventEnvCurrentHeight

808 heightRef <- asksEventEnv eventEnvCurrentHeight

907 liftIO $ writeIORef heightRef $! h

809 liftIO $ writeIORef heightRef $! h

908

810

909−instance HasSpiderTimeline x => Defer (Some Clear) (EventM x) where

811+instance HasSpiderTimeline x => Defer SomeClear (EventM x) where

910 {-# INLINE getDeferralQueue #-}

812 {-# INLINE getDeferralQueue #-}

911 getDeferralQueue = asksEventEnv eventEnvClears

813 getDeferralQueue = asksEventEnv eventEnvClears

912

814

913{-# INLINE scheduleClear #-}

815{-# INLINE scheduleClear #-}

914−scheduleClear :: Defer (Some Clear) m => IORef (Maybe a) -> m ()

816+scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()

915−scheduleClear r = defer $ Some $ Clear r

817+scheduleClear r = defer $ SomeClear r

916−

917−instance HasSpiderTimeline x => Defer (Some IntClear) (EventM x) where

918− {-# INLINE getDeferralQueue #-}

919− getDeferralQueue = asksEventEnv eventEnvIntClears

920

818

921−{-# INLINE scheduleIntClear #-}

819+instance HasSpiderTimeline x => Defer SomeRootClear (EventM x) where

922−scheduleIntClear :: Defer (Some IntClear) m => IORef (IntMap a) -> m ()

923−scheduleIntClear r = defer $ Some $ IntClear r

924−

925−instance HasSpiderTimeline x => Defer (Some RootClear) (EventM x) where

926 {-# INLINE getDeferralQueue #-}

820 {-# INLINE getDeferralQueue #-}

927 getDeferralQueue = asksEventEnv eventEnvRootClears

821 getDeferralQueue = asksEventEnv eventEnvRootClears

928

822

929{-# INLINE scheduleRootClear #-}

823{-# INLINE scheduleRootClear #-}

930−scheduleRootClear :: Defer (Some RootClear) m => IORef (DMap k Identity) -> m ()

824+scheduleRootClear :: Defer SomeRootClear m => IORef (DMap k Identity) -> m ()

931−scheduleRootClear r = defer $ Some $ RootClear r

825+scheduleRootClear r = defer $ SomeRootClear r

932

826

933instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where

827instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where

934 {-# INLINE getDeferralQueue #-}

828 {-# INLINE getDeferralQueue #-}

@@ -957,7 +851,7 @@ hold v0 e = do

957 return h

851 return h

958

852

959{-# INLINE getHoldEventSubscription #-}

853{-# INLINE getHoldEventSubscription #-}

960−getHoldEventSubscription :: forall p x. (HasSpiderTimeline x, Patch p) => Hold x p -> EventM x (EventSubscription x)

854+getHoldEventSubscription :: forall m p x. (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer SomeClear m, Patch p, HasCurrentHeight x m, Defer (SomeMergeInit x) m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x, m ~ EventM x) => Hold x p -> m (EventSubscription x)

961getHoldEventSubscription h = do

855getHoldEventSubscription h = do

962 ep <- liftIO $ readIORef $ holdParent h

856 ep <- liftIO $ readIORef $ holdParent h

963 case ep of

857 case ep of

@@ -983,9 +877,9 @@ getHoldEventSubscription h = do

983

877

984type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])

878type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])

985

879

880+--type role BehaviorM representational

986-- BehaviorM can sample behaviors

881-- BehaviorM can sample behaviors

987−newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderIO (BehaviorEnv x) a }

882+newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderT (BehaviorEnv x) IO a } deriving (Functor, Applicative, MonadIO, MonadFix)

988− deriving (Functor, Applicative, MonadIO, MonadFix, MonadReader (BehaviorEnv x))

989

883

990instance Monad (BehaviorM x) where

884instance Monad (BehaviorM x) where

991 {-# INLINE (>>=) #-}

885 {-# INLINE (>>=) #-}

@@ -994,16 +888,14 @@ instance Monad (BehaviorM x) where

994 BehaviorM x >> BehaviorM y = BehaviorM $ x >> y

888 BehaviorM x >> BehaviorM y = BehaviorM $ x >> y

995 {-# INLINE return #-}

889 {-# INLINE return #-}

996 return x = BehaviorM $ return x

890 return x = BehaviorM $ return x

997−#if !MIN_VERSION_base(4,13,0)

998 {-# INLINE fail #-}

891 {-# INLINE fail #-}

999 fail s = BehaviorM $ fail s

892 fail s = BehaviorM $ fail s

1000−#endif

1001

893

1002data BehaviorSubscribed x a

894data BehaviorSubscribed x a

1003 = forall p. BehaviorSubscribedHold (Hold x p)

895 = forall p. BehaviorSubscribedHold (Hold x p)

1004 | BehaviorSubscribedPull (PullSubscribed x a)

896 | BehaviorSubscribedPull (PullSubscribed x a)

1005

897

1006−newtype SomeBehaviorSubscribed x = SomeBehaviorSubscribed (Some (BehaviorSubscribed x))

898+data SomeBehaviorSubscribed x = forall a. SomeBehaviorSubscribed (BehaviorSubscribed x a)

1007

899

1008--type role PullSubscribed representational

900--type role PullSubscribed representational

1009data PullSubscribed x a

901data PullSubscribed x a

@@ -1038,7 +930,7 @@ data RootSubscribed x a = forall k. GCompare k => RootSubscribed

1038#endif

930#endif

1039 }

931 }

1040

932

1041−data Root x k

933+data Root x (k :: * -> *)

1042 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event

934 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event

1043 , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))

935 , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))

1044 , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))

936 , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))

@@ -1046,8 +938,6 @@ data Root x k

1046

938

1047data SomeHoldInit x = forall p. Patch p => SomeHoldInit !(Hold x p)

939data SomeHoldInit x = forall p. Patch p => SomeHoldInit !(Hold x p)

1048

940

1049−data SomeDynInit x = forall p. Patch p => SomeDynInit !(Dyn x p)

1050−

1051data SomeMergeUpdate x = SomeMergeUpdate

941data SomeMergeUpdate x = SomeMergeUpdate

1052 { _someMergeUpdate_update :: !(EventM x [EventSubscription x])

942 { _someMergeUpdate_update :: !(EventM x [EventSubscription x])

1053 , _someMergeUpdate_invalidateHeight :: !(IO ())

943 , _someMergeUpdate_invalidateHeight :: !(IO ())

@@ -1057,7 +947,16 @@ data SomeMergeUpdate x = SomeMergeUpdate

1057newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }

947newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }

1058

948

1059-- EventM can do everything BehaviorM can, plus create holds

949-- EventM can do everything BehaviorM can, plus create holds

1060−newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException)

950+newtype EventM x a = EventM { unEventM :: IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException) -- The environment should be Nothing if we are not in a frame, and Just if we are - in which case it is a list of assignments to be done after the frame is over

951+

952+newtype ComputeM x a = ComputeM (ReaderT (IORef [SomeHoldInit x]) IO a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

953+

954+instance Defer (SomeHoldInit x) (ComputeM x) where

955+ getDeferralQueue = ComputeM ask

956+

957+{-# INLINABLE runComputeM #-}

958+runComputeM :: Defer (SomeHoldInit x) m => ComputeM x a -> m a

959+runComputeM (ComputeM a) = liftIO . runReaderT a =<< getDeferralQueue

1061

960

1062newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }

961newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }

1063

962

@@ -1082,8 +981,7 @@ heightBagFromList :: [Height] -> HeightBag

1082heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights

981heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights

1083

982

1084heightBagAdd :: Height -> HeightBag -> HeightBag

983heightBagAdd :: Height -> HeightBag -> HeightBag

1085−heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $

984+heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $ IntMap.insertWithKey (\_ _ old -> succ old) h 0 c

1086− IntMap.insertWithKey (\_ _ old -> succ old) h 0 c

1087

985

1088heightBagRemove :: Height -> HeightBag -> HeightBag

986heightBagRemove :: Height -> HeightBag -> HeightBag

1089heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of

987heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of

@@ -1092,13 +990,6 @@ heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.loo

1092 0 -> IntMap.delete h c

990 0 -> IntMap.delete h c

1093 _ -> IntMap.insert h (pred old) c

991 _ -> IntMap.insert h (pred old) c

1094

992

1095−heightBagRemoveMaybe :: Height -> HeightBag -> Maybe HeightBag

1096−heightBagRemoveMaybe (Height h) b@(HeightBag s c) = heightBagVerify . removed <$> IntMap.lookup h c where

1097− removed old = HeightBag (pred s) $ case old of

1098− 0 -> IntMap.delete h c

1099− _ -> IntMap.insert h (pred old) c

1100−

1101−

1102heightBagMax :: HeightBag -> Height

993heightBagMax :: HeightBag -> Height

1103heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of

994heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of

1104 Just ((h, _), _) -> Height h

995 Just ((h, _), _) -> Height h

@@ -1116,25 +1007,25 @@ heightBagVerify b@(HeightBag s c) = if

1116heightBagVerify = id

1007heightBagVerify = id

1117#endif

1008#endif

1118

1009

1119−data FanSubscribedChildren x k v a = FanSubscribedChildren

1010+data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren

1120− { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x (v a)))

1011+ { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a))

1121− , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k v)

1012+ , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k)

1122− , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k v)))

1013+ , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k)))

1123 }

1014 }

1124

1015

1125−data FanSubscribed x k v

1016+data FanSubscribed (x :: *) k

1126− = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))

1017+ = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k)))

1127− , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k v)))

1018+ , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))

1128− , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k v))) -- This DMap should never be empty

1019+ , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty

1129 , fanSubscribedParent :: !(EventSubscription x)

1020 , fanSubscribedParent :: !(EventSubscription x)

1130#ifdef DEBUG_NODEIDS

1021#ifdef DEBUG_NODEIDS

1131 , fanSubscribedNodeId :: Int

1022 , fanSubscribedNodeId :: Int

1132#endif

1023#endif

1133 }

1024 }

1134

1025

1135−data Fan x k v

1026+data Fan x k

1136− = Fan { fanParent :: !(Event x (DMap k v))

1027+ = Fan { fanParent :: !(Event x (DMap k Identity))

1137− , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))

1028+ , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k)))

1138 }

1029 }

1139

1030

1140data SwitchSubscribed x a

1031data SwitchSubscribed x a

@@ -1188,35 +1079,20 @@ newInvalidatorSwitch subd = return $! InvalidatorSwitch subd

1188newInvalidatorPull :: Pull x a -> IO (Invalidator x)

1079newInvalidatorPull :: Pull x a -> IO (Invalidator x)

1189newInvalidatorPull p = return $! InvalidatorPull p

1080newInvalidatorPull p = return $! InvalidatorPull p

1190

1081

1191−instance HasSpiderTimeline x => Filterable (Event x) where

1082+instance HasSpiderTimeline x => FunctorMaybe (Event x) where

1192− mapMaybe f = push $ return . f

1083+ fmapMaybe f = push $ return . f

1193

1084

1194instance HasSpiderTimeline x => Align (Event x) where

1085instance HasSpiderTimeline x => Align (Event x) where

1195 nil = eventNever

1086 nil = eventNever

1196−#if MIN_VERSION_these(0, 8, 0)

1087+ align ea eb = fmapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]

1197−instance HasSpiderTimeline x => Semialign (Event x) where

1198−#endif

1199− align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $

1200− DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]

1201−

1202−#ifdef MIN_VERSION_semialign

1203−#if MIN_VERSION_semialign(1,1,0)

1204−instance HasSpiderTimeline x => Zip (Event x) where

1205−#endif

1206− zip x y = mapMaybe justThese $ align x y

1207−#endif

1208

1088

1209−data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)

1089+newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (PatchTarget p), Event x p) (Hold x p)) }

1210− | BuildDyn !(EventM x (PatchTarget p), Event x p)

1211− | HoldDyn !(Hold x p)

1212

1090

1213−newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }

1091+newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)

1214−

1092+newMapDyn f d = dynamicDynIdentity $ unsafeDyn (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)

1215−newMapDyn :: HasSpiderTimeline x => (a -> b) -> DynamicS x (Identity a) -> DynamicS x (Identity b)

1216−newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)

1217

1093

1218--TODO: Avoid the duplication between this and R.zipDynWith

1094--TODO: Avoid the duplication between this and R.zipDynWith

1219−zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> DynamicS x (Identity a) -> DynamicS x (Identity b) -> DynamicS x (Identity c)

1095+zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c)

1220zipDynWith f da db =

1096zipDynWith f da db =

1221 let eab = align (dynamicUpdated da) (dynamicUpdated db)

1097 let eab = align (dynamicUpdated da) (dynamicUpdated db)

1222 ec = flip push eab $ \o -> do

1098 ec = flip push eab $ \o -> do

@@ -1229,22 +1105,19 @@ zipDynWith f da db =

1229 return (a, b)

1105 return (a, b)

1230 These (Identity a) (Identity b) -> return (a, b)

1106 These (Identity a) (Identity b) -> return (a, b)

1231 return $ Just $ Identity $ f a b

1107 return $ Just $ Identity $ f a b

1232− in dynamicDynIdentity $ unsafeBuildDynamic (f <$> readBehaviorUntracked (dynamicCurrent da) <*> readBehaviorUntracked (dynamicCurrent db)) ec

1108+ in dynamicDynIdentity $ unsafeDyn (f <$> readBehaviorUntracked (dynamicCurrent da) <*> readBehaviorUntracked (dynamicCurrent db)) ec

1233−

1234−buildDynamic :: (Defer (SomeDynInit x) m, Patch p) => EventM x (PatchTarget p) -> Event x p -> m (Dyn x p)

1235−buildDynamic readV0 v' = do

1236− result <- liftIO $ newIORef $ BuildDyn (readV0, v')

1237− let !d = Dyn result

1238− defer $ SomeDynInit d

1239− return d

1240

1109

1241−unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p

1110+unsafeDyn :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p

1242−unsafeBuildDynamic readV0 v' =

1111+unsafeDyn readV0 v' = Dyn $ unsafeNewIORef x $ Left x

1243− Dyn $ unsafePerformIO $ newIORef $ UnsafeDyn (readV0, v')

1112+ where x = (readV0, v')

1244

1113

1245-- ResultM can read behaviors and events

1114-- ResultM can read behaviors and events

1246type ResultM = EventM

1115type ResultM = EventM

1247

1116

1117+{-# NOINLINE unsafeNewIORef #-}

1118+unsafeNewIORef :: a -> b -> IORef b

1119+unsafeNewIORef _ b = unsafePerformIO $ newIORef b

1120+

1248instance HasSpiderTimeline x => Functor (Event x) where

1121instance HasSpiderTimeline x => Functor (Event x) where

1249 fmap f = push $ return . Just . f

1122 fmap f = push $ return . Just . f

1250

1123

@@ -1257,42 +1130,33 @@ push f e = cacheEvent (pushCheap f e)

1257

1130

1258{-# INLINABLE pull #-}

1131{-# INLINABLE pull #-}

1259pull :: BehaviorM x a -> Behavior x a

1132pull :: BehaviorM x a -> Behavior x a

1260−pull a = unsafePerformIO $ do

1133+pull a = behaviorPull $ Pull

1261− ref <- newIORef Nothing

1134+ { pullCompute = a

1262−#ifdef DEBUG_NODEIDS

1135+ , pullValue = unsafeNewIORef a Nothing

1263− nid <- newNodeId

1264−#endif

1265− pure $ behaviorPull $ Pull

1266− { pullCompute = a

1267− , pullValue = ref

1268#ifdef DEBUG_NODEIDS

1136#ifdef DEBUG_NODEIDS

1269− , pullNodeId = nid

1137+ , pullNodeId = unsafeNodeId a

1270#endif

1138#endif

1271− }

1139+ }

1272

1140

1273{-# INLINABLE switch #-}

1141{-# INLINABLE switch #-}

1274switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a

1142switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a

1275−switch a = unsafePerformIO $ do

1143+switch a = eventSwitch $ Switch

1276− ref <- newIORef Nothing

1144+ { switchParent = a

1277− pure $ eventSwitch $ Switch

1145+ , switchSubscribed = unsafeNewIORef a Nothing

1278− { switchParent = a

1146+ }

1279− , switchSubscribed = ref

1280− }

1281

1147

1282coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a

1148coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a

1283−coincidence a = unsafePerformIO $ do

1149+coincidence a = eventCoincidence $ Coincidence

1284− ref <- newIORef Nothing

1150+ { coincidenceParent = a

1285− pure $ eventCoincidence $ Coincidence

1151+ , coincidenceSubscribed = unsafeNewIORef a Nothing

1286− { coincidenceParent = a

1152+ }

1287− , coincidenceSubscribed = ref

1288− }

1289

1153

1290-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors

1154-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors

1291run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b

1155run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b

1292run roots after = do

1156run roots after = do

1293 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"

1157 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"

1294− let t = spiderTimeline :: SpiderTimelineEnv x

1158+ t <- SpiderHost ask

1295− result <- SpiderHost $ withMVar (_spiderTimeline_lock (unSTE t)) $ \_ -> unSpiderHost $ runFrame $ do

1159+ result <- SpiderHost $ lift $ withMVar (_spiderTimeline_lock t) $ \_ -> flip runReaderT t $ unSpiderHost $ runFrame $ do

1296 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do

1160 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do

1297 occBefore <- liftIO $ do

1161 occBefore <- liftIO $ do

1298 occBefore <- readIORef occRef

1162 occBefore <- readIORef occRef

@@ -1330,11 +1194,9 @@ scheduleMerge' initialHeight heightRef a = scheduleMerge initialHeight $ do

1330 GT -> scheduleMerge' height heightRef a -- The height has been increased (by a coincidence event; TODO: is this the only way?)

1194 GT -> scheduleMerge' height heightRef a -- The height has been increased (by a coincidence event; TODO: is this the only way?)

1331 EQ -> a

1195 EQ -> a

1332

1196

1333−newtype Clear a = Clear (IORef (Maybe a))

1197+data SomeClear = forall a. SomeClear (IORef (Maybe a))

1334−

1335−newtype IntClear a = IntClear (IORef (IntMap a))

1336

1198

1337−newtype RootClear k = RootClear (IORef (DMap k Identity))

1199+data SomeRootClear = forall k. SomeRootClear (IORef (DMap k Identity))

1338

1200

1339data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a

1201data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a

1340

1202

@@ -1346,110 +1208,55 @@ mkWeakPtrWithDebug x debugNote = do

1346 x' <- evaluate x

1208 x' <- evaluate x

1347 mkWeakPtr x' $

1209 mkWeakPtr x' $

1348 if debugFinalize

1210 if debugFinalize

1349− then Just $ debugStrLn $ "finalizing: " ++ debugNote

1211+ then Just $ putStrLn $ "finalizing: " ++ debugNote

1350 else Nothing

1212 else Nothing

1351

1213

1352type WeakList a = [Weak a]

1214type WeakList a = [Weak a]

1353

1215

1354−type CanTrace x m = (HasSpiderTimeline x, MonadIO m)

1355−

1356−

1357−

1358−

1359−#ifdef DEBUG

1360−

1361−debugSubscriber :: forall x a. HasSpiderTimeline x => String -> Subscriber x a -> IO (Subscriber x a)

1362−debugSubscriber description = return . debugSubscriber' description

1363−

1364−debugSubscriber' :: forall x a. HasSpiderTimeline x => String -> Subscriber x a -> Subscriber x a

1365−debugSubscriber' description subscribed = Subscriber

1366− {

1367− subscriberPropagate = \m -> do

1368− tracePropagate (Proxy :: Proxy x) ("subscriberPropagate: " <> description)

1369− subscriberPropagate subscribed m

1370− , subscriberInvalidateHeight = \old -> do

1371− traceInvalidateHeight $ "invalidateSubscriberHeight: " <> description <> ", old = " <> show (unHeight old)

1372− subscriberInvalidateHeight subscribed old

1373− traceInvalidateHeight $ "invalidateSubscriberHeight: " <> description <> ", done"

1374− , subscriberRecalculateHeight = \new -> do

1375− traceInvalidateHeight $ "subscriberRecalculateHeight: " <> description <> ", new = " <> show (unHeight new)

1376− subscriberRecalculateHeight subscribed new

1377− traceInvalidateHeight $ "subscriberRecalculateHeight: " <> description <> ", done"

1378− }

1379−

1380−

1381{-# INLINE withIncreasedDepth #-}

1216{-# INLINE withIncreasedDepth #-}

1382−withIncreasedDepth :: forall proxy x m a. CanTrace x m => proxy x -> m a -> m a

1217+#ifdef DEBUG

1383−withIncreasedDepth _ a = do

1218+withIncreasedDepth :: CanTrace x m => m a -> m a

1384− liftIO $ modifyIORef' (_spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)) succ

1219+withIncreasedDepth a = do

1220+ spiderTimeline <- askSpiderTimelineEnv

1221+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ

1385 result <- a

1222 result <- a

1386− liftIO $ modifyIORef' (_spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)) pred

1223+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred

1387 return result

1224 return result

1388−

1389−{-# INLINE tracePropagate #-}

1390−tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()

1391−tracePropagate p = when debugPropagate . trace p

1392−

1393−{-# INLINE traceInvalidate #-}

1394−traceInvalidate :: String -> IO ()

1395−traceInvalidate = when debugInvalidate . liftIO . debugStrLn

1396−

1397−{-# INLINE traceInvalidateHeight #-}

1398−traceInvalidateHeight :: String -> IO ()

1399−traceInvalidateHeight = when debugInvalidateHeight . liftIO . debugStrLn

1400−

1401−{-# INLINE trace #-}

1402−trace :: (CanTrace x m) => proxy x -> String -> m ()

1403−trace p message = traceM p $ return message

1404−

1405−{-# INLINE traceM #-}

1406−traceM :: forall x proxy m. (CanTrace x m) => proxy x -> m String -> m ()

1407−traceM _ getMessage = do

1408− message <- getMessage

1409− d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)

1410− liftIO $ debugStrLn $ replicate d ' ' <> message

1411−

1412#else

1225#else

1226+withIncreasedDepth :: m a -> m a

1227+withIncreasedDepth = id

1228+#endif

1413

1229

1414−{-# INLINE withIncreasedDepth #-}

1230+type CanTrace x m = (HasSpiderTimeline x, MonadIO m)

1415−withIncreasedDepth :: proxy x -> m a -> m a

1416−withIncreasedDepth _ = id

1417

1231

1418{-# INLINE tracePropagate #-}

1232{-# INLINE tracePropagate #-}

1419tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()

1233tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()

1420−tracePropagate _ _ = return ()

1234+tracePropagate p = traceWhen p debugPropagate

1421

1235

1422{-# INLINE traceInvalidate #-}

1236{-# INLINE traceInvalidate #-}

1423traceInvalidate :: String -> IO ()

1237traceInvalidate :: String -> IO ()

1424−traceInvalidate _ = return ()

1238+traceInvalidate = when debugInvalidate . liftIO . putStrLn

1425−

1426−{-# INLINE traceInvalidateHeight #-}

1427−traceInvalidateHeight :: String -> IO ()

1428−traceInvalidateHeight _ = return ()

1429−

1430−{-# INLINE debugSubscriber #-}

1431−debugSubscriber :: String -> Subscriber x a -> IO (Subscriber x a)

1432−debugSubscriber _ = return

1433

1239

1434−{-# INLINE debugSubscriber' #-}

1240+{-# INLINE traceWhen #-}

1435−debugSubscriber' :: String -> Subscriber x a -> Subscriber x a

1241+traceWhen :: (CanTrace x m) => proxy x -> Bool -> String -> m ()

1436−debugSubscriber' _ = id

1242+traceWhen p b message = traceMWhen p b $ return message

1437−

1438−

1439−

1440−{-# INLINE trace #-}

1441−trace :: (CanTrace x m) => proxy x -> String -> m ()

1442−trace _ _ = return ()

1443−

1444−{-# INLINE traceM #-}

1445−traceM :: (CanTrace x m) => proxy x -> m String -> m ()

1446−traceM _ _ = return ()

1447

1243

1244+{-# INLINE traceMWhen #-}

1245+traceMWhen :: (CanTrace x m) => proxy x -> Bool -> m String -> m ()

1246+traceMWhen _ b getMessage = when b $ do

1247+ message <- getMessage

1248+#ifdef DEBUG

1249+ spiderTimeline <- askSpiderTimelineEnv

1250+ d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline

1251+#else

1252+ let d = 0

1448#endif

1253#endif

1254+ liftIO $ putStrLn $ replicate d ' ' <> message

1449

1255

1450whoCreatedIORef :: IORef a -> IO [String]

1256whoCreatedIORef :: IORef a -> IO [String]

1451whoCreatedIORef (IORef a) = whoCreated $! a

1257whoCreatedIORef (IORef a) = whoCreated $! a

1452

1258

1259+#ifdef DEBUG_CYCLES

1453groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]

1260groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]

1454groupByHead = \case

1261groupByHead = \case

1455 [] -> []

1262 [] -> []

@@ -1460,54 +1267,20 @@ groupByHead = \case

1460 | otherwise -> (x, xs :| []) : l

1267 | otherwise -> (x, xs :| []) : l

1461

1268

1462listsToForest :: Eq a => [[a]] -> Forest a

1269listsToForest :: Eq a => [[a]] -> Forest a

1463−listsToForest lists = buildForest <$> groupByHead (mapMaybe nonEmpty lists)

1270+listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l

1464− where buildForest (a, lists') = Node a $ listsToForest $ toList lists'

1465−

1466−showStacks :: [[String]] -> String

1467−showStacks = drawForest . listsToForest . fmap (filterStack "Reflex.Spider.Internal")

1468−

1469−filterStack :: String -> [String] -> [String]

1470−#ifdef DEBUG_HIDE_INTERNALS

1471−filterStack prefix = filter (not . (prefix `isPrefixOf`))

1472−#else

1473−filterStack prefix = id

1474−#endif

1475−

1476−#ifdef DEBUG_CYCLES

1477−

1478−data EventLoopException = EventLoopException [[String]]

1479−instance Exception EventLoopException

1480−

1481−instance Show EventLoopException where

1482− show (EventLoopException stacks) = "causality loop detected:\n" <> if null stacks

1483− then "no location information, compile with profiling enabled for stack tree"

1484− else showStacks stacks

1485−

1486−#else

1487−

1488−data EventLoopException = EventLoopException

1489−instance Exception EventLoopException

1490−

1491−instance Show EventLoopException where

1492− show EventLoopException = "causality loop detected: \n" <>

1493− "compile reflex with flag 'debug-cycles' and compile with profiling enabled for stack tree"

1494−

1495#endif

1271#endif

1496

1272

1497−

1498{-# INLINE propagateSubscriberHold #-}

1273{-# INLINE propagateSubscriberHold #-}

1499propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()

1274propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()

1500propagateSubscriberHold h a = do

1275propagateSubscriberHold h a = do

1501− {-# SCC "trace" #-} when debugPropagate $ traceM (Proxy :: Proxy x) $ liftIO $ do

1276+ {-# SCC "trace" #-} traceMWhen (Proxy :: Proxy x) debugPropagate $ liftIO $ do

1502 invalidators <- liftIO $ readIORef $ holdInvalidators h

1277 invalidators <- liftIO $ readIORef $ holdInvalidators h

1503 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)

1278 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)

1504−

1505 v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h

1279 v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h

1506 case {-# SCC "apply" #-} apply a v of

1280 case {-# SCC "apply" #-} apply a v of

1507 Nothing -> return ()

1281 Nothing -> return ()

1508 Just v' -> do

1282 Just v' -> do

1509− {-# SCC "trace2" #-} withIncreasedDepth (Proxy :: Proxy x) $

1283+ {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate (Proxy :: Proxy x) $ "propagateSubscriberHold: assigning Hold" <> showNodeId h

1510− tracePropagate (Proxy :: Proxy x) ("propagateSubscriberHold: assigning Hold" <> showNodeId h)

1511 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h

1284 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h

1512 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h

1285 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h

1513 defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'

1286 defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'

@@ -1515,25 +1288,25 @@ propagateSubscriberHold h a = do

1515data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset

1288data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset

1516

1289

1517runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a

1290runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a

1518−runBehaviorM a mwi holdInits = runReaderIO (unBehaviorM a) (mwi, holdInits)

1291+runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)

1519

1292

1520askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))

1293askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))

1521askInvalidator = do

1294askInvalidator = do

1522− (!m, _) <- ask

1295+ (!m, _) <- BehaviorM ask

1523 case m of

1296 case m of

1524 Nothing -> return Nothing

1297 Nothing -> return Nothing

1525 Just (!wi, _) -> return $ Just wi

1298 Just (!wi, _) -> return $ Just wi

1526

1299

1527askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))

1300askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))

1528askParentsRef = do

1301askParentsRef = do

1529− (!m, _) <- ask

1302+ (!m, _) <- BehaviorM ask

1530 case m of

1303 case m of

1531 Nothing -> return Nothing

1304 Nothing -> return Nothing

1532 Just (_, !p) -> return $ Just p

1305 Just (_, !p) -> return $ Just p

1533

1306

1534askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])

1307askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])

1535askBehaviorHoldInits = do

1308askBehaviorHoldInits = do

1536− (_, !his) <- ask

1309+ (_, !his) <- BehaviorM ask

1537 return his

1310 return his

1538

1311

1539{-# INLINE getDynHold #-}

1312{-# INLINE getDynHold #-}

@@ -1541,27 +1314,30 @@ getDynHold :: (Defer (SomeHoldInit x) m, Patch p) => Dyn x p -> m (Hold x p)

1541getDynHold d = do

1314getDynHold d = do

1542 mh <- liftIO $ readIORef $ unDyn d

1315 mh <- liftIO $ readIORef $ unDyn d

1543 case mh of

1316 case mh of

1544− HoldDyn h -> return h

1317+ Right h -> return h

1545− UnsafeDyn (readV0, v') -> do

1318+ Left (readV0, v') -> do

1546 holdInits <- getDeferralQueue

1319 holdInits <- getDeferralQueue

1547 v0 <- liftIO $ runBehaviorM readV0 Nothing holdInits

1320 v0 <- liftIO $ runBehaviorM readV0 Nothing holdInits

1548− hold' v0 v'

1549− BuildDyn (readV0, v') -> do

1550− v0 <- liftIO $ runEventM readV0

1551− hold' v0 v'

1552− where

1553− hold' v0 v' = do

1554 h <- hold v0 v'

1321 h <- hold v0 v'

1555− liftIO $ writeIORef (unDyn d) $ HoldDyn h

1322+ liftIO $ writeIORef (unDyn d) $ Right h

1556 return h

1323 return h

1557

1324

1558−

1559-- Always refers to 0

1325-- Always refers to 0

1560{-# NOINLINE zeroRef #-}

1326{-# NOINLINE zeroRef #-}

1561zeroRef :: IORef Height

1327zeroRef :: IORef Height

1562zeroRef = unsafePerformIO $ newIORef zeroHeight

1328zeroRef = unsafePerformIO $ newIORef zeroHeight

1563

1329

1564−getRootSubscribed :: forall k x a. (GCompare k, HasSpiderTimeline x) => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)

1330+type CanSubscribe x m =

1331+ ( HasSpiderTimeline x

1332+ , HasCurrentHeight x m

1333+ , Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m -- The things we need to lazily initialize state

1334+ , Defer SomeClear m -- Wiping out event firings

1335+ , Defer (SomeAssignment x) m -- Updating state

1336+ , Defer (SomeResetCoincidence x) m

1337+ , m ~ EventM x

1338+ )

1339+

1340+getRootSubscribed :: GCompare k => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)

1565getRootSubscribed k r sub = do

1341getRootSubscribed k r sub = do

1566 mSubscribed <- readIORef $ rootSubscribed r

1342 mSubscribed <- readIORef $ rootSubscribed r

1567 let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r

1343 let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r

@@ -1575,14 +1351,9 @@ getRootSubscribed k r sub = do

1575 let !cached = rootSubscribed r

1351 let !cached = rootSubscribed r

1576 uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"

1352 uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"

1577 (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed

1353 (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed

1578−

1354+ when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"

1579− tracePropagate (Proxy::Proxy x) $ "getRootSubscribed: calling rootInit"

1580−

1581 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)

1355 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)

1582 writeIORef uninitRef $! uninit

1356 writeIORef uninitRef $! uninit

1583−#ifdef DEBUG_NODEIDS

1584− nid <- newNodeId

1585−#endif

1586 let !subscribed = RootSubscribed

1357 let !subscribed = RootSubscribed

1587 { rootSubscribedKey = k

1358 { rootSubscribedKey = k

1588 , rootSubscribedCachedSubscribed = cached

1359 , rootSubscribedCachedSubscribed = cached

@@ -1591,7 +1362,7 @@ getRootSubscribed k r sub = do

1591 , rootSubscribedUninit = uninit

1362 , rootSubscribedUninit = uninit

1592 , rootSubscribedWeakSelf = weakSelf

1363 , rootSubscribedWeakSelf = weakSelf

1593#ifdef DEBUG_NODEIDS

1364#ifdef DEBUG_NODEIDS

1594− , rootSubscribedNodeId = nid

1365+ , rootSubscribedNodeId = unsafeNodeId (k, r, subs)

1595#endif

1366#endif

1596 }

1367 }

1597 -- If we die at the same moment that all our children die, they will

1368 -- If we die at the same moment that all our children die, they will

@@ -1621,90 +1392,8 @@ cleanupRootSubscribed self@RootSubscribed { rootSubscribedKey = k, rootSubscribe

1621subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO WeakBagTicket

1392subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO WeakBagTicket

1622subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed

1393subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed

1623

1394

1624−newtype EventSelectorInt x a = EventSelectorInt { selectInt :: Int -> Event x a }

1625−

1626−data FanInt x a = FanInt

1627− { _fanInt_subscribers :: {-# UNPACK #-} !(FastMutableIntMap (FastWeakBag (Subscriber x a))) --TODO: Clean up the keys in here when their child weak bags get empty --TODO: Remove our own subscription when the subscribers list is completely empty

1628− , _fanInt_subscriptionRef :: {-# UNPACK #-} !(IORef (EventSubscription x)) -- This should have a valid subscription iff subscribers is non-empty

1629− , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a))

1630−#ifdef DEBUG_NODEIDS

1631− , _fanInt_nodeId :: {-# UNPACK #-} !Int

1632−#endif

1633− }

1634−

1635−newFanInt :: IO (FanInt x a)

1636−newFanInt = do

1637− subscribers <- FastMutableIntMap.newEmpty --TODO: Clean up the keys in here when their child weak bags get empty --TODO: Remove our own subscription when the subscribers list is completely empty

1638− subscriptionRef <- newIORef $ error "fanInt: no subscription"

1639− occRef <- newIORef $ error "fanInt: no occurrence"

1640−#ifdef DEBUG_NODEIDS

1641− nodeId <- newNodeId

1642−#endif

1643− return $ FanInt

1644− { _fanInt_subscribers = subscribers

1645− , _fanInt_subscriptionRef = subscriptionRef

1646− , _fanInt_occRef = occRef

1647−#ifdef DEBUG_NODEIDS

1648− , _fanInt_nodeId = nodeId

1649−#endif

1650− }

1651−

1652−fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a

1653−fanInt p = unsafePerformIO $ do

1654− self <- newFanInt

1655− pure $ EventSelectorInt $ \k -> Event $ \sub -> do

1656− isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)

1657− when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input

1658− let desc = "fanInt" <> showNodeId self <> ", k = " <> show k

1659− (subscription, parentOcc) <- subscribeAndRead p $ debugSubscriber' desc $ Subscriber

1660− { subscriberPropagate = \m -> do

1661− liftIO $ writeIORef (_fanInt_occRef self) m

1662− scheduleIntClear $ _fanInt_occRef self

1663− FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> --TODO: Do we need to know that no subscribers are being added as we traverse?

1664− FastWeakBag.traverse_ b $ \s ->

1665− subscriberPropagate s v

1666− , subscriberInvalidateHeight = \old ->

1667− FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->

1668− FastWeakBag.traverse_ b $ \s ->

1669− subscriberInvalidateHeight s old

1670− , subscriberRecalculateHeight = \new ->

1671− FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b ->

1672− FastWeakBag.traverse_ b $ \s ->

1673− subscriberRecalculateHeight s new

1674− }

1675− liftIO $ do

1676− writeIORef (_fanInt_subscriptionRef self) subscription

1677− writeIORef (_fanInt_occRef self) $ fromMaybe IntMap.empty parentOcc

1678− scheduleIntClear $ _fanInt_occRef self

1679− liftIO $ do

1680− b <- FastMutableIntMap.lookup (_fanInt_subscribers self) k >>= \case

1681− Nothing -> do

1682− b <- FastWeakBag.empty

1683− FastMutableIntMap.insert (_fanInt_subscribers self) k b

1684− return b

1685− Just b -> return b

1686− ticket <- liftIO $ FastWeakBag.insert sub b

1687− currentOcc <- readIORef (_fanInt_occRef self)

1688−

1689− subscribed <- fanIntSubscribed ticket self

1690− return (EventSubscription (FastWeakBag.remove ticket) subscribed, IntMap.lookup k currentOcc)

1691−

1692−fanIntSubscribed :: FastWeakBagTicket k -> FanInt x a -> IO (EventSubscribed x)

1693−fanIntSubscribed ticket self = do

1694− subscribedParent <- _eventSubscription_subscribed <$> readIORef (_fanInt_subscriptionRef self)

1695− return $ EventSubscribed

1696− { eventSubscribedHeightRef = eventSubscribedHeightRef subscribedParent

1697− , eventSubscribedRetained = toAny (_fanInt_subscriptionRef self, ticket)

1698−#ifdef DEBUG_CYCLES

1699− , eventSubscribedGetParents = return [subscribedParent]

1700− , eventSubscribedHasOwnHeightRef = False

1701− , eventSubscribedWhoCreated = whoCreatedIORef $ _fanInt_subscriptionRef self

1702−#endif

1703− }

1704−

1705−

1706{-# INLINABLE getFanSubscribed #-}

1395{-# INLINABLE getFanSubscribed #-}

1707−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))

1396+getFanSubscribed :: (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, HasCurrentHeight x m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x, m ~ EventM x, GCompare k) => k a -> Fan x k -> Subscriber x a -> m (WeakBagTicket, FanSubscribed x k, Maybe a)

1708getFanSubscribed k f sub = do

1397getFanSubscribed k f sub = do

1709 mSubscribed <- liftIO $ readIORef $ fanSubscribed f

1398 mSubscribed <- liftIO $ readIORef $ fanSubscribed f

1710 case mSubscribed of

1399 case mSubscribed of

@@ -1722,16 +1411,13 @@ getFanSubscribed k f sub = do

1722 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"

1411 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"

1723 occRef <- liftIO $ newIORef parentOcc

1412 occRef <- liftIO $ newIORef parentOcc

1724 when (isJust parentOcc) $ scheduleClear occRef

1413 when (isJust parentOcc) $ scheduleClear occRef

1725−#ifdef DEBUG_NODEIDS

1726− nid <- liftIO newNodeId

1727−#endif

1728 let subscribed = FanSubscribed

1414 let subscribed = FanSubscribed

1729 { fanSubscribedCachedSubscribed = fanSubscribed f

1415 { fanSubscribedCachedSubscribed = fanSubscribed f

1730 , fanSubscribedOccurrence = occRef

1416 , fanSubscribedOccurrence = occRef

1731 , fanSubscribedParent = subscription

1417 , fanSubscribedParent = subscription

1732 , fanSubscribedSubscribers = subscribersRef

1418 , fanSubscribedSubscribers = subscribersRef

1733#ifdef DEBUG_NODEIDS

1419#ifdef DEBUG_NODEIDS

1734− , fanSubscribedNodeId = nid

1420+ , fanSubscribedNodeId = unsafeNodeId f

1735#endif

1421#endif

1736 }

1422 }

1737 let !self = (k, subscribed)

1423 let !self = (k, subscribed)

@@ -1741,7 +1427,7 @@ getFanSubscribed k f sub = do

1741 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed

1427 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed

1742 return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)

1428 return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)

1743

1429

1744−cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k v) -> IO ()

1430+cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO ()

1745cleanupFanSubscribed (k, subscribed) = do

1431cleanupFanSubscribed (k, subscribed) = do

1746 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

1432 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

1747 let reducedSubscribers = DMap.delete k subscribers

1433 let reducedSubscribers = DMap.delete k subscribers

@@ -1753,7 +1439,7 @@ cleanupFanSubscribed (k, subscribed) = do

1753 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers

1439 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers

1754

1440

1755{-# INLINE subscribeFanSubscribed #-}

1441{-# INLINE subscribeFanSubscribed #-}

1756−subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k v -> Subscriber x (v a) -> IO WeakBagTicket

1442+subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO WeakBagTicket

1757subscribeFanSubscribed k subscribed sub = do

1443subscribeFanSubscribed k subscribed sub = do

1758 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

1444 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

1759 case DMap.lookup k subscribers of

1445 case DMap.lookup k subscribers of

@@ -1766,7 +1452,7 @@ subscribeFanSubscribed k subscribed sub = do

1766 Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed

1452 Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed

1767

1453

1768{-# INLINABLE getSwitchSubscribed #-}

1454{-# INLINABLE getSwitchSubscribed #-}

1769−getSwitchSubscribed :: HasSpiderTimeline x => Switch x a -> Subscriber x a -> EventM x (WeakBagTicket, SwitchSubscribed x a, Maybe a)

1455+getSwitchSubscribed :: (Defer (SomeHoldInit x) m, Defer (SomeAssignment x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, Defer (SomeResetCoincidence x) m, HasCurrentHeight x m, HasSpiderTimeline x, m ~ EventM x) => Switch x a -> Subscriber x a -> m (WeakBagTicket, SwitchSubscribed x a, Maybe a)

1770getSwitchSubscribed s sub = do

1456getSwitchSubscribed s sub = do

1771 mSubscribed <- liftIO $ readIORef $ switchSubscribed s

1457 mSubscribed <- liftIO $ readIORef $ switchSubscribed s

1772 case mSubscribed of

1458 case mSubscribed of

@@ -1791,9 +1477,6 @@ getSwitchSubscribed s sub = do

1791 when (isJust parentOcc) $ scheduleClear occRef

1477 when (isJust parentOcc) $ scheduleClear occRef

1792 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"

1478 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"

1793 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed

1479 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed

1794−#ifdef DEBUG_NODEIDS

1795− nid <- liftIO newNodeId

1796−#endif

1797 let !subscribed = SwitchSubscribed

1480 let !subscribed = SwitchSubscribed

1798 { switchSubscribedCachedSubscribed = switchSubscribed s

1481 { switchSubscribedCachedSubscribed = switchSubscribed s

1799 , switchSubscribedOccurrence = occRef

1482 , switchSubscribedOccurrence = occRef

@@ -1806,7 +1489,7 @@ getSwitchSubscribed s sub = do

1806 , switchSubscribedCurrentParent = subscriptionRef

1489 , switchSubscribedCurrentParent = subscriptionRef

1807 , switchSubscribedWeakSelf = weakSelf

1490 , switchSubscribedWeakSelf = weakSelf

1808#ifdef DEBUG_NODEIDS

1491#ifdef DEBUG_NODEIDS

1809− , switchSubscribedNodeId = nid

1492+ , switchSubscribedNodeId = unsafeNodeId s

1810#endif

1493#endif

1811 }

1494 }

1812 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"

1495 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"

@@ -1825,7 +1508,7 @@ subscribeSwitchSubscribed :: SwitchSubscribed x a -> Subscriber x a -> IO WeakBa

1825subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed

1508subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed

1826

1509

1827{-# INLINABLE getCoincidenceSubscribed #-}

1510{-# INLINABLE getCoincidenceSubscribed #-}

1828−getCoincidenceSubscribed :: forall x a. HasSpiderTimeline x => Coincidence x a -> Subscriber x a -> EventM x (WeakBagTicket, CoincidenceSubscribed x a, Maybe a)

1511+getCoincidenceSubscribed :: forall x a m. (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, HasCurrentHeight x m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x, m ~ EventM x) => Coincidence x a -> Subscriber x a -> m (WeakBagTicket, CoincidenceSubscribed x a, Maybe a)

1829getCoincidenceSubscribed c sub = do

1512getCoincidenceSubscribed c sub = do

1830 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c

1513 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c

1831 case mSubscribed of

1514 case mSubscribed of

@@ -1851,9 +1534,6 @@ getCoincidenceSubscribed c sub = do

1851 scheduleClear innerSubdRef

1534 scheduleClear innerSubdRef

1852 weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"

1535 weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"

1853 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed

1536 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed

1854−#ifdef DEBUG_NODEIDS

1855− nid <- liftIO newNodeId

1856−#endif

1857 let subscribed = CoincidenceSubscribed

1537 let subscribed = CoincidenceSubscribed

1858 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c

1538 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c

1859 , coincidenceSubscribedOccurrence = occRef

1539 , coincidenceSubscribedOccurrence = occRef

@@ -1864,7 +1544,7 @@ getCoincidenceSubscribed c sub = do

1864 , coincidenceSubscribedInnerParent = innerSubdRef

1544 , coincidenceSubscribedInnerParent = innerSubdRef

1865 , coincidenceSubscribedWeakSelf = weakSelf

1545 , coincidenceSubscribedWeakSelf = weakSelf

1866#ifdef DEBUG_NODEIDS

1546#ifdef DEBUG_NODEIDS

1867− , coincidenceSubscribedNodeId = nid

1547+ , coincidenceSubscribedNodeId = unsafeNodeId c

1868#endif

1548#endif

1869 }

1549 }

1870 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"

1550 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"

@@ -1881,259 +1561,189 @@ cleanupCoincidenceSubscribed subscribed = do

1881subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket

1561subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket

1882subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed

1562subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed

1883

1563

1884−{-# INLINE mergeG #-}

1564+{-# INLINE merge #-}

1885−mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k)

1565+merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)

1886− => (forall a. q a -> Event x (v a))

1566+merge d = cacheEvent (mergeCheap d)

1887− -> DynamicS x (PatchDMap k q) -> Event x (DMap k v)

1888−mergeG nt d = cacheEvent (mergeCheap nt d)

1889

1567

1890{-# INLINE mergeWithMove #-}

1568{-# INLINE mergeWithMove #-}

1891−mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k)

1569+mergeWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)

1892− => (forall a. q a -> Event x (v a))

1570+mergeWithMove d = cacheEvent (mergeCheapWithMove d)

1893− -> DynamicS x (PatchDMapWithMove k q) -> Event x (DMap k v)

1894−mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)

1895

1571

1896{-# INLINE [1] mergeCheap #-}

1572{-# INLINE [1] mergeCheap #-}

1897−mergeCheap

1573+mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)

1898− :: forall k x q v. (HasSpiderTimeline x, GCompare k)

1574+mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy DMap.size

1899− => (forall a. q a -> Event x (v a))

1900− -> DynamicS x (PatchDMap k q)

1901− -> Event x (DMap k v)

1902−mergeCheap nt = mergeGCheap' unMergeSubscribedParent getInitialSubscribers updateMe destroy

1903 where

1575 where

1904− updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)

1576+ updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)

1905 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do

1577 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do

1906 let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do

1578 let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do

1907 (mOldSubd, newPs) <- case me of

1579 (mOldSubd, newPs) <- case me of

1908 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps

1580 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps

1909 Just e -> do

1581 Just e -> do

1910 let s = subscriber $ return k

1582 let s = subscriber $ return k

1911− subscription@(EventSubscription _ subd) <- subscribe (nt e) s

1583+ subscription@(EventSubscription _ subd) <- subscribe e s

1912 newParentHeight <- liftIO $ getEventSubscribedHeight subd

1584 newParentHeight <- liftIO $ getEventSubscribedHeight subd

1913 let newParent = MergeSubscribedParent subscription

1585 let newParent = MergeSubscribedParent subscription

1914 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight

1586 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight

1915 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps

1587 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps

1916 forM_ mOldSubd $ \oldSubd -> do

1588 forM_ mOldSubd $ \oldSubd -> do

1917− oldHeight <- liftIO $ getEventSubscribedHeight $

1589+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd

1918− _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd

1919−

1920 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

1590 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

1921 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)

1591 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)

1922 foldM f ([], oldParents) $ DMap.toList p

1592 foldM f ([], oldParents) $ DMap.toList p

1923−

1593+ getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParent x)

1924− getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParent x)

1925 getInitialSubscribers initialParents subscriber = do

1594 getInitialSubscribers initialParents subscriber = do

1926 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do

1595 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do

1927 let s = subscriber $ return k

1596 let s = subscriber $ return k

1928− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s

1597+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s

1929 height <- liftIO $ getEventSubscribedHeight parentSubd

1598 height <- liftIO $ getEventSubscribedHeight parentSubd

1930− return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParent subscription)

1599+ return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription)

1931 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers

1600 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers

1932 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here

1601 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here

1933 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers

1602 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers

1934 )

1603 )

1935−

1936 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)

1604 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)

1937 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub

1605 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub

1938

1606

1939{-# INLINE [1] mergeCheapWithMove #-}

1607{-# INLINE [1] mergeCheapWithMove #-}

1940−mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)

1608+mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)

1941− => (forall a. q a -> Event x (v a))

1609+mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy DMap.size

1942− -> DynamicS x (PatchDMapWithMove k q)

1943− -> Event x (DMap k v)

1944−mergeCheapWithMove nt = mergeGCheap' _mergeSubscribedParentWithMove_subscription getInitialSubscribers updateMe destroy

1945 where

1610 where

1946− updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)

1611+ updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)

1947− updateMe subscriber heightBagRef oldParents p = do

1612+ updateMe subscriber heightBagRef oldParents pWrapped = do

1948− -- Prepare new parents for insertion

1613+ let p = unPatchDMapWithMove pWrapped

1949− let subscribeParent :: forall a. k a -> Event x (v a) -> EventM x (MergeSubscribedParentWithMove x k a)

1614+ let f (subscriptionsToKill, ps) (k :=> edit) = do

1950− subscribeParent k e = do

1615+ let deleteHere = return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps

1951− keyRef <- liftIO $ newIORef k

1616+ insertHere e = do

1952− let s = subscriber $ liftIO $ readIORef keyRef

1617+ keyRef <- liftIO $ newIORef k

1953− subscription@(EventSubscription _ subd) <- subscribe e s

1618+ let s = subscriber $ liftIO $ readIORef keyRef

1954− liftIO $ do

1619+ subscription@(EventSubscription _ subd) <- subscribe e s

1955− newParentHeight <- getEventSubscribedHeight subd

1620+ liftIO $ do

1956− modifyIORef' heightBagRef $ heightBagAdd newParentHeight

1621+ newParentHeight <- getEventSubscribedHeight subd

1957− return $ MergeSubscribedParentWithMove subscription keyRef

1622+ let newParent = MergeSubscribedParentWithMove subscription keyRef

1958− p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey (\k q -> subscribeParent k (nt q)) p

1623+ modifyIORef' heightBagRef $ heightBagAdd newParentHeight

1959− -- Collect old parents for deletion and update the keys of moved parents

1624+ return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps

1960− let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a

1625+ (mOldSubd, newPs) <- case edit of

1961− moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of

1626+ DMapEdit_Delete moved -> do

1962− Nothing -> do

1627+ (toDelete, newPs) <- deleteHere

1963− oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $

1628+ return (if moved then Nothing else toDelete, newPs)

1964− _mergeSubscribedParentWithMove_subscription parent

1629+ DMapEdit_Insert moved e -> do

1965−

1630+ (toDelete, newPs) <- insertHere e

1631+ return (if moved then Nothing else toDelete, newPs)

1632+ DMapEdit_Move moved sourceKey -> do

1633+ (toDelete, newPs) <- case DMap.lookup sourceKey ps of

1634+ Nothing -> deleteHere

1635+ Just s@(MergeSubscribedParentWithMove _ keyRef) -> do

1636+ liftIO $ writeIORef keyRef k

1637+ return $ DMap.insertLookupWithKey' (\_ new _ -> new) k s ps

1638+ return (if moved then Nothing else toDelete, newPs)

1639+ forM_ mOldSubd $ \oldSubd -> do

1640+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription oldSubd

1966 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

1641 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

1967− return $ Just $ _mergeSubscribedParentWithMove_subscription parent

1642+ return (maybeToList (_mergeSubscribedParentWithMove_subscription <$> mOldSubd) ++ subscriptionsToKill, newPs)

1968− Just toKey -> do

1643+ foldM f ([], oldParents) $ DMap.toList p

1969− liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey

1644+ getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k)

1970− return Nothing

1971− toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $

1972− DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents

1973−

1974− return (toDelete, applyAlways p' oldParents)

1975− getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)

1976 getInitialSubscribers initialParents subscriber = do

1645 getInitialSubscribers initialParents subscriber = do

1977 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do

1646 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do

1978 keyRef <- liftIO $ newIORef k

1647 keyRef <- liftIO $ newIORef k

1979 let s = subscriber $ liftIO $ readIORef keyRef

1648 let s = subscriber $ liftIO $ readIORef keyRef

1980− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s

1649+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s

1981 height <- liftIO $ getEventSubscribedHeight parentSubd

1650 height <- liftIO $ getEventSubscribedHeight parentSubd

1982− return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)

1651+ return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)

1983 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers

1652 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers

1984 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here

1653 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here

1985 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers

1654 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers

1986 )

1655 )

1987−

1988 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)

1656 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)

1989 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub

1657 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub

1990

1658

1991−type MergeUpdateFunc k v x p s

1659+type MergeUpdateFunc k x p s

1992− = (forall a. EventM x (k a) -> Subscriber x (v a))

1660+ = (forall a. EventM x (k a) -> Subscriber x a)

1993 -> IORef HeightBag

1661 -> IORef HeightBag

1994 -> DMap k s

1662 -> DMap k s

1995 -> p

1663 -> p

1996 -> EventM x ([EventSubscription x], DMap k s)

1664 -> EventM x ([EventSubscription x], DMap k s)

1997

1665

1998−type MergeGetSubscription x s = forall a. s a -> EventSubscription x

1666+type MergeInitFunc k x s

1999−

1667+ = DMap k (Event x)

2000−type MergeInitFunc k v q x s

1668+ -> (forall a. EventM x (k a) -> Subscriber x a)

2001− = DMap k q

1669+ -> EventM x (DMap k Identity, [Height], DMap k s)

2002− -> (forall a. EventM x (k a) -> Subscriber x (v a))

2003− -> EventM x (DMap k v, [Height], DMap k s)

2004

1670

2005type MergeDestroyFunc k s

1671type MergeDestroyFunc k s

2006 = DMap k s

1672 = DMap k s

2007 -> IO ()

1673 -> IO ()

2008

1674

2009−data Merge x k v s = Merge

1675+{-# INLINE mergeCheap' #-}

2010− { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))

1676+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 -> (DMap k s -> Int) -> Dynamic x p -> Event x (DMap k Identity)

2011− , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)

1677+mergeCheap' getInitialSubscribers updateFunc destroy numParents d = Event $ \sub -> do

2012− , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)

2013− , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k v))

2014− , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k v))

2015− }

2016−

2017−invalidateMergeHeight :: Merge x k v s -> IO ()

2018−invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)

2019−

2020−invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()

2021−invalidateMergeHeight' heightRef sub = do

2022− oldHeight <- readIORef heightRef

2023− -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents

2024− when (oldHeight /= invalidHeight) $ do

2025− writeIORef heightRef $! invalidHeight

2026− subscriberInvalidateHeight sub oldHeight

2027−

2028−revalidateMergeHeight :: Merge x k v s -> IO ()

2029−revalidateMergeHeight m = do

2030− currentHeight <- readIORef $ _merge_heightRef m

2031−

2032− -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check

2033− when (currentHeight == invalidHeight) $ do

2034− heights <- readIORef $ _merge_heightBagRef m

2035− parents <- readIORef $ _merge_parentsRef m

2036− -- When the number of heights in the bag reaches the number of parents, we should have a valid height

2037− case heightBagSize heights `compare` DMap.size parents of

2038− LT -> return ()

2039− EQ -> do

2040− let height = succHeight $ heightBagMax heights

2041− traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height

2042− writeIORef (_merge_heightRef m) $! height

2043− subscriberRecalculateHeight (_merge_sub m) height

2044− GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"

2045−

2046−scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()

2047−scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do

2048− vals <- liftIO $ readIORef $ _merge_accumRef m

2049− -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us,

2050− -- it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers

2051− liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty

2052− --TODO: Assert that m is not empty

2053− subscriberPropagate (_merge_sub m) vals

2054−

2055−checkCycle :: HasSpiderTimeline x => EventSubscribed x -> EventM x ()

2056−checkCycle subscribed = liftIO $ do

2057− height <- readIORef (eventSubscribedHeightRef subscribed)

2058−

2059− -- currentHeight <- getCurrentHeight

2060− -- when (height <= currentHeight) $ if height /= invalidHeight

2061− -- then do

2062− -- myStack <- liftIO $ whoCreatedIORef undefined --TODO

2063− -- error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)

2064− -- else liftIO $

2065− when (height == invalidHeight) $

2066−#ifdef DEBUG_CYCLES

2067− do

2068− nodesInvolvedInCycle <- walkInvalidHeightParents subscribed

2069− stacks <- forM nodesInvolvedInCycle whoCreatedEventSubscribed

2070− throwIO (EventLoopException stacks)

2071−#else

2072− throwIO EventLoopException

2073−#endif

2074−

2075−

2076−mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => EventSubscribed x -> Merge x k v s -> EventM x (k a) -> Subscriber x (v a)

2077−mergeSubscriber subscribed m getKey = Subscriber

2078− { subscriberPropagate = \a -> do

2079− oldM <- liftIO $ readIORef $ _merge_accumRef m

2080− k <- getKey

2081− let newM = DMap.insertWith (error "Same key fired multiple times for Merge") k a oldM

2082− tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)

2083− liftIO $ writeIORef (_merge_accumRef m) $! newM

2084− when (DMap.null oldM) $ do -- Only schedule the firing once

2085− height <- liftIO $ readIORef $ _merge_heightRef m

2086− checkCycle subscribed

2087−

2088− scheduleMergeSelf m height

2089− , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating

2090− modifyIORef' (_merge_heightBagRef m) $ heightBagRemove old

2091− invalidateMergeHeight m

2092− , subscriberRecalculateHeight = \new -> do

2093− modifyIORef' (_merge_heightBagRef m) $ heightBagAdd new

2094− revalidateMergeHeight m

2095− }

2096−

2097−--TODO: Be able to run as much of this as possible promptly

2098−updateMerge :: (HasSpiderTimeline x, GCompare k) => EventSubscribed x -> Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x

2099−updateMerge subscribed m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)

2100− where updateMe = do

2101− oldParents <- liftIO $ readIORef $ _merge_parentsRef m

2102− (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber subscribed m) (_merge_heightBagRef m) oldParents p

2103− liftIO $ writeIORef (_merge_parentsRef m) $! newParents

2104− return subscriptionsToKill

2105−

2106−{-# INLINE mergeGCheap' #-}

2107−mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)

2108− => MergeGetSubscription x s -> MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> DynamicS x p -> Event x (DMap k v)

2109−mergeGCheap' getParent getInitialSubscribers updateFunc destroy d = Event $ \sub -> do

2110 initialParents <- readBehaviorUntracked $ dynamicCurrent d

1678 initialParents <- readBehaviorUntracked $ dynamicCurrent d

2111 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"

1679 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"

2112 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"

1680 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"

2113 heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"

1681 heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"

2114 parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"

1682 parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"

2115− changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"

1683+ let scheduleSelf height = scheduleMerge' height heightRef $ do

2116−

1684+ m <- liftIO $ readIORef accumRef

2117− let subscribed = EventSubscribed

1685+ liftIO $ writeIORef accumRef $! DMap.empty

2118− { eventSubscribedHeightRef = heightRef

1686+ --TODO: Assert that m is not empty

2119− , eventSubscribedRetained = toAny (parentsRef, changeSubdRef)

1687+ subscriberPropagate sub m

1688+ invalidateMyHeight = do

1689+ oldHeight <- readIORef heightRef

1690+ when (oldHeight /= invalidHeight) $ do -- If the height used to be valid, it must be invalid now; we should never have *more* heights than we have parents

1691+ writeIORef heightRef $! invalidHeight

1692+ subscriberInvalidateHeight sub oldHeight

1693+ revalidateMyHeight = do

1694+ currentHeight <- readIORef heightRef

1695+ when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check

1696+ heights <- readIORef heightBagRef

1697+ parents <- readIORef parentsRef

1698+ -- When the number of heights in the bag reaches the number of parents, we should have a valid height

1699+ case heightBagSize heights `compare` numParents parents of

1700+ LT -> return ()

1701+ EQ -> do

1702+ let height = succHeight $ heightBagMax heights

1703+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height

1704+ writeIORef heightRef $! height

1705+ subscriberRecalculateHeight sub height

1706+ GT -> error $ "revalidateMergeHeight: more heights than parents for Merge"

1707+ subscriber :: forall a. EventM x (k a) -> Subscriber x a

1708+ subscriber getKey = Subscriber

1709+ { subscriberPropagate = \a -> do

1710+ oldM <- liftIO $ readIORef accumRef

1711+ k <- getKey

1712+ let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM

1713+ tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)

1714+ liftIO $ writeIORef accumRef $! newM

1715+ when (DMap.null oldM) $ do -- Only schedule the firing once

1716+ height <- liftIO $ readIORef heightRef

1717+ --TODO: assertions about height

1718+ currentHeight <- getCurrentHeight

1719+ when (height <= currentHeight) $ do

1720+ if height /= invalidHeight

1721+ then do

1722+ myStack <- liftIO $ whoCreatedIORef undefined --TODO

1723+ error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)

1724+ else liftIO $ do

2120#ifdef DEBUG_CYCLES

1725#ifdef DEBUG_CYCLES

2121− , eventSubscribedGetParents = do

1726+ nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed

2122− let getParent' (_ :=> v) = _eventSubscription_subscribed (getParent v)

1727+ stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es

2123− fmap getParent' . DMap.toList <$> readIORef parentsRef

1728+ let cycleInfo = ":\n" <> drawForest (listsToForest stacks)

2124− , eventSubscribedHasOwnHeightRef = False

1729+#else

2125− , eventSubscribedWhoCreated = whoCreatedIORef heightRef

1730+ let cycleInfo = ""

2126#endif

1731#endif

2127− }

1732+ error $ "Causality loop found" <> cycleInfo

2128−

1733+ scheduleSelf height

2129− m = Merge

1734+ , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating

2130− { _merge_parentsRef = parentsRef

1735+ modifyIORef' heightBagRef $ heightBagRemove old

2131− , _merge_heightBagRef = heightBagRef

1736+ invalidateMyHeight

2132− , _merge_heightRef = heightRef

1737+ , subscriberRecalculateHeight = \new -> do

2133− , _merge_sub = sub

1738+ modifyIORef' heightBagRef $ heightBagAdd new

2134− , _merge_accumRef = accumRef

1739+ revalidateMyHeight

2135 }

1740 }

2136− (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber subscribed m

1741+ let updateMe x = do

1742+ oldParents <- liftIO $ readIORef parentsRef

1743+ (subscriptionsToKill, newParents) <- updateFunc subscriber heightBagRef oldParents x

1744+ liftIO $ writeIORef parentsRef $! newParents

1745+ return subscriptionsToKill

1746+ (dm, heights, initialParentState) <- getInitialSubscribers initialParents subscriber

2137 let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights

1747 let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights

2138 myHeight = if invalidHeight `elem` heights

1748 myHeight = if invalidHeight `elem` heights

2139 then invalidHeight

1749 then invalidHeight

@@ -2142,236 +1752,114 @@ mergeGCheap' getParent getInitialSubscribers updateFunc destroy d = Event $ \sub

2142 let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now

1752 let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now

2143 then (if DMap.null dm then Nothing else Just dm, DMap.empty)

1753 then (if DMap.null dm then Nothing else Just dm, DMap.empty)

2144 else (Nothing, dm)

1754 else (Nothing, dm)

2145− unless (DMap.null accum) $ scheduleMergeSelf m myHeight

1755+ unless (DMap.null accum) $ do

1756+ scheduleSelf myHeight

1757+ occRef <- liftIO $ newIORef occ

1758+ when (isJust occ) $ scheduleClear occRef

2146 liftIO $ writeIORef accumRef $! accum

1759 liftIO $ writeIORef accumRef $! accum

2147 liftIO $ writeIORef heightRef $! myHeight

1760 liftIO $ writeIORef heightRef $! myHeight

2148 liftIO $ writeIORef heightBagRef $! myHeightBag

1761 liftIO $ writeIORef heightBagRef $! myHeightBag

1762+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"

2149 liftIO $ writeIORef parentsRef $! initialParentState

1763 liftIO $ writeIORef parentsRef $! initialParentState

2150 defer $ SomeMergeInit $ do

1764 defer $ SomeMergeInit $ do

2151− let changeSubscriber = Subscriber

1765+ let s = Subscriber

2152 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

1766 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

2153− tracePropagate (Proxy :: Proxy x) "SubscriberMerge/Change"

1767+ tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change"

2154− defer $ updateMerge subscribed m updateFunc a

1768+ defer $ SomeMergeUpdate (updateMe a) invalidateMyHeight revalidateMyHeight

2155 , subscriberInvalidateHeight = \_ -> return ()

1769 , subscriberInvalidateHeight = \_ -> return ()

2156 , subscriberRecalculateHeight = \_ -> return ()

1770 , subscriberRecalculateHeight = \_ -> return ()

2157 }

1771 }

2158− (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) changeSubscriber

1772+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s

2159− forM_ change $ \c -> defer $ updateMerge subscribed m updateFunc c

1773+ forM_ change $ \c -> defer $ SomeMergeUpdate (updateMe c) invalidateMyHeight revalidateMyHeight

2160 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.

1774 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.

2161 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain

1775 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain

2162 -- its subscription.

1776 -- its subscription.

2163− liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)

1777+ liftIO $ writeIORef changeSubdRef (s, changeSubscription)

2164 let unsubscribeAll = destroy =<< readIORef parentsRef

1778 let unsubscribeAll = destroy =<< readIORef parentsRef

2165−

1779+ return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parentsRef, changeSubdRef)

2166− return (EventSubscription unsubscribeAll subscribed, occ)

1780+ , occ

2167−

1781+ )

2168−

2169−mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)

2170−mergeInt = cacheEvent . mergeIntCheap

2171−

2172−{-# INLINABLE mergeIntCheap #-}

2173−mergeIntCheap :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)

2174−mergeIntCheap d = Event $ \sub -> do

2175− initialParents <- readBehaviorUntracked $ dynamicCurrent d

2176− accum <- liftIO $ FastMutableIntMap.newEmpty

2177− heightRef <- liftIO $ newIORef zeroHeight

2178− heightBagRef <- liftIO $ newIORef heightBagEmpty

2179− parents <- liftIO $ FastMutableIntMap.newEmpty

2180− changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"

2181− let subscribed = EventSubscribed

2182− { eventSubscribedHeightRef = heightRef

2183− , eventSubscribedRetained = toAny (parents, changeSubdRef)

2184−#ifdef DEBUG_CYCLES

2185− , eventSubscribedGetParents = fmap (_eventSubscription_subscribed . snd) <$> FastMutableIntMap.toList parents

2186− , eventSubscribedHasOwnHeightRef = False

2187− , eventSubscribedWhoCreated = whoCreatedIORef heightRef

2188−#endif

2189− }

2190− let scheduleSelf = do

2191− height <- liftIO $ readIORef $ heightRef

2192− scheduleMerge' height heightRef $ do

2193− vals <- liftIO $ FastMutableIntMap.getFrozenAndClear accum

2194− subscriberPropagate sub vals

2195− invalidateMyHeight = invalidateMergeHeight' heightRef sub

2196− recalculateMyHeight = do

2197− currentHeight <- readIORef heightRef

2198− when (currentHeight == invalidHeight) $ do --TODO: This will almost always be true; can we get rid of this check and just proceed to the next one always?

2199− heights <- readIORef heightBagRef

2200− numParents <- FastMutableIntMap.size parents

2201− case heightBagSize heights `compare` numParents of

2202− LT -> return ()

2203− EQ -> do

2204− let height = succHeight $ heightBagMax heights

2205− traceInvalidateHeight $ "recalculateSubscriberHeight: height: " <> show height

2206− writeIORef heightRef $! height

2207− subscriberRecalculateHeight sub height

2208− GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"

2209− mySubscriber k = Subscriber

2210− { subscriberPropagate = \a -> do

2211− checkCycle subscribed

2212−

2213− wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum

2214− liftIO $ FastMutableIntMap.insert accum k a

2215− when wasEmpty scheduleSelf

2216− , subscriberInvalidateHeight = \old -> do

2217− modifyIORef' heightBagRef $ heightBagRemove old

2218− invalidateMyHeight

2219− , subscriberRecalculateHeight = \new -> do

2220− modifyIORef' heightBagRef $ heightBagAdd new

2221− recalculateMyHeight

2222− }

2223− forM_ (IntMap.toList initialParents) $ \(k, p) -> do

2224− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead p $ mySubscriber k

2225− liftIO $ do

2226− forM_ parentOcc $ FastMutableIntMap.insert accum k

2227− FastMutableIntMap.insert parents k subscription

2228− height <- getEventSubscribedHeight parentSubd

2229− if height == invalidHeight

2230− then writeIORef heightRef invalidHeight

2231− else do

2232− modifyIORef' heightBagRef $ heightBagAdd height

2233− modifyIORef' heightRef $ \oldHeight ->

2234− if oldHeight == invalidHeight

2235− then invalidHeight

2236− else max (succHeight height) oldHeight

2237− myHeight <- liftIO $ readIORef heightRef

2238− currentHeight <- getCurrentHeight

2239− isEmpty <- liftIO $ FastMutableIntMap.isEmpty accum

2240− occ <- if currentHeight >= myHeight -- If we should have fired by now

2241− then if isEmpty

2242− then return Nothing

2243− else liftIO $ Just <$> FastMutableIntMap.getFrozenAndClear accum

2244− else do when (not isEmpty) scheduleSelf -- We have things accumulated, but we shouldn't have fired them yet

2245− return Nothing

2246− defer $ SomeMergeInit $ do

2247− let updateMe a = SomeMergeUpdate u invalidateMyHeight recalculateMyHeight

2248− where

2249− u = do

2250− let f k newParent = do

2251− subscription@(EventSubscription _ subd) <- subscribe newParent $ mySubscriber k

2252− newParentHeight <- liftIO $ getEventSubscribedHeight subd

2253− liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight

2254− return subscription

2255− newSubscriptions <- FastMutableIntMap.traverseIntMapPatchWithKey f a

2256− oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions

2257− liftIO $ for_ oldParents $ \oldParent -> do

2258− oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent

2259−

2260− print ("updateMe", oldParentHeight)

2261− modifyIORef' heightBagRef $ heightBagRemove oldParentHeight

2262− return $ IntMap.elems oldParents

2263− let changeSubscriber = Subscriber

2264− { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

2265− tracePropagate (Proxy :: Proxy x) $ "SubscriberMergeInt/Change"

2266− defer $ updateMe a

2267− , subscriberInvalidateHeight = \_ -> return ()

2268− , subscriberRecalculateHeight = \_ -> return ()

2269− }

2270− (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) changeSubscriber

2271− forM_ change $ \c -> defer $ updateMe c

2272− -- We explicitly hold on to the unsubscribe function from subscribing to the update event.

2273− -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain

2274− -- its subscription.

2275− liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)

2276− let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents

2277−

2278−

2279− return (EventSubscription unsubscribeAll subscribed, occ)

2280

1782

2281newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }

1783newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }

2282−newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) }

2283

1784

2284−fanG :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k v) -> EventSelectorG x k v

1785+fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k

2285−fanG e = unsafePerformIO $ do

1786+fan e =

2286− ref <- newIORef Nothing

2287 let f = Fan

1787 let f = Fan

2288 { fanParent = e

1788 { fanParent = e

2289− , fanSubscribed = ref

1789+ , fanSubscribed = unsafeNewIORef e Nothing

2290 }

1790 }

2291− pure $ EventSelectorG $ \k -> eventFan k f

1791+ in EventSelector $ \k -> eventFan k f

2292

1792

2293−runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()

1793+runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeMergeInit x] -> EventM x ()

2294−runHoldInits holdInitRef dynInitRef mergeInitRef = do

1794+runHoldInits holdInitRef mergeInitRef = do

2295 holdInits <- liftIO $ readIORef holdInitRef

1795 holdInits <- liftIO $ readIORef holdInitRef

2296− dynInits <- liftIO $ readIORef dynInitRef

2297 mergeInits <- liftIO $ readIORef mergeInitRef

1796 mergeInits <- liftIO $ readIORef mergeInitRef

2298− unless (null holdInits && null dynInits && null mergeInits) $ do

1797+ unless (null holdInits && null mergeInits) $ do

2299 liftIO $ writeIORef holdInitRef []

1798 liftIO $ writeIORef holdInitRef []

2300− liftIO $ writeIORef dynInitRef []

2301 liftIO $ writeIORef mergeInitRef []

1799 liftIO $ writeIORef mergeInitRef []

2302 mapM_ initHold holdInits

1800 mapM_ initHold holdInits

2303− mapM_ initDyn dynInits

2304 mapM_ unSomeMergeInit mergeInits

1801 mapM_ unSomeMergeInit mergeInits

2305− runHoldInits holdInitRef dynInitRef mergeInitRef

1802+ runHoldInits holdInitRef mergeInitRef

2306

1803

2307initHold :: HasSpiderTimeline x => SomeHoldInit x -> EventM x ()

1804initHold :: HasSpiderTimeline x => SomeHoldInit x -> EventM x ()

2308initHold (SomeHoldInit h) = void $ getHoldEventSubscription h

1805initHold (SomeHoldInit h) = void $ getHoldEventSubscription h

2309

1806

2310−initDyn :: HasSpiderTimeline x => SomeDynInit x -> EventM x ()

2311−initDyn (SomeDynInit d) = void $ getDynHold d

2312−

2313newEventEnv :: IO (EventEnv x)

1807newEventEnv :: IO (EventEnv x)

2314newEventEnv = do

1808newEventEnv = do

2315 toAssignRef <- newIORef [] -- This should only actually get used when events are firing

1809 toAssignRef <- newIORef [] -- This should only actually get used when events are firing

2316 holdInitRef <- newIORef []

1810 holdInitRef <- newIORef []

2317− dynInitRef <- newIORef []

2318 mergeUpdateRef <- newIORef []

1811 mergeUpdateRef <- newIORef []

2319 mergeInitRef <- newIORef []

1812 mergeInitRef <- newIORef []

2320 heightRef <- newIORef zeroHeight

1813 heightRef <- newIORef zeroHeight

2321 toClearRef <- newIORef []

1814 toClearRef <- newIORef []

2322− toClearIntRef <- newIORef []

2323 toClearRootRef <- newIORef []

1815 toClearRootRef <- newIORef []

2324 coincidenceInfosRef <- newIORef []

1816 coincidenceInfosRef <- newIORef []

2325 delayedRef <- newIORef IntMap.empty

1817 delayedRef <- newIORef IntMap.empty

2326− return $ EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef

1818+ return $ EventEnv toAssignRef holdInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef

2327

1819

2328clearEventEnv :: EventEnv x -> IO ()

1820clearEventEnv :: EventEnv x -> IO ()

2329−clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef) = do

1821+clearEventEnv (EventEnv toAssignRef holdInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef) = do

2330 writeIORef toAssignRef []

1822 writeIORef toAssignRef []

2331 writeIORef holdInitRef []

1823 writeIORef holdInitRef []

2332− writeIORef dynInitRef []

2333 writeIORef mergeUpdateRef []

1824 writeIORef mergeUpdateRef []

2334 writeIORef mergeInitRef []

1825 writeIORef mergeInitRef []

2335 writeIORef heightRef zeroHeight

1826 writeIORef heightRef zeroHeight

2336 writeIORef toClearRef []

1827 writeIORef toClearRef []

2337− writeIORef toClearIntRef []

2338 writeIORef toClearRootRef []

1828 writeIORef toClearRootRef []

2339 writeIORef coincidenceInfosRef []

1829 writeIORef coincidenceInfosRef []

2340 writeIORef delayedRef IntMap.empty

1830 writeIORef delayedRef IntMap.empty

2341

1831

2342-- | Run an event action outside of a frame

1832-- | Run an event action outside of a frame

2343runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex

1833runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex

2344−runFrame a = SpiderHost $ do

1834+runFrame a = SpiderHost $ ask >>= \_ -> lift $ do

2345− let env = _spiderTimeline_eventEnv $ unSTE (spiderTimeline :: SpiderTimelineEnv x)

1835+ let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)

2346 let go = do

1836 let go = do

2347 result <- a

1837 result <- a

2348− 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

1838+ runHoldInits (eventEnvHoldInits 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

2349 return result

1839 return result

2350 result <- runEventM go

1840 result <- runEventM go

2351 toClear <- readIORef $ eventEnvClears env

1841 toClear <- readIORef $ eventEnvClears env

2352− forM_ toClear $ \(Some (Clear ref)) -> {-# SCC "clear" #-} writeIORef ref Nothing

1842+ forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing

2353− toClearInt <- readIORef $ eventEnvIntClears env

2354− forM_ toClearInt $ \(Some (IntClear ref)) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty

2355 toClearRoot <- readIORef $ eventEnvRootClears env

1843 toClearRoot <- readIORef $ eventEnvRootClears env

2356− forM_ toClearRoot $ \(Some (RootClear ref)) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty

1844+ forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty

2357 toAssign <- readIORef $ eventEnvAssignments env

1845 toAssign <- readIORef $ eventEnvAssignments env

2358 toReconnectRef <- newIORef []

1846 toReconnectRef <- newIORef []

2359 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env

1847 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env

2360 forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do

1848 forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do

2361 writeIORef vRef v

1849 writeIORef vRef v

2362− traceInvalidate $ "Invalidating Hold"

1850+ when debugInvalidate $ putStrLn $ "Invalidating Hold"

2363 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef

1851 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef

2364 mergeUpdates <- readIORef $ eventEnvMergeUpdates env

1852 mergeUpdates <- readIORef $ eventEnvMergeUpdates env

2365 writeIORef (eventEnvMergeUpdates env) []

1853 writeIORef (eventEnvMergeUpdates env) []

2366− tracePropagate (Proxy::Proxy x) $ "Updating merges"

1854+ when debugPropagate $ putStrLn "Updating merges"

2367 mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates

1855 mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates

2368− tracePropagate (Proxy::Proxy x) $ "Updating merges done"

1856+ when debugPropagate $ putStrLn "Updating merges done"

2369 toReconnect <- readIORef toReconnectRef

1857 toReconnect <- readIORef toReconnectRef

2370 clearEventEnv env

1858 clearEventEnv env

2371 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do

1859 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do

2372 oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed

1860 oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed

2373 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed

1861 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed

2374− traceInvalidate $ "Finalizing invalidator for Switch" <> showNodeId subscribed

1862+ when debugInvalidate $ putStrLn $ "Finalizing invalidator for Switch" <> showNodeId subscribed

2375 finalize wi

1863 finalize wi

2376 i <- evaluate $ switchSubscribedOwnInvalidator subscribed

1864 i <- evaluate $ switchSubscribedOwnInvalidator subscribed

2377 wi' <- mkWeakPtrWithDebug i "wi'"

1865 wi' <- mkWeakPtrWithDebug i "wi'"

@@ -2379,13 +1867,13 @@ runFrame a = SpiderHost $ do

2379 writeIORef (switchSubscribedBehaviorParents subscribed) []

1867 writeIORef (switchSubscribedBehaviorParents subscribed) []

2380 writeIORef (eventEnvHoldInits env) [] --TODO: Should we reuse this?

1868 writeIORef (eventEnvHoldInits env) [] --TODO: Should we reuse this?

2381 e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) $ eventEnvHoldInits env

1869 e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) $ eventEnvHoldInits env

2382− runEventM $ runHoldInits (eventEnvHoldInits env) (eventEnvDynInits env) (eventEnvMergeInits env) --TODO: Is this actually OK? It seems like it should be, since we know that no events are firing at this point, but it still seems inelegant

1870+ runEventM $ runHoldInits (eventEnvHoldInits env) (eventEnvMergeInits env) --TODO: Is this actually OK? It seems like it should be, since we know that no events are firing at this point, but it still seems inelegant

2383 --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times

1871 --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times

2384 sub <- newSubscriberSwitch subscribed

1872 sub <- newSubscriberSwitch subscribed

2385− subscription <- unSpiderHost $ runFrame $ {-# SCC "subscribeSwitch" #-} subscribe e sub --TODO: Assert that the event isn't firing --TODO: This should not loop because none of the events should be firing, but still, it is inefficient

1873+ subscription <- runReaderT (unSpiderHost (runFrame ({-# SCC "subscribeSwitch" #-} subscribe e sub))) spiderTimeline --TODO: Assert that the event isn't firing --TODO: This should not loop because none of the events should be firing, but still, it is inefficient

2386 {-

1874 {-

2387 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)

1875 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)

2388− liftIO $ debugStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of

1876+ liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of

2389 EventRoot _ -> "EventRoot"

1877 EventRoot _ -> "EventRoot"

2390 EventNever -> "EventNever"

1878 EventNever -> "EventNever"

2391 _ -> "something else"

1879 _ -> "something else"

@@ -2400,7 +1888,7 @@ runFrame a = SpiderHost $ do

2400 myHeight <- readIORef $ switchSubscribedHeight subscribed

1888 myHeight <- readIORef $ switchSubscribedHeight subscribed

2401 when (parentHeight /= myHeight) $ do

1889 when (parentHeight /= myHeight) $ do

2402 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight

1890 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight

2403− WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight

1891+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight

2404 mapM_ _someMergeUpdate_invalidateHeight mergeUpdates --TODO: In addition to when the patch is completely empty, we should also not run this if it has some Nothing values, but none of them have actually had any effect; potentially, we could even check for Just values with no effect (e.g. by comparing their IORefs and ignoring them if they are unchanged); actually, we could just check if the new height is different

1892 mapM_ _someMergeUpdate_invalidateHeight mergeUpdates --TODO: In addition to when the patch is completely empty, we should also not run this if it has some Nothing values, but none of them have actually had any effect; potentially, we could even check for Just values with no effect (e.g. by comparing their IORefs and ignoring them if they are unchanged); actually, we could just check if the new height is different

2405 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do

1893 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do

2406 unsubscribe subscription

1894 unsubscribe subscription

@@ -2441,7 +1929,7 @@ invalidateCoincidenceHeight subscribed = do

2441 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed

1929 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed

2442 when (oldHeight /= invalidHeight) $ do

1930 when (oldHeight /= invalidHeight) $ do

2443 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight

1931 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight

2444− WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

1932+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

2445

1933

2446updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()

1934updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()

2447updateSwitchHeight new subscribed = do

1935updateSwitchHeight new subscribed = do

@@ -2449,7 +1937,7 @@ updateSwitchHeight new subscribed = do

2449 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion

1937 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion

2450 when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion

1938 when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion

2451 writeIORef (switchSubscribedHeight subscribed) $! new

1939 writeIORef (switchSubscribedHeight subscribed) $! new

2452− WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new

1940+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new

2453

1941

2454recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()

1942recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()

2455recalculateCoincidenceHeight subscribed = do

1943recalculateCoincidenceHeight subscribed = do

@@ -2458,7 +1946,7 @@ recalculateCoincidenceHeight subscribed = do

2458 height <- calculateCoincidenceHeight subscribed

1946 height <- calculateCoincidenceHeight subscribed

2459 when (height /= invalidHeight) $ do

1947 when (height /= invalidHeight) $ do

2460 writeIORef (coincidenceSubscribedHeight subscribed) $! height

1948 writeIORef (coincidenceSubscribedHeight subscribed) $! height

2461− WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height

1949+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height

2462

1950

2463calculateSwitchHeight :: SwitchSubscribed x a -> IO Height

1951calculateSwitchHeight :: SwitchSubscribed x a -> IO Height

2464calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)

1952calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)

@@ -2497,218 +1985,13 @@ invalidate toReconnectRef wis = do

2497-- Reflex integration

1985-- Reflex integration

2498--------------------------------------------------------------------------------

1986--------------------------------------------------------------------------------

2499

1987

2500−-- | Designates the default, global Spider timeline

1988+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

2501−data SpiderTimeline x

1989+-- When we're specializing, we include this from Reflex.Class instead, because

2502−type role SpiderTimeline nominal

1990+-- it needs access to these types; when we're not, we want them here, so our

2503−

1991+-- instance isn't an orphan instance.

2504−-- | The default, global Spider environment

1992+#include "SpiderTimeline.include.hs"

2505−type Spider = SpiderTimeline Global

1993+#include "SpiderTimelineHost.include.hs"

2506−

2507−instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (EventM x) where

2508− {-# INLINABLE sample #-}

2509− sample (SpiderBehavior b) = readBehaviorUntracked b

2510−

2511−instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (EventM x) where

2512− {-# INLINABLE hold #-}

2513− hold = holdSpiderEventM

2514− {-# INLINABLE holdDyn #-}

2515− holdDyn = holdDynSpiderEventM

2516− {-# INLINABLE holdIncremental #-}

2517− holdIncremental = holdIncrementalSpiderEventM

2518− {-# INLINABLE buildDynamic #-}

2519− buildDynamic = buildDynamicSpiderEventM

2520− {-# INLINABLE headE #-}

2521− headE = R.slowHeadE

2522−-- headE (SpiderEvent e) = SpiderEvent <$> Reflex.Spider.Internal.headE e

2523− {-# INLINABLE now #-}

2524− now = nowSpiderEventM

2525−

2526−instance Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where

2527− {-# INLINABLE sample #-}

2528− sample = coerce . readBehaviorTracked . unSpiderBehavior

2529−

2530−instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPushM x) where

2531− {-# INLINABLE sample #-}

2532− sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b

2533−

2534−instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderPushM x) where

2535− {-# INLINABLE hold #-}

2536− hold v0 e = Reflex.Class.current <$> Reflex.Class.holdDyn v0 e

2537− {-# INLINABLE holdDyn #-}

2538− holdDyn v0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce e

2539− {-# INLINABLE holdIncremental #-}

2540− holdIncremental v0 (SpiderEvent e) = SpiderPushM $ SpiderIncremental . dynamicHold <$> Reflex.Spider.Internal.hold v0 e

2541− {-# INLINABLE buildDynamic #-}

2542− buildDynamic getV0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce e

2543− {-# INLINABLE headE #-}

2544− headE = R.slowHeadE

2545−-- headE (SpiderEvent e) = SpiderPushM $ SpiderEvent <$> Reflex.Spider.Internal.headE e

2546− {-# INLINABLE now #-}

2547− now = SpiderPushM nowSpiderEventM

2548−

2549−

2550−instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where

2551− {-# INLINE return #-}

2552− return = pure

2553− {-# INLINE (>>=) #-}

2554− x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x

2555− {-# INLINE (>>) #-}

2556− (>>) = (*>)

2557−#if !MIN_VERSION_base(4,13,0)

2558− {-# INLINE fail #-}

2559− fail _ = error "Dynamic does not support 'fail'"

2560−#endif

2561−

2562−{-# INLINABLE newJoinDyn #-}

2563−newJoinDyn :: HasSpiderTimeline x => DynamicS x (Identity (DynamicS x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)

2564−newJoinDyn d =

2565− let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)

2566− eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d

2567− eInner = Reflex.Spider.Internal.switch $ dynamicUpdated <$> dynamicCurrent d

2568− eBoth = Reflex.Spider.Internal.coincidence $ dynamicUpdated . runIdentity <$> dynamicUpdated d

2569− v' = unSpiderEvent $ Reflex.Class.leftmost $ map SpiderEvent [eBoth, eOuter, eInner]

2570− in Reflex.Spider.Internal.unsafeBuildDynamic readV0 v'

2571−

2572−instance HasSpiderTimeline x => Functor (Reflex.Class.Dynamic (SpiderTimeline x)) where

2573− fmap = mapDynamicSpider

2574− x <$ d = R.unsafeBuildDynamic (return x) $ x <$ R.updated d

2575−

2576−mapDynamicSpider :: HasSpiderTimeline x => (a -> b) -> Reflex.Class.Dynamic (SpiderTimeline x) a -> Reflex.Class.Dynamic (SpiderTimeline x) b

2577−mapDynamicSpider f = SpiderDynamic . newMapDyn f . unSpiderDynamic

2578−{-# INLINE [1] mapDynamicSpider #-}

2579−

2580−instance HasSpiderTimeline x => Applicative (Reflex.Class.Dynamic (SpiderTimeline x)) where

2581− pure = SpiderDynamic . dynamicConst

2582−#if MIN_VERSION_base(4,10,0)

2583− liftA2 f a b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith f (unSpiderDynamic a) (unSpiderDynamic b)

2584#endif

1994#endif

2585− SpiderDynamic a <*> SpiderDynamic b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith ($) a b

2586− a *> b = R.unsafeBuildDynamic (R.sample $ R.current b) $ R.leftmost [R.updated b, R.tag (R.current b) $ R.updated a]

2587− (<*) = flip (*>) -- There are no effects, so order doesn't matter

2588−

2589−holdSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Behavior (SpiderTimeline x) a)

2590−holdSpiderEventM v0 e = fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e

2591−

2592−holdDynSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)

2593−holdDynSpiderEventM v0 e = fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e

2594−

2595−holdIncrementalSpiderEventM :: (HasSpiderTimeline x, Patch p) => PatchTarget p -> Reflex.Class.Event (SpiderTimeline x) p -> EventM x (Reflex.Class.Incremental (SpiderTimeline x) p)

2596−holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e

2597−

2598−buildDynamicSpiderEventM :: HasSpiderTimeline x => SpiderPushM x a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)

2599−buildDynamicSpiderEventM getV0 e = fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e

2600−

2601−instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHost x) where

2602− {-# INLINABLE hold #-}

2603− hold v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.hold v0 e

2604− {-# INLINABLE holdDyn #-}

2605− holdDyn v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdDyn v0 e

2606− {-# INLINABLE holdIncremental #-}

2607− holdIncremental v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdIncremental v0 e

2608− {-# INLINABLE buildDynamic #-}

2609− buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e

2610− {-# INLINABLE headE #-}

2611− headE e = runFrame . runSpiderHostFrame $ Reflex.Class.headE e

2612− {-# INLINABLE now #-}

2613− now = runFrame . runSpiderHostFrame $ Reflex.Class.now

2614−

2615−

2616−instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where

2617− sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can

2618−

2619−instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHostFrame x) where

2620− {-# INLINABLE hold #-}

2621− hold v0 e = SpiderHostFrame $ fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e

2622− {-# INLINABLE holdDyn #-}

2623− holdDyn v0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e

2624− {-# INLINABLE holdIncremental #-}

2625− holdIncremental v0 e = SpiderHostFrame $ fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e

2626− {-# INLINABLE buildDynamic #-}

2627− buildDynamic getV0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e

2628− {-# INLINABLE headE #-}

2629− headE = R.slowHeadE

2630−-- headE (SpiderEvent e) = SpiderHostFrame $ SpiderEvent <$> Reflex.Spider.Internal.headE e

2631− {-# INLINABLE now #-}

2632− now = SpiderHostFrame Reflex.Class.now

2633−

2634−instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where

2635− {-# INLINABLE sample #-}

2636− sample = runFrame . readBehaviorUntracked . unSpiderBehavior

2637−

2638−instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where

2639− {-# INLINABLE sample #-}

2640− sample = Reflex.Spider.Internal.ReadPhase . Reflex.Class.sample

2641−

2642−instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where

2643− {-# INLINABLE hold #-}

2644− hold v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.hold v0 e

2645− {-# INLINABLE holdDyn #-}

2646− holdDyn v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdDyn v0 e

2647− {-# INLINABLE holdIncremental #-}

2648− holdIncremental v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdIncremental v0 e

2649− {-# INLINABLE buildDynamic #-}

2650− buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e

2651− {-# INLINABLE headE #-}

2652− headE e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.headE e

2653− {-# INLINABLE now #-}

2654− now = Reflex.Spider.Internal.ReadPhase Reflex.Class.now

2655−

2656−--------------------------------------------------------------------------------

2657−-- Deprecated items

2658−--------------------------------------------------------------------------------

2659−

2660−-- | 'SpiderEnv' is the old name for 'SpiderTimeline'

2661−{-# DEPRECATED SpiderEnv "Use 'SpiderTimelineEnv' instead" #-}

2662−type SpiderEnv = SpiderTimeline

2663−instance HasSpiderTimeline x => Reflex.Host.Class.MonadSubscribeEvent (SpiderTimeline x) (SpiderHostFrame x) where

2664− {-# INLINABLE subscribeEvent #-}

2665− subscribeEvent e = SpiderHostFrame $ do

2666− --TODO: Unsubscribe eventually (manually and/or with weak ref)

2667− val <- liftIO $ newIORef Nothing

2668− subscription <- subscribe (unSpiderEvent e) $ Subscriber

2669− { subscriberPropagate = \a -> do

2670− liftIO $ writeIORef val $ Just a

2671− scheduleClear val

2672− , subscriberInvalidateHeight = \_ -> return ()

2673− , subscriberRecalculateHeight = \_ -> return ()

2674− }

2675− return $ SpiderEventHandle

2676− { spiderEventHandleSubscription = subscription

2677− , spiderEventHandleValue = val

2678− }

2679−

2680−instance HasSpiderTimeline x => Reflex.Host.Class.ReflexHost (SpiderTimeline x) where

2681− type EventTrigger (SpiderTimeline x) = RootTrigger x

2682− type EventHandle (SpiderTimeline x) = SpiderEventHandle x

2683− type HostFrame (SpiderTimeline x) = SpiderHostFrame x

2684−

2685−instance HasSpiderTimeline x => Reflex.Host.Class.MonadReadEvent (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where

2686− {-# NOINLINE readEvent #-}

2687− readEvent h = Reflex.Spider.Internal.ReadPhase $ fmap (fmap return) $ liftIO $ do

2688− result <- readIORef $ spiderEventHandleValue h

2689− touch h

2690− return result

2691−

2692−instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where

2693− newEventWithTrigger = SpiderHost . fmap SpiderEvent . newEventWithTriggerIO

2694− newFanEventWithTrigger f = SpiderHost $ do

2695− es <- newFanEventWithTriggerIO f

2696− return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es

2697−

2698−instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where

2699− newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO

2700− newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do

2701− es <- newFanEventWithTriggerIO f

2702− return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es

2703−

2704−instance HasSpiderTimeline x => Reflex.Host.Class.MonadSubscribeEvent (SpiderTimeline x) (SpiderHost x) where

2705− {-# INLINABLE subscribeEvent #-}

2706− subscribeEvent = runFrame . runSpiderHostFrame . Reflex.Host.Class.subscribeEvent

2707−

2708−instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexHost (SpiderTimeline x) (SpiderHost x) where

2709− type ReadPhase (SpiderHost x) = Reflex.Spider.Internal.ReadPhase x

2710− fireEventsAndRead es (Reflex.Spider.Internal.ReadPhase a) = run es a

2711− runHostFrame = runFrame . runSpiderHostFrame

2712

1995

2713unsafeNewSpiderTimelineEnv :: forall x. IO (SpiderTimelineEnv x)

1996unsafeNewSpiderTimelineEnv :: forall x. IO (SpiderTimelineEnv x)

2714unsafeNewSpiderTimelineEnv = do

1997unsafeNewSpiderTimelineEnv = do

@@ -2717,7 +2000,7 @@ unsafeNewSpiderTimelineEnv = do

2717#ifdef DEBUG

2000#ifdef DEBUG

2718 depthRef <- newIORef 0

2001 depthRef <- newIORef 0

2719#endif

2002#endif

2720− return $ STE $ SpiderTimelineEnv

2003+ return $ SpiderTimelineEnv

2721 { _spiderTimeline_lock = lock

2004 { _spiderTimeline_lock = lock

2722 , _spiderTimeline_eventEnv = env

2005 , _spiderTimeline_eventEnv = env

2723#ifdef DEBUG

2006#ifdef DEBUG

@@ -2725,40 +2008,41 @@ unsafeNewSpiderTimelineEnv = do

2725#endif

2008#endif

2726 }

2009 }

2727

2010

2011+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

2728-- | Create a new SpiderTimelineEnv

2012-- | Create a new SpiderTimelineEnv

2729newSpiderTimeline :: IO (Some SpiderTimelineEnv)

2013newSpiderTimeline :: IO (Some SpiderTimelineEnv)

2730−newSpiderTimeline = withSpiderTimeline (pure . Some)

2014+newSpiderTimeline = withSpiderTimeline (pure . Some.This)

2731

2015

2732−data LocalSpiderTimeline (x :: Type) s

2016+data LocalSpiderTimeline x s

2733

2017

2734instance Reifies s (SpiderTimelineEnv x) =>

2018instance Reifies s (SpiderTimelineEnv x) =>

2735 HasSpiderTimeline (LocalSpiderTimeline x s) where

2019 HasSpiderTimeline (LocalSpiderTimeline x s) where

2736− spiderTimeline = localSpiderTimeline Proxy $ reflect (Proxy :: Proxy s)

2020+ spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s)

2737

2021

2738localSpiderTimeline

2022localSpiderTimeline

2739− :: proxy s

2023+ :: Proxy s

2740 -> SpiderTimelineEnv x

2024 -> SpiderTimelineEnv x

2741 -> SpiderTimelineEnv (LocalSpiderTimeline x s)

2025 -> SpiderTimelineEnv (LocalSpiderTimeline x s)

2742−localSpiderTimeline _ = coerce

2026+localSpiderTimeline _ = unsafeCoerce

2743

2027

2744-- | Pass a new timeline to the given function.

2028-- | Pass a new timeline to the given function.

2745withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r

2029withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r

2746withSpiderTimeline k = do

2030withSpiderTimeline k = do

2747 env <- unsafeNewSpiderTimelineEnv

2031 env <- unsafeNewSpiderTimelineEnv

2748 reify env $ \s -> k $ localSpiderTimeline s env

2032 reify env $ \s -> k $ localSpiderTimeline s env

2033+#endif

2749

2034

2750−newtype SpiderPullM (x :: Type) a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2035+newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2751−

2752−type ComputeM = EventM

2753

2036

2754−newtype SpiderPushM (x :: Type) a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2037+newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2755

2038

2039+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

2756instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2040instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2757 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}

2041 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}

2758 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }

2042 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }

2759 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }

2043 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }

2760− newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: DynamicS x (Identity a) } -- deriving (Functor, Applicative, Monad)

2044+ newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad)

2761− newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: DynamicS x p }

2045+ newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }

2762 type PullM (SpiderTimeline x) = SpiderPullM x

2046 type PullM (SpiderTimeline x) = SpiderPullM x

2763 type PushM (SpiderTimeline x) = SpiderPushM x

2047 type PushM (SpiderTimeline x) = SpiderPushM x

2764 {-# INLINABLE never #-}

2048 {-# INLINABLE never #-}

@@ -2771,15 +2055,10 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2771 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent

2055 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent

2772 {-# INLINABLE pull #-}

2056 {-# INLINABLE pull #-}

2773 pull = SpiderBehavior . pull . coerce

2057 pull = SpiderBehavior . pull . coerce

2774− {-# INLINABLE fanG #-}

2058+ {-# INLINABLE merge #-}

2775− fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))

2059+ merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x))

2776− {-# INLINABLE mergeG #-}

2060+ {-# INLINABLE fan #-}

2777− mergeG

2061+ fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))

2778− :: forall k2 (k :: k2 -> *) q (v :: k2 -> *). GCompare k

2779− => (forall a. q a -> R.Event (SpiderTimeline x) (v a))

2780− -> DMap k q

2781− -> R.Event (SpiderTimeline x) (DMap k v)

2782− mergeG nt = SpiderEvent . mergeG (unSpiderEvent #. nt) . dynamicConst

2783 {-# INLINABLE switch #-}

2062 {-# INLINABLE switch #-}

2784 switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior

2063 switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior

2785 {-# INLINABLE coincidence #-}

2064 {-# INLINABLE coincidence #-}

@@ -2787,31 +2066,27 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2787 {-# INLINABLE current #-}

2066 {-# INLINABLE current #-}

2788 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic

2067 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic

2789 {-# INLINABLE updated #-}

2068 {-# INLINABLE updated #-}

2790− updated = SpiderEvent #. dynamicUpdated .# fmap coerce . unSpiderDynamic

2069+ updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic

2791 {-# INLINABLE unsafeBuildDynamic #-}

2070 {-# INLINABLE unsafeBuildDynamic #-}

2792− unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'

2071+ unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeDyn (coerce readV0) $ coerce $ unSpiderEvent v'

2793 {-# INLINABLE unsafeBuildIncremental #-}

2072 {-# INLINABLE unsafeBuildIncremental #-}

2794− unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv

2073+ unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeDyn (coerce readV0) $ unSpiderEvent dv

2795− {-# INLINABLE mergeIncrementalG #-}

2074+ {-# INLINABLE mergeIncremental #-}

2796− mergeIncrementalG nt = SpiderEvent #. mergeG (coerce #. nt) .# unSpiderIncremental

2075+ mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental

2797− {-# INLINABLE mergeIncrementalWithMoveG #-}

2076+ {-# INLINABLE mergeIncrementalWithMove #-}

2798− mergeIncrementalWithMoveG nt = SpiderEvent #. mergeWithMove (coerce #. nt) .# unSpiderIncremental

2077+ mergeIncrementalWithMove = SpiderEvent . mergeWithMove . (unsafeCoerce :: Dynamic x (PatchDMapWithMove k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMapWithMove k (Event x))) . unSpiderIncremental

2799 {-# INLINABLE currentIncremental #-}

2078 {-# INLINABLE currentIncremental #-}

2800 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental

2079 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental

2801 {-# INLINABLE updatedIncremental #-}

2080 {-# INLINABLE updatedIncremental #-}

2802 updatedIncremental = SpiderEvent . dynamicUpdated . unSpiderIncremental

2081 updatedIncremental = SpiderEvent . dynamicUpdated . unSpiderIncremental

2803 {-# INLINABLE incrementalToDynamic #-}

2082 {-# INLINABLE incrementalToDynamic #-}

2804− incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (readBehaviorUntracked $ dynamicCurrent i) $ flip push (dynamicUpdated i) $ \p -> do

2083+ incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ dynamicDynIdentity $ unsafeDyn (readBehaviorUntracked $ dynamicCurrent i) $ flip push (dynamicUpdated i) $ \p -> do

2805 c <- readBehaviorUntracked $ dynamicCurrent i

2084 c <- readBehaviorUntracked $ dynamicCurrent i

2806 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'

2085 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'

2807 eventCoercion Coercion = Coercion

2086 eventCoercion Coercion = Coercion

2808 behaviorCoercion Coercion = Coercion

2087 behaviorCoercion Coercion = Coercion

2809− dynamicCoercion Coercion = Coercion

2088+ dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance

2810− incrementalCoercion Coercion Coercion = Coercion

2089+#endif

2811− {-# INLINABLE mergeIntIncremental #-}

2812− mergeIntIncremental = SpiderEvent . mergeInt . coerce

2813− {-# INLINABLE fanInt #-}

2814− fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))

2815

2090

2816data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)

2091data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)

2817

2092

@@ -2834,7 +2109,7 @@ instance MonadAtomicRef (EventM x) where

2834 atomicModifyRef r f = liftIO $ atomicModifyRef r f

2109 atomicModifyRef r f = liftIO $ atomicModifyRef r f

2835

2110

2836-- | The monad for actions that manipulate a Spider timeline identified by @x@

2111-- | The monad for actions that manipulate a Spider timeline identified by @x@

2837−newtype SpiderHost (x :: Type) a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

2112+newtype SpiderHost x a = SpiderHost { unSpiderHost :: ReaderT (SpiderTimelineEnv x) IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

2838

2113

2839instance Monad (SpiderHost x) where

2114instance Monad (SpiderHost x) where

2840 {-# INLINABLE (>>=) #-}

2115 {-# INLINABLE (>>=) #-}

@@ -2843,27 +2118,22 @@ instance Monad (SpiderHost x) where

2843 SpiderHost x >> SpiderHost y = SpiderHost $ x >> y

2118 SpiderHost x >> SpiderHost y = SpiderHost $ x >> y

2844 {-# INLINABLE return #-}

2119 {-# INLINABLE return #-}

2845 return x = SpiderHost $ return x

2120 return x = SpiderHost $ return x

2846−#if !MIN_VERSION_base(4,13,0)

2847 {-# INLINABLE fail #-}

2121 {-# INLINABLE fail #-}

2848− fail = MonadFail.fail

2122+ fail s = SpiderHost $ fail s

2849−#endif

2850−

2851−instance MonadFail (SpiderHost x) where

2852− {-# INLINABLE fail #-}

2853− fail s = SpiderHost $ MonadFail.fail s

2854

2123

2855-- | Run an action affecting the global Spider timeline; this will be guarded by

2124-- | Run an action affecting the global Spider timeline; this will be guarded by

2856-- a mutex for that timeline

2125-- a mutex for that timeline

2857runSpiderHost :: SpiderHost Global a -> IO a

2126runSpiderHost :: SpiderHost Global a -> IO a

2858−runSpiderHost (SpiderHost a) = a

2127+runSpiderHost (SpiderHost a) = runReaderT a globalSpiderTimelineEnv

2859

2128

2129+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

2860-- | Run an action affecting a given Spider timeline; this will be guarded by a

2130-- | Run an action affecting a given Spider timeline; this will be guarded by a

2861-- mutex for that timeline

2131-- mutex for that timeline

2862runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a

2132runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a

2863−runSpiderHostForTimeline (SpiderHost a) _ = a

2133+runSpiderHostForTimeline (SpiderHost a) = runReaderT a

2134+#endif

2864

2135

2865−newtype SpiderHostFrame (x :: Type) a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }

2136+newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

2866− deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

2867

2137

2868instance Monad (SpiderHostFrame x) where

2138instance Monad (SpiderHostFrame x) where

2869 {-# INLINABLE (>>=) #-}

2139 {-# INLINABLE (>>=) #-}

@@ -2872,21 +2142,15 @@ instance Monad (SpiderHostFrame x) where

2872 SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y

2142 SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y

2873 {-# INLINABLE return #-}

2143 {-# INLINABLE return #-}

2874 return x = SpiderHostFrame $ return x

2144 return x = SpiderHostFrame $ return x

2875−#if !MIN_VERSION_base(4,13,0)

2876 {-# INLINABLE fail #-}

2145 {-# INLINABLE fail #-}

2877 fail s = SpiderHostFrame $ fail s

2146 fail s = SpiderHostFrame $ fail s

2878−#endif

2879−

2880−instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where

2881− notReadyUntil _ = pure ()

2882− notReady = pure ()

2883

2147

2884−newEventWithTriggerIO :: forall x a. HasSpiderTimeline x => (RootTrigger x a -> IO (IO ())) -> IO (Event x a)

2148+newEventWithTriggerIO :: (RootTrigger x a -> IO (IO ())) -> IO (Event x a)

2885newEventWithTriggerIO f = do

2149newEventWithTriggerIO f = do

2886 es <- newFanEventWithTriggerIO $ \Refl -> f

2150 es <- newFanEventWithTriggerIO $ \Refl -> f

2887 return $ select es Refl

2151 return $ select es Refl

2888

2152

2889−newFanEventWithTriggerIO :: (HasSpiderTimeline x, GCompare k) => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)

2153+newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)

2890newFanEventWithTriggerIO f = do

2154newFanEventWithTriggerIO f = do

2891 occRef <- newIORef DMap.empty

2155 occRef <- newIORef DMap.empty

2892 subscribedRef <- newIORef DMap.empty

2156 subscribedRef <- newIORef DMap.empty

@@ -2920,11 +2184,3 @@ instance MonadAtomicRef (SpiderHostFrame x) where

2920instance PrimMonad (SpiderHostFrame x) where

2184instance PrimMonad (SpiderHostFrame x) where

2921 type PrimState (SpiderHostFrame x) = PrimState IO

2185 type PrimState (SpiderHostFrame x) = PrimState IO

2922 primitive = SpiderHostFrame . EventM . primitive

2186 primitive = SpiderHostFrame . EventM . primitive

2923−

2924−instance NotReady (SpiderTimeline x) (SpiderHost x) where

2925− notReadyUntil _ = return ()

2926− notReady = return ()

2927−

2928−instance HasSpiderTimeline x => NotReady (SpiderTimeline x) (PerformEventT (SpiderTimeline x) (SpiderHost x)) where

2929− notReadyUntil _ = return ()

2930− notReady = return ()

src/Reflex/Spider/SpiderTimeline.include.hsnew file+122

@@ -0,0 +1,122 @@

1+-- | Designates the default, global Spider timeline

2+data SpiderTimeline x

3+type role SpiderTimeline nominal

5+-- | The default, global Spider environment

6+type Spider = SpiderTimeline Global

8+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (EventM x) where

9+ {-# INLINABLE sample #-}

10+ sample (SpiderBehavior b) = readBehaviorUntracked b

11+

12+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (EventM x) where

13+ {-# INLINABLE hold #-}

14+ hold = holdSpiderEventM

15+ {-# INLINABLE holdDyn #-}

16+ holdDyn = holdDynSpiderEventM

17+ {-# INLINABLE holdIncremental #-}

18+ holdIncremental = holdIncrementalSpiderEventM

19+

20+instance (

21+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

22+ x ~ Global

23+#endif

24+ ) => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where

25+ {-# INLINABLE sample #-}

26+ sample = coerce . readBehaviorTracked . unSpiderBehavior

27+

28+instance (

29+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

30+ x ~ Global

31+#endif

32+ ) => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPushM x) where

33+ {-# INLINABLE sample #-}

34+ sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b

35+

36+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderPushM x) where

37+ {-# INLINABLE hold #-}

38+ hold v0 e = Reflex.Class.current <$> Reflex.Class.holdDyn v0 e

39+ {-# INLINABLE holdDyn #-}

40+ holdDyn v0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce e

41+ {-# INLINABLE holdIncremental #-}

42+ holdIncremental v0 (SpiderEvent e) = SpiderPushM $ SpiderIncremental . dynamicHold <$> Reflex.Spider.Internal.hold v0 e

43+

44+instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where

45+ {-# INLINE return #-}

46+ return = pure

47+ {-# INLINE (>>=) #-}

48+ x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x

49+ {-# INLINE (>>) #-}

50+ _ >> y = y

51+ {-# INLINE fail #-}

52+ fail _ = error "Dynamic does not support 'fail'"

53+

54+newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)

55+newJoinDyn d =

56+ let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)

57+ eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d

58+ eInner = Reflex.Spider.Internal.switch $ dynamicUpdated <$> dynamicCurrent d

59+ eBoth = Reflex.Spider.Internal.coincidence $ dynamicUpdated . runIdentity <$> dynamicUpdated d

60+ v' = unSpiderEvent $ Reflex.Class.leftmost $ map SpiderEvent [eBoth, eOuter, eInner]

61+ in unsafeDyn readV0 v'

62+

63+instance HasSpiderTimeline x => Functor (Reflex.Class.Dynamic (SpiderTimeline x)) where

64+ fmap f = SpiderDynamic . newMapDyn f . unSpiderDynamic

65+

66+instance HasSpiderTimeline x => Applicative (Reflex.Class.Dynamic (SpiderTimeline x)) where

67+ pure = SpiderDynamic . dynamicConst

68+ SpiderDynamic a <*> SpiderDynamic b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith ($) a b

69+ _ *> b = b

70+ a <* _ = a

71+

72+holdSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Behavior (SpiderTimeline x) a)

73+holdSpiderEventM v0 e = fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e

74+

75+holdDynSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)

76+holdDynSpiderEventM v0 e = fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e

77+

78+holdIncrementalSpiderEventM :: (HasSpiderTimeline x, Patch p) => PatchTarget p -> Reflex.Class.Event (SpiderTimeline x) p -> EventM x (Reflex.Class.Incremental (SpiderTimeline x) p)

79+holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e

80+

81+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHost x) where

82+ {-# INLINABLE hold #-}

83+ hold v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.hold v0 e

84+ {-# INLINABLE holdDyn #-}

85+ holdDyn v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdDyn v0 e

86+ {-# INLINABLE holdIncremental #-}

87+ holdIncremental v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdIncremental v0 e

88+

89+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where

90+ sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can

91+

92+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHostFrame x) where

93+ {-# INLINABLE hold #-}

94+ hold v0 e = SpiderHostFrame $ fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e

95+ {-# INLINABLE holdDyn #-}

96+ holdDyn v0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e

97+ {-# INLINABLE holdIncremental #-}

98+ holdIncremental v0 e = SpiderHostFrame $ fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e

99+

100+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where

101+ {-# INLINABLE sample #-}

102+ sample = runFrame . readBehaviorUntracked . unSpiderBehavior

103+

104+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where

105+ {-# INLINABLE sample #-}

106+ sample = Reflex.Spider.Internal.ReadPhase . Reflex.Class.sample

107+

108+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where

109+ {-# INLINABLE hold #-}

110+ hold v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.hold v0 e

111+ {-# INLINABLE holdDyn #-}

112+ holdDyn v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdDyn v0 e

113+ {-# INLINABLE holdIncremental #-}

114+ holdIncremental v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdIncremental v0 e

115+

116+--------------------------------------------------------------------------------

117+-- Deprecated items

118+--------------------------------------------------------------------------------

119+

120+-- | 'SpiderEnv' is the old name for 'SpiderTimeline'

121+{-# DEPRECATED SpiderEnv "Use 'SpiderTimelineEnv' instead" #-}

122+type SpiderEnv = SpiderTimeline

src/Reflex/Spider/SpiderTimelineHost.include.hsnew file+57

@@ -0,0 +1,57 @@

1+instance HasSpiderTimeline x => Reflex.Host.Class.MonadSubscribeEvent (SpiderTimeline x) (SpiderHostFrame x) where

2+ {-# INLINABLE subscribeEvent #-}

3+ subscribeEvent e = SpiderHostFrame $ do

4+ --TODO: Unsubscribe eventually (manually and/or with weak ref)

5+ val <- liftIO $ newIORef Nothing

6+ subscription <- subscribe (unSpiderEvent e) $ Subscriber

7+ { subscriberPropagate = \a -> do

8+ liftIO $ writeIORef val $ Just a

9+ scheduleClear val

10+ , subscriberInvalidateHeight = \_ -> return ()

11+ , subscriberRecalculateHeight = \_ -> return ()

12+ }

13+ return $ SpiderEventHandle

14+ { spiderEventHandleSubscription = subscription

15+ , spiderEventHandleValue = val

16+ }

17+

18+instance HasSpiderTimeline x => Reflex.Host.Class.ReflexHost (SpiderTimeline x) where

19+ type EventTrigger (SpiderTimeline x) = RootTrigger x

20+ type EventHandle (SpiderTimeline x) = SpiderEventHandle x

21+ type HostFrame (SpiderTimeline x) = SpiderHostFrame x

22+

23+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReadEvent (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where

24+ {-# NOINLINE readEvent #-}

25+ readEvent h = Reflex.Spider.Internal.ReadPhase $ fmap (fmap return) $ liftIO $ do

26+ result <- readIORef $ spiderEventHandleValue h

27+ touch h

28+ return result

29+

30+instance (

31+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

32+ x ~ Global

33+#endif

34+ ) => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where

35+ newEventWithTrigger = SpiderHost . lift . fmap SpiderEvent . newEventWithTriggerIO

36+ newFanEventWithTrigger f = SpiderHost $ lift $ do

37+ es <- newFanEventWithTriggerIO f

38+ return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es

39+

40+instance (

41+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

42+ x ~ Global

43+#endif

44+ ) => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where

45+ newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO

46+ newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do

47+ es <- newFanEventWithTriggerIO f

48+ return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es

49+

50+instance HasSpiderTimeline x => Reflex.Host.Class.MonadSubscribeEvent (SpiderTimeline x) (SpiderHost x) where

51+ {-# INLINABLE subscribeEvent #-}

52+ subscribeEvent = runFrame . runSpiderHostFrame . Reflex.Host.Class.subscribeEvent

53+

54+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexHost (SpiderTimeline x) (SpiderHost x) where

55+ type ReadPhase (SpiderHost x) = Reflex.Spider.Internal.ReadPhase x

56+ fireEventsAndRead es (Reflex.Spider.Internal.ReadPhase a) = run es a

57+ runHostFrame = runFrame . runSpiderHostFrame

src/Reflex/Time.hsdeleted−384

@@ -1,384 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveDataTypeable #-}

3−{-# LANGUAGE DeriveGeneric #-}

4−{-# LANGUAGE DeriveTraversable #-}

5−{-# LANGUAGE FlexibleContexts #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

7−{-# LANGUAGE RecursiveDo #-}

8−{-# LANGUAGE ScopedTypeVariables #-}

9−{-# LANGUAGE TupleSections #-}

10−{-# LANGUAGE TypeFamilies #-}

11−#ifdef USE_TEMPLATE_HASKELL

12−{-# LANGUAGE TemplateHaskell #-}

13−#endif

14−-- |

15−-- Module:

16−-- Reflex.Time

17−-- Description:

18−-- Clocks, timers, and other time-related functions.

19−module Reflex.Time where

20−

21−import Reflex.Class

22−import Reflex.Dynamic

23−import Reflex.PerformEvent.Class

24−import Reflex.PostBuild.Class

25−import Reflex.TriggerEvent.Class

26−

27−import Control.Concurrent

28−import qualified Control.Concurrent.Thread.Delay as Concurrent

29−import Control.Lens hiding ((|>))

30−import Control.Monad

31−import Control.Monad.Fix

32−import Control.Monad.IO.Class

33−import Data.Align

34−import Data.Data (Data)

35−import Data.Fixed

36−import Data.Semigroup (Semigroup(..))

37−import Data.Sequence (Seq, (|>))

38−import qualified Data.Sequence as Seq

39−import Data.These

40−import Data.Time.Clock

41−import Data.Typeable

42−import GHC.Generics (Generic)

43−import System.Random

44−

45−-- | Metadata associated with a timer "tick"

46−data TickInfo

47− = TickInfo { _tickInfo_lastUTC :: UTCTime

48− -- ^ UTC time immediately after the last tick.

49− , _tickInfo_n :: Integer

50− -- ^ Number of time periods or ticks since the start of the timer

51− , _tickInfo_alreadyElapsed :: NominalDiffTime

52− -- ^ Amount of time that has elapsed in the current tick period.

53− }

54− deriving (Eq, Ord, Show, Typeable)

55−

56−-- | Fires an 'Event' once every time provided interval elapses, approximately.

57−-- The provided 'UTCTime' is used bootstrap the determination of how much time has elapsed with each tick.

58−-- This is a special case of 'tickLossyFrom' that uses the post-build event to start the tick thread.

59−tickLossy :: (PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m) => NominalDiffTime -> UTCTime -> m (Event t TickInfo)

60−tickLossy dt t0 = tickLossyFrom dt t0 =<< getPostBuild

61−

62−-- | Fires an 'Event' once every time provided interval elapses, approximately.

63−-- This is a special case of 'tickLossyFrom' that uses the post-build event to start the tick thread and the time of the post-build as the tick basis time.

64−tickLossyFromPostBuildTime :: (PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m) => NominalDiffTime -> m (Event t TickInfo)

65−tickLossyFromPostBuildTime dt = do

66− postBuild <- getPostBuild

67− postBuildTime <- performEvent $ liftIO getCurrentTime <$ postBuild

68− tickLossyFrom' $ (dt,) <$> postBuildTime

69−

70−-- | Fires an 'Event' approximately each time the provided interval elapses. If the system starts running behind, occurrences will be dropped rather than buffered.

71−-- Each occurrence of the resulting event will contain the index of the current interval, with 0 representing the provided initial time.

72−tickLossyFrom

73− :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m)

74− => NominalDiffTime

75− -- ^ The length of a tick interval

76− -> UTCTime

77− -- ^ The basis time from which intervals count and with which the initial calculation of elapsed time will be made.

78− -> Event t a

79− -- ^ Event that starts a tick generation thread. Usually you want this to

80− -- be something like the result of getPostBuild that only fires once. But

81− -- there could be uses for starting multiple timer threads.

82− -> m (Event t TickInfo)

83−tickLossyFrom dt t0 e = tickLossyFrom' $ (dt, t0) <$ e

84−

85−-- | Generalization of tickLossyFrom that takes the delay and initial time as an 'Event'.

86−tickLossyFrom'

87− :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m)

88− => Event t (NominalDiffTime, UTCTime)

89− -- ^ Event that starts a tick generation thread. Usually you want this to

90− -- be something like the result of 'getPostBuild' that only fires once. But

91− -- there could be uses for starting multiple timer threads.

92− -> m (Event t TickInfo)

93−tickLossyFrom' e = do

94− rec result <- performEventAsync $ callAtNextInterval <$> leftmost [e, snd <$> result]

95− return $ fst <$> result

96− where callAtNextInterval pair cb = void $ liftIO $ forkIO $ do

97− tick <- uncurry getCurrentTick pair

98− Concurrent.delay $ ceiling $ (fst pair - _tickInfo_alreadyElapsed tick) * 1000000

99− cb (tick, pair)

100−

101−-- | Like 'tickLossy', but immediately calculates the first tick and provides a 'Dynamic' that is updated as ticks fire.

102−clockLossy :: (MonadIO m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), PostBuild t m, MonadHold t m, MonadFix m) => NominalDiffTime -> UTCTime -> m (Dynamic t TickInfo)

103−clockLossy dt t0 = do

104− initial <- liftIO $ getCurrentTick dt t0

105− e <- tickLossy dt t0

106− holdDyn initial e

107−

108−-- | Generates a 'TickInfo', given the specified interval and timestamp. The 'TickInfo' will include the

109−-- current time, the number of ticks that have elapsed since the timestamp, and the amount of time that

110−-- has elapsed since the start time of this tick.

111−getCurrentTick :: NominalDiffTime -> UTCTime -> IO TickInfo

112−getCurrentTick dt t0 = do

113− t <- getCurrentTime

114− let offset = t `diffUTCTime` t0

115− (n, alreadyElapsed) = offset `divMod'` dt

116− return $ TickInfo t n alreadyElapsed

117−

118−-- | Delay an Event's occurrences by a given amount in seconds.

119−delay :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t a)

120−delay dt e = performEventAsync $ ffor e $ \a cb -> liftIO $ void $ forkIO $ do

121− Concurrent.delay $ ceiling $ dt * 1000000

122− cb a

123−

124−-- | Send events with Poisson timing with the given basis and rate

125−-- Each occurrence of the resulting event will contain the index of

126−-- the current interval, with 0 representing the basis time

127−poissonLossyFrom

128− :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m)

129− => g

130− -> Double

131− -- ^ Poisson event rate (Hz)

132− -> UTCTime

133− -- ^ Baseline time for events

134− -> Event t a

135− -- ^ Event that starts a tick generation thread. Usually you want this to

136− -- be something like the result of getPostBuild that only fires once. But

137− -- there could be uses for starting multiple timer threads.

138− -- Start sending events in response to the event parameter.

139− -> m (Event t TickInfo)

140−poissonLossyFrom rnd rate = inhomogeneousPoissonFrom rnd (constant rate) rate

141−

142−

143−-- | Send events with Poisson timing with the given basis and rate

144−-- Each occurrence of the resulting event will contain the index of

145−-- the current interval, with 0 representing the basis time.

146−-- Automatically begin sending events when the DOM is built

147−poissonLossy

148− :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, PostBuild t m)

149− => g

150− -> Double

151− -- ^ Poisson event rate (Hz)

152− -> UTCTime

153− -- ^ Baseline time for events

154− -> m (Event t TickInfo)

155−poissonLossy rnd rate t0 = poissonLossyFrom rnd rate t0 =<< getPostBuild

156−

157−-- | Send events with inhomogeneous Poisson timing with the given basis

158−-- and variable rate. Provide a maxRate that you expect to support.

159−inhomogeneousPoissonFrom

160− :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m)

161− => g

162− -> Behavior t Double

163− -> Double

164− -> UTCTime

165− -> Event t a

166− -> m (Event t TickInfo)

167−inhomogeneousPoissonFrom rnd rate maxRate t0 e = do

168−

169− -- Create a thread for producing homogeneous poisson events

170− -- along with random Doubles (usage of Double's explained below)

171− ticksWithRateRand <- performEventAsync $

172− fmap callAtNextInterval e

173−

174− -- Filter homogeneous events according to associated

175− -- random values and the current rate parameter

176− return $ attachWithMaybe filterFun rate ticksWithRateRand

177−

178− where

179−

180− -- Inhomogeneous poisson processes are built from faster

181− -- homogeneous ones by randomly dropping events from the

182− -- fast process. For each fast homogeneous event, choose

183− -- a uniform random sample from (0, rMax). If the

184− -- inhomogeneous rate at this moment is greater than the

185− -- random sample, then keep this event, otherwise drop it

186− filterFun :: Double -> (TickInfo, Double) -> Maybe TickInfo

187− filterFun r (tInfo, p)

188− | r >= p = Just tInfo

189− | otherwise = Nothing

190−

191− callAtNextInterval _ cb = void $ liftIO $ forkIO $ go t0 rnd cb 0

192−

193− go tTargetLast lastGen cb lastN = do

194− t <- getCurrentTime

195−

196− -- Generate random numbers for this poisson interval (u)

197− -- and sample-retention likelihood (p)

198− let (u, nextGen) = randomR (0,1) lastGen

199− (p :: Double, nextGen') = randomR (0,maxRate) nextGen

200−

201− -- Inter-event interval is drawn from exponential

202− -- distribution accourding to u

203− let dt = realToFrac $ (-1) * log u / maxRate :: NominalDiffTime

204− nEvents = lastN + 1

205− alreadyElapsed = diffUTCTime t tTargetLast

206− tTarget = addUTCTime dt tTargetLast

207− thisDelay = realToFrac $ diffUTCTime tTarget t :: Double

208− Concurrent.delay $ ceiling $ thisDelay * 1000000

209− _ <- cb (TickInfo t nEvents alreadyElapsed, p)

210− go tTarget nextGen' cb nEvents

211−

212−-- | Send events with inhomogeneous Poisson timing with the given basis

213−-- and variable rate. Provide a maxRate that you expect to support

214−inhomogeneousPoisson

215− :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, PostBuild t m)

216− => g

217− -> Behavior t Double

218− -> Double

219− -> UTCTime

220− -> m (Event t TickInfo)

221−inhomogeneousPoisson rnd rate maxRate t0 =

222− inhomogeneousPoissonFrom rnd rate maxRate t0 =<< getPostBuild

223−

224−-- | Block occurrences of an Event until the given number of seconds elapses without

225−-- the Event firing, at which point the last occurrence of the Event will fire.

226−debounce :: (MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t a)

227−debounce dt e = do

228− n :: Dynamic t Integer <- count e

229− let tagged = attachPromptlyDynWith (,) n e

230− delayed <- delay dt tagged

231− return $ attachWithMaybe (\n' (t, v) -> if n' == t then Just v else Nothing) (current n) delayed

232−

233−-- | When the given 'Event' occurs, wait the given amount of time and collect

234−-- all occurrences during that time. Then, fire the output 'Event' with the

235−-- collected output.

236−batchOccurrences :: (MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t (Seq a))

237−batchOccurrences t newValues = do

238− let f s x = (Just newState, out)

239− where newState = case x of

240− This a -> s |> a

241− That _ -> mempty

242− These a _ -> Seq.singleton a

243− out = case x of

244− This _ -> if Seq.null s then Just () else Nothing

245− That _ -> Nothing

246− These _ _ -> Just ()

247− rec (buffer, toDelay) <- mapAccumMaybe f mempty $ align newValues delayed

248− delayed <- delay t toDelay

249− return $ tag buffer delayed

250−

251−-- | Throttle an input event, ensuring that at least a given amount of time passes between occurrences of the output event. If the input event occurs too

252−-- frequently, the output event occurs with the most recently seen input value after the given delay passes since the last occurrence of the output.

253−-- If the output event has not occurred recently, occurrences of the input event will cause the output event to fire immediately.

254−throttle :: (MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t a)

255−throttle t e = do

256− let f (immediate, buffer) x = case x of -- (Just newState, out)

257− This a -- If only the input event fires

258− | immediate -> -- and we're in immediate mode

259− -- Immediate mode turns off, and the buffer is empty.

260− -- We fire the output event with the input event value immediately.

261− (Just (False, Nothing), Just a)

262− | otherwise -> -- and we're not in immediate mode

263− -- Immediate mode remains off, and we replace the contents of the buffer (if any) with the input value.

264− -- We don't fire the output event.

265− (Just (False, Just a), Nothing)

266− That _ -> -- If only the delayed output event fires,

267− case buffer of

268− Nothing -> -- and the buffer is empty:

269− -- Immediate mode turns back on, and the buffer remains empty.

270− -- We don't fire.

271− (Just (True, Nothing), Nothing)

272− Just b -> -- and the buffer is full:

273− -- Immediate mode remains off, and the buffer is cleared.

274− -- We fire with the buffered value.

275− (Just (False, Nothing), Just b)

276− These a _ -> -- If both the input and delayed output event fire simultaneously:

277− -- Immediate mode turns off, and the buffer is empty.

278− -- We fire with the input event's value, as it is the most recent we have seen at this moment.

279− (Just (False, Nothing), Just a)

280− rec (_, outE) <- mapAccumMaybeDyn f (True, Nothing) $ align e delayed -- We start in immediate mode with an empty buffer.

281− delayed <- delay t outE

282− return outE

283−

284−data ThrottleState b

285− = ThrottleState_Immediate

286− | ThrottleState_Buffered (ThrottleBuffer b)

287− deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic, Data, Typeable)

288−

289−data ThrottleBuffer b

290− = ThrottleBuffer_Empty -- Empty conflicts with lens, and hiding it would require turning

291− -- on PatternSynonyms

292− | ThrottleBuffer_Full b

293− deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic, Data, Typeable)

294−

295−instance Semigroup b => Semigroup (ThrottleBuffer b) where

296− x <> y = case x of

297− ThrottleBuffer_Empty -> y

298− ThrottleBuffer_Full b1 -> case y of

299− ThrottleBuffer_Empty -> x

300− ThrottleBuffer_Full b2 -> ThrottleBuffer_Full $ b1 <> b2

301− {-# INLINE (<>) #-}

302−

303−instance Semigroup b => Monoid (ThrottleBuffer b) where

304− mempty = ThrottleBuffer_Empty

305− {-# INLINE mempty #-}

306− mappend = (<>)

307− {-# INLINE mappend #-}

308−

309−-- | Throttle an input event, ensuring that the output event doesn't occur more often than you are ready for it. If the input event occurs too

310−-- frequently, the output event will contain semigroup-based summaries of the input firings that happened since the last output firing.

311−-- If the output event has not occurred recently, occurrences of the input event will cause the output event to fire immediately.

312−-- The first parameter is a function that receives access to the output event, and should construct an event that fires when the receiver is

313−-- ready for more input. For example, using @delay 20@ would give a simple time-based throttle.

314−--

315−-- NB: The provided lag function must *actually* delay the event.

316−throttleBatchWithLag :: (MonadFix m, MonadHold t m, PerformEvent t m, Semigroup a) => (Event t () -> m (Event t ())) -> Event t a -> m (Event t a)

317−-- Invariants:

318−-- * Immediate mode must turn off whenever output is produced.

319−-- * Output must be produced whenever immediate mode turns from on to off.

320−-- * Immediate mode can only go from off to on when the delayed event fires.

321−-- * Every input firing must go into either an immediate output firing or the

322−-- buffer, but not both.

323−-- * An existing full buffer must either stay in the buffer or go to output,

324−-- but not both.

325−throttleBatchWithLag lag e = do

326− let f state x = case x of -- (Just $ newState, out)

327− This a -> -- If only the input event fires

328− case state of

329− ThrottleState_Immediate -> -- and we're in immediate mode

330− -- Immediate mode turns off, and the buffer is empty.

331− -- We fire the output event with the input event value immediately.

332− (Just $ ThrottleState_Buffered $ ThrottleBuffer_Empty, Just a)

333− ThrottleState_Buffered b -> -- and we're not in immediate mode

334− -- Immediate mode remains off, and we accumulate the input value.

335− -- We don't fire the output event.

336− (Just $ ThrottleState_Buffered $ b <> ThrottleBuffer_Full a, Nothing)

337− That _ -> -- If only the delayed output event fires,

338− case state of

339− ThrottleState_Immediate -> -- and we're in immediate mode

340− -- Nothing happens.

341− (Nothing, Nothing)

342− ThrottleState_Buffered ThrottleBuffer_Empty -> -- and the buffer is empty:

343− -- Immediate mode turns back on, and the buffer remains empty.

344− -- We don't fire.

345− (Just ThrottleState_Immediate, Nothing)

346− ThrottleState_Buffered (ThrottleBuffer_Full b) -> -- and the buffer is full:

347− -- Immediate mode remains off, and the buffer is cleared.

348− -- We fire with the buffered value.

349− (Just $ ThrottleState_Buffered ThrottleBuffer_Empty, Just b)

350− These a _ -> -- If both the input and delayed output event fire simultaneously:

351− case state of

352− ThrottleState_Immediate -> -- and we're in immediate mode

353− -- Immediate mode turns off, and the buffer is empty.

354− -- We fire with the input event's value, as it is the most recent we have seen at this moment.

355− (Just $ ThrottleState_Buffered ThrottleBuffer_Empty, Just a)

356− ThrottleState_Buffered ThrottleBuffer_Empty -> -- and the buffer is empty:

357− -- Immediate mode stays off, and the buffer remains empty.

358− -- We fire with the input event's value.

359− (Just $ ThrottleState_Buffered ThrottleBuffer_Empty, Just a)

360− ThrottleState_Buffered (ThrottleBuffer_Full b) -> -- and the buffer is full:

361− -- Immediate mode remains off, and the buffer is cleared.

362− -- We fire with everything including the buffered value.

363− (Just $ ThrottleState_Buffered ThrottleBuffer_Empty, Just (b <> a))

364− rec (_stateDyn, outE) <- mapAccumMaybeDyn f

365− ThrottleState_Immediate -- We start in immediate mode with an empty buffer.

366− (align e delayed)

367− delayed <- lag (void outE)

368− return outE

369−

370−#ifdef USE_TEMPLATE_HASKELL

371−makeLensesWith (lensRules & simpleLenses .~ True) ''TickInfo

372−#else

373−tickInfo_lastUTC :: Lens' TickInfo UTCTime

374−tickInfo_lastUTC f (TickInfo x1 x2 x3) = (\y -> TickInfo y x2 x3) <$> f x1

375−{-# INLINE tickInfo_lastUTC #-}

376−

377−tickInfo_n :: Lens' TickInfo Integer

378−tickInfo_n f (TickInfo x1 x2 x3) = (\y -> TickInfo x1 y x3) <$> f x2

379−{-# INLINE tickInfo_n #-}

380−

381−tickInfo_alreadyElapsed :: Lens' TickInfo NominalDiffTime

382−tickInfo_alreadyElapsed f (TickInfo x1 x2 x3) = (\y -> TickInfo x1 x2 y) <$> f x3

383−{-# INLINE tickInfo_alreadyElapsed #-}

384−#endif

src/Reflex/TriggerEvent/Base.hs+4−43

@@ -13,19 +13,12 @@ module Reflex.TriggerEvent.Base

13 , EventTriggerRef (..)

14 ) where

16−import Control.Applicative (liftA2)

17import Control.Concurrent

16import Control.Concurrent

18import Control.Monad.Exception

17import Control.Monad.Exception

19−import Control.Monad.Primitive

20import Control.Monad.Reader

18import Control.Monad.Reader

21import Control.Monad.Ref

19import Control.Monad.Ref

22−import Data.Coerce

23import Data.Dependent.Sum

20import Data.Dependent.Sum

24−import Data.IORef

25−import Data.Monoid ((<>))

26−import qualified Data.Semigroup as S

27import Reflex.Class

21import Reflex.Class

28−import Reflex.Adjustable.Class

29import Reflex.Host.Class

22import Reflex.Host.Class

30import Reflex.PerformEvent.Class

23import Reflex.PerformEvent.Class

31import Reflex.PostBuild.Class

24import Reflex.PostBuild.Class

@@ -36,28 +29,21 @@ import Reflex.TriggerEvent.Class

36data TriggerInvocation a = TriggerInvocation a (IO ())

29data TriggerInvocation a = TriggerInvocation a (IO ())

38-- | A reference to an 'EventTrigger' suitable for firing with 'TriggerEventT'.

31-- | A reference to an 'EventTrigger' suitable for firing with 'TriggerEventT'.

39−newtype EventTriggerRef t a = EventTriggerRef { unEventTriggerRef :: IORef (Maybe (EventTrigger t a)) }

32+newtype EventTriggerRef t m a = EventTriggerRef { unEventTriggerRef :: Ref m (Maybe (EventTrigger t a)) }

41-- | A basic implementation of 'TriggerEvent'.

34-- | A basic implementation of 'TriggerEvent'.

42−newtype TriggerEventT t m a = TriggerEventT { unTriggerEventT :: ReaderT (Chan [DSum (EventTriggerRef t) TriggerInvocation]) m a }

35+newtype TriggerEventT t m a = TriggerEventT { unTriggerEventT :: ReaderT (Chan [DSum (EventTriggerRef t m) TriggerInvocation]) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)

43− deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)

45-- | Run a 'TriggerEventT' action. The argument should be a 'Chan' into which

37-- | Run a 'TriggerEventT' action. The argument should be a 'Chan' into which

46-- 'TriggerInvocation's can be passed; it is expected that some other thread

38-- 'TriggerInvocation's can be passed; it is expected that some other thread

47-- will be responsible for popping values out of the 'Chan' and firing their

39-- will be responsible for popping values out of the 'Chan' and firing their

48-- 'EventTrigger's.

40-- 'EventTrigger's.

49−runTriggerEventT :: TriggerEventT t m a -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a

41+runTriggerEventT :: TriggerEventT t m a -> Chan [DSum (EventTriggerRef t m) TriggerInvocation] -> m a

50runTriggerEventT = runReaderT . unTriggerEventT

42runTriggerEventT = runReaderT . unTriggerEventT

52instance MonadTrans (TriggerEventT t) where

44instance MonadTrans (TriggerEventT t) where

53− {-# INLINABLE lift #-}

54 lift = TriggerEventT . lift

45 lift = TriggerEventT . lift

56−instance PrimMonad m => PrimMonad (TriggerEventT t m) where

57− type PrimState (TriggerEventT t m) = PrimState m

58− {-# INLINABLE primitive #-}

59− primitive = lift . primitive

60−

61instance PerformEvent t m => PerformEvent t (TriggerEventT t m) where

47instance PerformEvent t m => PerformEvent t (TriggerEventT t m) where

62 type Performable (TriggerEventT t m) = Performable m

48 type Performable (TriggerEventT t m) = Performable m

63 {-# INLINABLE performEvent_ #-}

49 {-# INLINABLE performEvent_ #-}

@@ -118,33 +104,8 @@ instance MonadHold t m => MonadHold t (TriggerEventT t m) where

118 holdDyn v0 v' = lift $ holdDyn v0 v'

104 holdDyn v0 v' = lift $ holdDyn v0 v'

119 {-# INLINABLE holdIncremental #-}

105 {-# INLINABLE holdIncremental #-}

120 holdIncremental v0 v' = lift $ holdIncremental v0 v'

106 holdIncremental v0 v' = lift $ holdIncremental v0 v'

121− {-# INLINABLE buildDynamic #-}

122− buildDynamic a0 = lift . buildDynamic a0

123− {-# INLINABLE headE #-}

124− headE = lift . headE

125− {-# INLINABLE now #-}

126− now = lift now

127−

128−instance Adjustable t m => Adjustable t (TriggerEventT t m) where

129− {-# INLINABLE runWithReplace #-}

130− runWithReplace (TriggerEventT a0) a' = TriggerEventT $ runWithReplace a0 (coerceEvent a')

131− {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}

132− traverseIntMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseIntMapWithKeyWithAdjust (coerce . f) dm0 dm'

133− {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

134− traverseDMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjust (coerce . f) dm0 dm'

135− {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}

136− traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjustWithMove (coerce . f) dm0 dm'

137−

138−-- TODO: Monoid and Semigroup can likely be derived once ReaderT has them.

139−instance (Monoid a, Applicative m) => Monoid (TriggerEventT t m a) where

140− mempty = pure mempty

141− mappend = (<>)

142−

143−instance (S.Semigroup a, Applicative m) => S.Semigroup (TriggerEventT t m a) where

144− (<>) = liftA2 (S.<>)

145−

146

107

147-- | Retrieve the current 'Chan'; event trigger invocations pushed into it will

108-- | Retrieve the current 'Chan'; event trigger invocations pushed into it will

148-- be fired.

109-- be fired.

149−askEvents :: Monad m => TriggerEventT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])

110+askEvents :: Monad m => TriggerEventT t m (Chan [DSum (EventTriggerRef t m) TriggerInvocation])

150askEvents = TriggerEventT ask

111askEvents = TriggerEventT ask

src/Reflex/TriggerEvent/Class.hs+1−18

@@ -2,6 +2,7 @@

2-- new 'Event's that can be triggered from 'IO'.

3{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FunctionalDependencies #-}

5+{-# LANGUAGE MultiParamTypeClasses #-}

5{-# LANGUAGE UndecidableInstances #-}

6{-# LANGUAGE UndecidableInstances #-}

6module Reflex.TriggerEvent.Class

7module Reflex.TriggerEvent.Class

7 ( TriggerEvent (..)

8 ( TriggerEvent (..)

@@ -10,9 +11,6 @@ module Reflex.TriggerEvent.Class

10import Reflex.Class

11import Reflex.Class

12import Control.Monad.Reader

13import Control.Monad.Reader

13−import Control.Monad.State

14−import qualified Control.Monad.State.Strict as Strict

15−import Control.Monad.Trans.Maybe (MaybeT)

17--TODO: Shouldn't have IO hard-coded

15--TODO: Shouldn't have IO hard-coded

18-- | 'TriggerEvent' represents actions that can create 'Event's that can be

16-- | 'TriggerEvent' represents actions that can create 'Event's that can be

@@ -38,18 +36,3 @@ instance TriggerEvent t m => TriggerEvent t (ReaderT r m) where

38 newTriggerEvent = lift newTriggerEvent

36 newTriggerEvent = lift newTriggerEvent

39 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

37 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

40 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

38 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

41−

42−instance TriggerEvent t m => TriggerEvent t (StateT s m) where

43− newTriggerEvent = lift newTriggerEvent

44− newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

45− newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

46−

47−instance TriggerEvent t m => TriggerEvent t (Strict.StateT s m) where

48− newTriggerEvent = lift newTriggerEvent

49− newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

50− newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

51−

52−instance TriggerEvent t m => TriggerEvent t (MaybeT m) where

53− newTriggerEvent = lift newTriggerEvent

54− newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

55− newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

src/Reflex/Widget/Basic.hsdeleted−44

@@ -1,44 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE ExplicitForAll #-}

3−{-# LANGUAGE MultiParamTypeClasses #-}

4−{-# LANGUAGE RecursiveDo #-}

5−#ifdef USE_REFLEX_OPTIMIZER

6−{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

7−#endif

8−

9−module Reflex.Widget.Basic where

10−

11−import Control.Monad.Fix (MonadFix)

12−import Data.Map (Map)

13−

14−import Reflex.Class

15−import Reflex.Adjustable.Class

16−import Data.Patch.MapWithMove

17−

18−

19−-- | Build sortable content in such a way that re-sorting it can cause minimal

20−-- disruption to an existing context.

21−--

22−-- Naively re-sorting a list of images would destroy every image and add them back

23−-- in the new order. This framework is able to avoid that by preserving the

24−-- identity of each image and simply moving it to the new location.

25−--

26−-- Example:

27−--

28−-- > let sortByFst = buttonA $> comparing fst

29−-- > sortBySnd = buttonB $> comparing snd

30−-- > sortEvent = leftmost [sortByFst, sortBySnd]

31−-- > sortableList

32−-- > (\k v -> text $ "\n" ++ show k ++ " " ++ v) -- show each element on a new line

33−-- > (Map.fromList $ zip [0..] [(3, "a"), (2, "b"), (1, "c")])

34−-- > sortEvent

35−sortableList :: forall t m k v a. (MonadHold t m, MonadFix m, Adjustable t m, Ord k)

36− => (k -> v -> m a) -- ^ Function to render the content for each key/value pair

37− -> Map k v -- ^ The sortable list with an initial ordering determined by the @Map@ keys in ascending order

38− -> Event t (v -> v -> Ordering) -- ^ An event carrying a sort function for the list

39− -> m (Map k a)

40−sortableList f m0 reSortFunc = do

41− rec let reSortPatch = attachWith (flip patchThatSortsMapWith) (currentIncremental m) reSortFunc

42− m <- holdIncremental m0 reSortPatch

43− (results, _) <- mapMapWithAdjustWithMove f m0 reSortPatch

44− pure results

src/Reflex/Workflow.hsdeleted−50

@@ -1,50 +0,0 @@

1−{-# LANGUAGE RecursiveDo #-}

2−{-# LANGUAGE ScopedTypeVariables #-}

3−-- |

4−-- Module:

5−-- Reflex.Workflow

6−-- Description:

7−-- Provides a convenient way to describe a series of interrelated widgets that

8−-- can send data to, invoke, and replace one another. Useful for modeling user interface

9−-- "workflows."

10−module Reflex.Workflow (

11− Workflow (..)

12− , workflow

13− , workflowView

14− , mapWorkflow

15− , mapWorkflowCheap

16− ) where

17−

18−import Control.Arrow ((***))

19−import Control.Monad.Fix (MonadFix)

20−

21−import Reflex.Class

22−import Reflex.Adjustable.Class

23−import Reflex.Network

24−import Reflex.NotReady.Class

25−import Reflex.PostBuild.Class

26−

27−-- | A widget in a workflow

28−-- When the 'Event' returned by a 'Workflow' fires, the current 'Workflow' is replaced by the one inside the firing 'Event'. A series of 'Workflow's must share the same return type.

29−newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }

30−

31−-- | Runs a 'Workflow' and returns the 'Dynamic' result of the 'Workflow' (i.e., a 'Dynamic' of the value produced by the current 'Workflow' node, and whose update 'Event' fires whenever one 'Workflow' is replaced by another).

32−workflow :: forall t m a. (Reflex t, Adjustable t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a)

33−workflow w0 = do

34− rec eResult <- networkHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult

35− return $ fmap fst eResult

36−

37−-- | Similar to 'workflow', but outputs an 'Event' that fires at post-build time and whenever the current 'Workflow' is replaced by the next 'Workflow'.

38−workflowView :: forall t m a. (Reflex t, NotReady t m, Adjustable t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a)

39−workflowView w0 = do

40− rec eResult <- networkView . fmap unWorkflow =<< holdDyn w0 eReplace

41− eReplace <- fmap switch $ hold never $ fmap snd eResult

42− return $ fmap fst eResult

43−

44−-- | Map a function over a 'Workflow', possibly changing the return type.

45−mapWorkflow :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b

46−mapWorkflow f (Workflow x) = Workflow (fmap (f *** fmap (mapWorkflow f)) x)

47−

48−-- | Map a "cheap" function over a 'Workflow'. Refer to the documentation for 'pushCheap' for more information and performance considerations.

49−mapWorkflowCheap :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b

50−mapWorkflowCheap f (Workflow x) = Workflow (fmap (f *** fmapCheap (mapWorkflowCheap f)) x)

stylizedeleted−4

@@ -1,4 +0,0 @@

1−#!/usr/bin/env bash

2−set -euo pipefail

3−

4−for x in **/*.hs ; do stylish-haskell -i "$x" ; done

test/Adjustable.hsdeleted−62

@@ -1,62 +0,0 @@

1−{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE LambdaCase #-}

3−{-# LANGUAGE RankNTypes #-}

4−{-# LANGUAGE RecursiveDo #-}

5−

6−module Main where

7−

8−import Control.Monad.Fix

9−import Data.Maybe

10−import qualified Data.Map as Map

11−

12−import Reflex

13−import Reflex.EventWriter.Base

14−import Reflex.Network

15−import Reflex.Patch.MapWithMove

16−import Test.Run

17−

18−main :: IO ()

19−main = do

20− let actions = [ Increment, Update0th, Increment, Swap, Increment, Increment ]

21− os <- runAppB testPatchMapWithMove $ map Just actions

22− -- If the final counter value in the adjusted widgets corresponds to the number of times it has

23− -- been incremented, we know that the networks haven't broken.

24− let expectedCount = length $ ffilter (== Increment) actions

25− -- let !True = last (last os) == [expectedCount,expectedCount] -- TODO re-enable this test after issue #369 has been resolved

26− return ()

27−

28−data PatchMapTestAction

29− = Increment

30− | Swap

31− | Update0th

32− deriving Eq

33−

34−-- See https://github.com/reflex-frp/reflex/issues/369 for the bug that this is testing.

35−testPatchMapWithMove

36− :: forall t m

37− . ( Reflex t

38− , Adjustable t m

39− , MonadHold t m

40− , MonadFix m

41− )

42− => Event t PatchMapTestAction

43− -> m (Behavior t [Int])

44−testPatchMapWithMove pulse = do

45− let pulseAction = ffor pulse $ \case

46− Increment -> Nothing

47− Swap -> patchMapWithMove $ Map.fromList

48− [ (0, NodeInfo (From_Move 1) (Just 1))

49− , (1, NodeInfo (From_Move 0) (Just 0))

50− ]

51− Update0th -> patchMapWithMove $ Map.fromList

52− [ (0, NodeInfo (From_Insert 'z') Nothing) ]

53− (_, result) <- runBehaviorWriterT $ mdo

54− counter <- foldDyn (+) 1 $ fmapMaybe (\e -> if isNothing e then Just 1 else Nothing) pulseAction

55− _ <- mapMapWithAdjustWithMove

56− (\_ _ -> networkHold

57− (tellBehavior $ constant [])

58− ((\t -> tellBehavior $ constant [t]) <$> updated counter))

59− (Map.fromList $ zip [0..] "ab")

60− (fmapMaybe id pulseAction)

61− return ()

62− return result

test/DebugCycles.hsdeleted−171

@@ -1,171 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE GADTs #-}

5−{-# LANGUAGE RecursiveDo #-}

6−{-# LANGUAGE ScopedTypeVariables #-}

7−{-# LANGUAGE PatternSynonyms #-}

8−{-# LANGUAGE RankNTypes #-}

9−

10−module Main where

11−

12−import Data.Foldable

13−import Control.Lens

14−import Control.Applicative

15−import Control.Monad

16−import Control.Monad.Fix

17−import Control.Exception

18−import System.Timeout

19−import Data.Maybe (isJust)

20−import Data.Functor.Misc

21−import qualified Data.Map as Map

22−import Data.Map (Map)

23−import qualified Data.IntMap as IntMap

24−import Data.IntMap (IntMap)

25−import Data.These

26−import Data.Align

27−import Reflex

28−import Reflex.EventWriter.Base

29−import Test.Run

30−import Test.Hspec

31−import Reflex.Spider.Internal (EventLoopException)

32−import Data.Witherable (Filterable)

33−

34−#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))

35−import Data.These.Lens

36−#endif

37−

38−type Widget t m = (MonadHold t m, Reflex t, MonadFix m)

39−

40−connectDyn :: Widget t m => Event t () -> (Dynamic t a, Dynamic t a) -> m (Dynamic t a)

41−connectDyn e (d, d') = do

42− dd <- holdDyn d (d' <$ e)

43− return $ join dd

44−

45−dynLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

46−dynLoop (e1, e2) = do

47− -- "heightBagRemove: Height 2 not present in bag HeightBag {_heightBag_size = 2, _heightBag_contents = fromList [(0,1)]}"

48− rec

49− d <- count e1

50− d' <- connectDyn e2 (d, liftA2 (+) d d')

51− return $ updated d'

52−

53−connectOnCoincidence :: Widget t m => Event t () -> Event t a -> m (Event t a)

54−connectOnCoincidence click e = do

55− d <- holdDyn never (e <$ click)

56− return $ coincidence (updated d)

57−

58−coincidenceLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

59−coincidenceLoop (e1, e2) = do

60−-- "heightBagRemove: Height 1 not present in bag HeightBag {_heightBag_size = 1, _heightBag_contents = fromList [(0,0)]}"

61−-- (simpler version of dynLoop)

62− rec

63− e' <- connectOnCoincidence e2 (updated d)

64− d <- count (align e' e1)

65− return $ updated d

66−

67−addHeight :: Reflex t => Event t a -> Event t a

68−addHeight e = leftmost [e4, e4] where

69− e1 = leftmost [e, e]

70− e2 = leftmost [e1, e1]

71− e3 = leftmost [e2, e2]

72− e4 = leftmost [e3, e3]

73−

74−-- Take an existing test and build it inside a

75−buildLoop :: Widget t m => (forall t m. Widget t m => (Event t Int, Event t ()) -> m (Event t Int)) -> (Event t Int, Event t ()) -> m (Event t Int)

76−buildLoop test (e1, e2) = switchHold never buildLoop

77− where buildLoop = pushAlways (const $ test (e1, e2)) e2

78−

79−connectButtonPromptly :: Widget t m => Event t () -> Event t a -> m (Event t a)

80−connectButtonPromptly click e = do

81− d <- holdDyn never (e <$ click)

82− return (switchDyn d)

83−

84−connectButton :: Widget t m => Event t () -> Event t a -> m (Event t a)

85−connectButton click e = do

86− d <- hold never (e <$ click)

87− return (switch d)

88−

89−switchLoop01 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

90−switchLoop01 (e1, e2) = do

91− rec

92− e' <- connectButton e2 (updated d)

93− d <- count (align e' e1)

94− return $ updated d

95−

96−mergeLoop :: forall t m. (Adjustable t m, Widget t m) => (Event t Int, Event t ()) -> m (Event t Int)

97−mergeLoop (e1, e2) = do

98− rec

99− (_, e) <- runEventWriterT $

100− runWithReplace w (leftmost [w <$ e1])

101− return (sum <$> e)

102− where

103− w = do

104− c <- count e1

105− tellEvent (updated ((pure <$> c) :: Dynamic t [Int]))

106−

107−switchLoop02 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

108−switchLoop02 (e1, e2) = do

109− rec

110− e' <- connectButton e2 (updated d)

111− d <- count (leftmost [e', e1])

112− return $ updated d

113−

114−switchLoop03 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

115−switchLoop03 (e1, e2) = do

116− rec

117− e' <- connectButton e2 (addHeight $ updated d)

118− d <- count (align e' e1)

119− return $ updated d

120−

121−staticLoop01 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

122−staticLoop01 (e1, e2) = do

123− rec

124− d <- foldDyn (+) (0 :: Int) (1 <$ align e1 (updated d))

125− return $ updated d

126−

127−staticLoop02 :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

128−staticLoop02 (e1, e2) = do

129− rec

130− d <- foldDyn (+) (0 :: Int) (leftmost [e1, updated d])

131− return $ updated d

132−

133−buildStaticLoop :: Widget t m => (Event t Int, Event t ()) -> m (Event t Int)

134−buildStaticLoop (e1, e2) = switchHold never buildLoop

135− where buildLoop = pushAlways (const $ staticLoop01 (e1, e2)) e2

136−

137−splitThese :: Filterable f => f (These a b) -> (f a, f b)

138−splitThese f = (mapMaybe (preview here) f, mapMaybe (preview there) f)

139−

140−main :: IO ()

141−main = hspec $ do

142− describe "DebugCycles" $ do

143− it "throws EventLoopException on switchLoop01" $ do

144− check switchLoop01

145− it "throws EventLoopException on switchLoop02" $ do

146− check switchLoop02

147− it "throws EventLoopException on switchLoop03" $ do

148− check switchLoop03

149− it "throws EventLoopException on buildSwitchLoop" $ do

150− check $ buildLoop switchLoop01

151− xit "throws EventLoopException on mergeLoop" $ do

152− check mergeLoop

153− xit "throws EventLoopException on staticLoop01" $ do

154− check staticLoop01

155− xit "throws EventLoopException on staticLoop02" $ do

156− check staticLoop02

157− xit "throws EventLoopException on buildStaticLoop" $ do

158− check buildStaticLoop

159− xit "throws EventLoopException on coincidenceLoop" $ do

160− check coincidenceLoop

161− xit "throws EventLoopException on dynLoop" $ do

162− check dynLoop

163− xit "throws EventLoopException on buildCoincidenceLoop" $ do

164− check $ buildLoop coincidenceLoop

165− where

166− milliseconds = (*1000)

167− occs = [ This 1, This 2, That (), This 3, That (), This 1 ]

168− check test = do

169− let action = timeout (milliseconds 50) $ do

170− runApp' (test . splitThese) (Just <$> occs)

171− action `shouldThrow` (const True :: Selector EventLoopException)

test/EventWriterT.hs+53−126

@@ -1,134 +1,61 @@

1−{-# LANGUAGE CPP #-}

1+{-# LANGUAGE FlexibleContexts, GADTs #-}

2−{-# LANGUAGE BangPatterns #-}

3−{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE GADTs #-}

5−{-# LANGUAGE RecursiveDo #-}

6−{-# LANGUAGE ScopedTypeVariables #-}

7module Main where

2module Main where

9−import Control.Lens

10import Control.Monad

4import Control.Monad

11−import Control.Monad.Fix

5+import Control.Monad.IO.Class

12−import qualified Data.Dependent.Map as DMap

6+import Control.Monad.Ref

13−import Data.Functor.Misc

7+import Data.Dependent.Sum

14−import qualified Data.Map as M

8+import Data.IORef

15−import Data.These

9+import Data.List

16−

10+import Data.Functor.Identity

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

21import Reflex

12import Reflex

22−import Reflex.EventWriter.Base

13+import Reflex.EventWriter

23−import Test.Run

14+import Reflex.Host.Class

15+import Reflex.PerformEvent.Base

16+

17+import System.Exit (exitFailure)

25main :: IO ()

19main :: IO ()

26main = do

20main = do

27− os1@[[Just [10,9,8,7,6,5,4,3,2,1]]] <- runApp' (unwrapApp testOrdering) $

21+ (Just out1, Nothing) <- runApp app1

28− [ Just ()

22+ print out1

29− ]

23+ (Just out2, Just (out3, out4)) <- runApp app2

30− print os1

24+ print out2

31− os2@[[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]]

25+ print out3

32− <- runApp' (unwrapApp testSimultaneous) $ map Just $

26+ print out4

33− [ This ()

27+ when (sort out1 /= out1 || map (+1) out2 /= out3 || out3 /= out4) exitFailure

34− , That ()

28+

35− , This ()

29+runApp :: (Show a, t ~ SpiderTimeline Global, m ~ SpiderHost Global)

36− , These () ()

30+ => (Event t () -> EventWriterT t [a] (PerformEventT t m) (Maybe (Ref m (Maybe (EventTrigger t ())))))

37− ]

31+ -> IO (Maybe [a], Maybe ([a], [a]))

38− print os2

32+runApp x = runSpiderHost $ do

39− os3@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEvent) [Just ()]

33+ (pulseE, pulseTriggerRef) <- newEventWithTriggerRef

40− print os3

34+ ((mactuateRef, e), FireCommand fire) <- hostPerformEventT $ runEventWriterT (x pulseE)

41− os4@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEventDMap) [Just ()]

35+ hnd <- subscribeEvent e

42− print os4

36+ out1 <- fireEventRefAndRead pulseTriggerRef () hnd

43− os5@[[Nothing, Just [1, 2]]] <- runApp' (unwrapApp testLiveTellEventDMap) [Just ()]

37+ out2 <- fmap join $ forM mactuateRef $ \actuateRef -> do

44− print os5

38+ let readPhase = do

45− os6 <- runApp' (unwrapApp delayedPulse) [Just ()]

39+ mGetValue <- readEvent hnd

46− print os6

40+ case mGetValue of

47− let ![[Nothing, Nothing]] = os6

41+ Nothing -> return Nothing

48− return ()

42+ Just getValue -> fmap Just getValue

49−

43+ mactuate <- readRef actuateRef

50−unwrapApp :: (Reflex t, Monad m) => (a -> EventWriterT t [Int] m ()) -> a -> m (Event t [Int])

44+ mpulse <- readRef pulseTriggerRef

51−unwrapApp x appIn = do

45+ forM ((,) <$> mactuate <*> mpulse) $ \(actuate, pulse) -> do

52− ((), e) <- runEventWriterT $ x appIn

46+ _ <- fire [actuate :=> Identity ()] $ return ()

53− return e

47+ [Just a] <- fire [pulse :=> Identity ()] $ readPhase

54−

48+ [Just b, Nothing] <- fire [actuate :=> Identity (), pulse :=> Identity ()] $ readPhase

55−testOrdering :: (Reflex t, Monad m) => Event t () -> EventWriterT t [Int] m ()

49+ return (a,b)

56−testOrdering pulse = forM_ [10,9..1] $ \i -> tellEvent ([i] <$ pulse)

50+ return (out1, out2)

57−

51+

58−testSimultaneous :: (Reflex t, Adjustable t m, MonadHold t m) => Event t (These () ()) -> EventWriterT t [Int] m ()

52+app1 :: (Reflex t, Ref m ~ IORef, EventWriter t [Int] m) => Event t () -> m (Maybe (Ref m (Maybe (EventTrigger t ()))))

59−testSimultaneous pulse = do

53+app1 e = do

60− let e0 = fmapMaybe (^? here) pulse

54+ forM_ [1..10] $ \i -> tellEvent ([i] <$ e)

61− e1 = fmapMaybe (^? there) pulse

55+ return Nothing

62− forM_ [1,3..9] $ \i -> runWithReplace (tellEvent ([i] <$ e0)) $ ffor e1 $ \_ -> tellEvent ([i+1] <$ e0)

56+

63−

57+app2 :: (Reflex t, Ref m ~ IORef, EventWriter t [Int] m, MonadAdjust t m, MonadReflexCreateTrigger t m, MonadRef m) => Event t () -> m (Maybe (Ref m (Maybe (EventTrigger t ()))))

64−-- | Test that a widget telling and event which fires at the same time it has been replaced

58+app2 e = do

65−-- doesn't count along with the new widget.

59+ (pulse, pulseTriggerRef) <- newEventWithTriggerRef

66−testMoribundTellEvent

60+ forM_ [1,3..9] $ \i -> runWithReplace (tellEvent ([i] <$ e)) $ ffor pulse $ \_ -> tellEvent ([i+1] <$ e)

67− :: forall t m

61+ return (Just pulseTriggerRef)

68− . ( Reflex t

69− , Adjustable t m

70− , MonadHold t m

71− , MonadFix m

72− )

73− => Event t ()

74− -> EventWriterT t [Int] m ()

75−testMoribundTellEvent pulse = do

76− rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m ()

77− tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished

78− (_, rwrFinished) <- runWithReplace (tellIntOnReplace 1) $ tellIntOnReplace 2 <$ pulse

79− return ()

80−

81−-- | The equivalent of 'testMoribundTellEvent' for 'traverseDMapWithKeyWithAdjust'.

82−testMoribundTellEventDMap

83− :: forall t m

84− . ( Reflex t

85− , Adjustable t m

86− , MonadHold t m

87− , MonadFix m

88− )

89− => Event t ()

90− -> EventWriterT t [Int] m ()

91−testMoribundTellEventDMap pulse = do

92− rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m ()

93− tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished

94− (_, rwrFinished :: Event t (PatchDMap (Const2 () Int) Identity)) <-

95− traverseDMapWithKeyWithAdjust

96− (\(Const2 ()) (Identity v) -> Identity . const v <$> tellIntOnReplace v)

97− (mapToDMap $ M.singleton () 1)

98− ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton () 2) <$ pulse)

99− return ()

100−

101−-- | Ensures that elements which are _not_ removed can still fire 'tellEvent's

102−-- during the same frame as other elements are updated.

103−testLiveTellEventDMap

104− :: forall t m

105− . ( Reflex t

106− , Adjustable t m

107− , MonadHold t m

108− , MonadFix m

109− )

110− => Event t ()

111− -> EventWriterT t [Int] m ()

112−testLiveTellEventDMap pulse = do

113− rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m ()

114− tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished

115− (_, rwrFinished :: Event t (PatchDMap (Const2 Int ()) Identity)) <-

116− traverseDMapWithKeyWithAdjust

117− (\(Const2 k) (Identity ()) -> Identity <$> tellIntOnReplace k)

118− (mapToDMap $ M.singleton 1 ())

119− ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton 2 ()) <$ pulse)

120− return ()

121−

122−delayedPulse

123− :: forall t m

124− . ( Reflex t

125− , Adjustable t m

126− , MonadHold t m

127− , MonadFix m

128− )

129− => Event t ()

130− -> EventWriterT t [Int] m ()

131−delayedPulse pulse = void $ flip runWithReplace (pure () <$ pulse) $ do

132− -- This has the effect of delaying pulse' from pulse

133− (_, pulse') <- runWithReplace (pure ()) $ pure [1] <$ pulse

134− tellEvent pulse'

test/GC.hs+8−14

@@ -1,9 +1,4 @@

1−{-# LANGUAGE FlexibleContexts #-}

1+{-# LANGUAGE OverloadedStrings, FlexibleContexts, GADTs, TypeFamilies, RankNTypes, ScopedTypeVariables, LambdaCase #-}

2−{-# LANGUAGE GADTs #-}

3−{-# LANGUAGE OverloadedStrings #-}

4−{-# LANGUAGE RankNTypes #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE TypeFamilies #-}

7module Main where

2module Main where

9import Control.Monad

4import Control.Monad

@@ -18,17 +13,15 @@ import Data.GADT.Compare

18import Data.IORef

13import Data.IORef

19import Data.Semigroup

14import Data.Semigroup

20import Data.These

15import Data.These

21−import Data.Type.Equality ((:~:)(Refl))

23import Data.Functor.Misc

17import Data.Functor.Misc

24−import Data.Patch

18+import Reflex.Patch

26−import qualified Reflex.Host.Class as Host

27import qualified Reflex.Spider.Internal as S

20import qualified Reflex.Spider.Internal as S

21+import qualified Reflex.Host.Class as Host

29−import System.Exit

30import System.Mem

23import System.Mem

31−import Data.Coerce

24+import System.Exit

33main :: IO ()

26main :: IO ()

34main = do

27main = do

@@ -48,7 +41,7 @@ hostPerf ref = S.runSpiderHost $ do

48 eventToPerform <- Host.runHostFrame $ do

41 eventToPerform <- Host.runHostFrame $ do

49 (reqMap :: S.Event S.Global (DMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) Identity))

42 (reqMap :: S.Event S.Global (DMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) Identity))

50 <- S.SpiderHostFrame

43 <- S.SpiderHostFrame

51− $ fmap ( S.mergeG coerce

44+ $ fmap ( S.merge

52 . S.dynamicHold)

45 . S.dynamicHold)

53 $ S.hold DMap.empty

46 $ S.hold DMap.empty

54 -- Construct a new heap object for the subscriber, invalidating any weak references to the subscriber if they are not retained

47 -- Construct a new heap object for the subscriber, invalidating any weak references to the subscriber if they are not retained

@@ -57,8 +50,8 @@ hostPerf ref = S.runSpiderHost $ do

57 { S.subscriberPropagate = S.subscriberPropagate sub

50 { S.subscriberPropagate = S.subscriberPropagate sub

58 }

51 }

59 return (s, o))

52 return (s, o))

60− $ runIdentity . runIdentity <$> S.selectG

53+ $ runIdentity <$> S.select

61− (S.fanG $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response)

54+ (S.fan $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response)

62 (WrapArg Request)

55 (WrapArg Request)

63 return $ alignWith (mergeThese (<>))

56 return $ alignWith (mergeThese (<>))

64 (flip S.pushCheap eadd $ \_ -> return $ Just $ DMap.singleton Request $ do

57 (flip S.pushCheap eadd $ \_ -> return $ Just $ DMap.singleton Request $ do

@@ -84,6 +77,7 @@ hostPerf ref = S.runSpiderHost $ do

84 Nothing -> []

77 Nothing -> []

85 Host.fireEventsAndRead followupEventTriggers $ return ()

78 Host.fireEventsAndRead followupEventTriggers $ return ()

86 return ()

79 return ()

80+ return ()

88data Tell a where

82data Tell a where

89 Action :: Tell ()

83 Action :: Tell ()

test/Headless.hsdeleted−10

@@ -1,10 +0,0 @@

1−module Main where

2−

3−import Reflex

4−import Reflex.Host.Headless (runHeadlessApp)

5−

6−main :: IO ()

7−main = do

8− runHeadlessApp $ do

9− pb <- getPostBuild

10− performEvent (pure <$> pb)

test/QueryT.hsdeleted−142

@@ -1,142 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveFunctor #-}

3−{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5−{-# LANGUAGE LambdaCase #-}

6−{-# LANGUAGE RankNTypes #-}

7−{-# LANGUAGE StandaloneDeriving #-}

8−{-# LANGUAGE TypeFamilies #-}

9−{-# LANGUAGE UndecidableInstances #-}

10−

11−import Control.Lens

12−import Control.Monad.Fix

13−import Data.Align

14−import qualified Data.AppendMap as AMap

15−import Data.Functor.Misc

16−import Data.Map (Map)

17−import qualified Data.Map as Map

18−import Data.Map.Monoidal (MonoidalMap)

19−import Data.Semigroup

20−import Data.These

21−

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−

26−import Reflex

27−import Data.Patch.MapWithMove

28−import Test.Run

29−

30−newtype MyQuery = MyQuery SelectedCount

31− deriving (Show, Read, Eq, Ord, Monoid, Semigroup, Additive, Group)

32−

33−instance Query MyQuery where

34− type QueryResult MyQuery = ()

35− crop _ _ = ()

36−

37−instance (Ord k, Query a, Eq (QueryResult a), Align (MonoidalMap k)) => Query (Selector k a) where

38− type QueryResult (Selector k a) = Selector k (QueryResult a)

39− crop q r = undefined

40−

41−newtype Selector k a = Selector { unSelector :: MonoidalMap k a }

42− deriving (Show, Read, Eq, Ord, Functor)

43−

44−#if !(MIN_VERSION_monoidal_containers(0,4,1))

45−deriving instance Ord k => Align (MonoidalMap k)

46−#endif

47−

48−instance (Ord k, Eq a, Monoid a, Align (MonoidalMap k)) => Semigroup (Selector k a) where

49− (Selector a) <> (Selector b) = Selector $ fmapMaybe id $ f a b

50− where

51− f = alignWith $ \case

52− This x -> Just x

53− That y -> Just y

54− These x y ->

55− let z = x `mappend` y

56− in if z == mempty then Nothing else Just z

57−

58−instance (Ord k, Eq a, Monoid a, Align (MonoidalMap k)) => Monoid (Selector k a) where

59− mempty = Selector AMap.empty

60− mappend = (<>)

61−

62−instance (Eq a, Ord k, Group a, Align (MonoidalMap k)) => Group (Selector k a) where

63− negateG = fmap negateG

64−

65−instance (Eq a, Ord k, Group a, Align (MonoidalMap k)) => Additive (Selector k a)

66−

67−main :: IO ()

68−main = do

69− [0, 1, 1, 0] <- fmap (map fst . concat) $

70− runApp (testQueryT testRunWithReplace) () $ map (Just . That) $

71− [ That (), This (), That () ]

72− [0, 1, 1, 0] <- fmap (map fst . concat) $

73− runApp (testQueryT testSequenceDMapWithAdjust) () $ map (Just . That) $

74− [ That (), This (), That () ]

75− [0, 1, 1, 0] <- fmap (map fst . concat) $

76− runApp (testQueryT testSequenceDMapWithAdjustWithMove) () $ map (Just . That) $

77− [ That (), This (), That () ]

78− return ()

79−

80−testQueryT :: (Reflex t, MonadFix m)

81− => (Event t () -> Event t () -> QueryT t (Selector Int MyQuery) m ())

82− -> AppIn t () (These () ())

83− -> m (AppOut t Int Int)

84−testQueryT w (AppIn _ pulse) = do

85− let replace = fmapMaybe (^? here) pulse

86− increment = fmapMaybe (^? there) pulse

87− (_, q) <- runQueryT (w replace increment) $ pure mempty

88− let qDyn = head . AMap.keys . unSelector <$> incrementalToDynamic q

89− return $ AppOut

90− { _appOut_behavior = current qDyn

91− , _appOut_event = updated qDyn

92− }

93−

94−testRunWithReplace :: ( Reflex t

95− , Adjustable t m

96− , MonadHold t m

97− , MonadFix m

98− , MonadQuery t (Selector Int MyQuery) m)

99− => Event t ()

100− -> Event t ()

101− -> m ()

102−testRunWithReplace replace increment = do

103− let w = do

104− n <- count increment

105− queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1

106− _ <- runWithReplace w $ w <$ replace

107− return ()

108−

109−testSequenceDMapWithAdjust :: ( Reflex t

110− , Adjustable t m

111− , MonadHold t m

112− , MonadFix m

113− , MonadQuery t (Selector Int MyQuery) m)

114− => Event t ()

115− -> Event t ()

116− -> m ()

117−testSequenceDMapWithAdjust replace increment = do

118− _ <- listHoldWithKey (Map.singleton () ()) (Map.singleton () (Just ()) <$ replace) $ \_ _ -> do

119− n <- count increment

120− queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1

121− return ()

122−

123−testSequenceDMapWithAdjustWithMove :: ( Reflex t

124− , Adjustable t m

125− , MonadHold t m

126− , MonadFix m

127− , MonadQuery t (Selector Int MyQuery) m)

128− => Event t ()

129− -> Event t ()

130− -> m ()

131−testSequenceDMapWithAdjustWithMove replace increment = do

132− _ <- listHoldWithKeyWithMove (Map.singleton () ()) (Map.singleton () (Just ()) <$ replace) $ \_ _ -> do

133− n <- count increment

134− queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1

135− return ()

136−

137−-- scam it out to test traverseDMapWithAdjustWithMove

138−listHoldWithKeyWithMove :: forall t m k v a. (Ord k, MonadHold t m, Adjustable t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a))

139−listHoldWithKeyWithMove m0 m' f = do

140− (n0, n') <- mapMapWithAdjustWithMove f m0 $ ffor m' $ PatchMapWithMove . Map.map (\v -> NodeInfo (maybe From_Delete From_Insert v) Nothing)

141− incrementalToDynamic <$> holdIncremental n0 n'

142−-- -}

test/Reflex/Bench/Focused.hs+1−13

@@ -130,16 +130,6 @@ mapDynChain = iterM (return . fmap (+1))

130joinDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

131joinDynChain = iterM (\d -> return $ join $ fmap (const d) d)

132

133−holdDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

134−holdDynChain = iterM (\d -> sample (current d) >>= flip holdDyn (updated d))

135−

136−buildDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

137−buildDynChain = iterM (\d -> do

138− let b = fmap (+1) (current d)

139− e = fmap (*2) (updated d)

140− buildDynamic (sample b) e)

141−

142−

143combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

133combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

144combineDynChain = iterM (\d -> return $ zipDynWith (+) d d)

134combineDynChain = iterM (\d -> return $ zipDynWith (+) d d)

145

135

@@ -194,7 +184,7 @@ switchMergeBehaviors mapChanges = pull . joinMap <$> holdMap mapChanges

194

184

195-- | Turn an UpdatedMap into a Dynamic by applying the differences to the initial value

185-- | Turn an UpdatedMap into a Dynamic by applying the differences to the initial value

196holdMapDyn :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => UpdatedMap t k a -> m (Dynamic t (Map k a))

186holdMapDyn :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => UpdatedMap t k a -> m (Dynamic t (Map k a))

197−holdMapDyn (UpdatedMap initial changes) = foldDyn (flip (Map.foldrWithKey modify)) initial changes

187+holdMapDyn (UpdatedMap initial changes) = foldDyn (flip (Map.foldWithKey modify)) initial changes

198

188

199 where

189 where

200 modify k Nothing items = Map.delete k items

190 modify k Nothing items = Map.delete k items

@@ -318,8 +308,6 @@ dynamics :: Word -> [(String, TestCase)]

318dynamics n =

308dynamics n =

319 [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d

309 [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d

320 , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d

310 , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d

321− , testE "holdDynChain" $ fmap updated $ holdDynChain n =<< d

322− , testE "buildDynChain" $ fmap updated $ buildDynChain n =<< d

323 , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d

311 , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d

324 , testE "dense mergeTree" $ fmap (updated . mergeTreeDyn 8) dense

312 , testE "dense mergeTree" $ fmap (updated . mergeTreeDyn 8) dense

325 , testE "sparse mergeTree" $ fmap (updated . mergeTreeDyn 8) sparse

313 , testE "sparse mergeTree" $ fmap (updated . mergeTreeDyn 8) sparse

test/Reflex/Plan/Pure.hs+4−7

@@ -39,9 +39,6 @@ instance MonadHold (Pure Int) PurePlan where

39 hold initial = liftPlan . hold initial

40 holdDyn initial = liftPlan . holdDyn initial

41 holdIncremental initial = liftPlan . holdIncremental initial

42− buildDynamic getInitial = liftPlan . buildDynamic getInitial

43− headE = liftPlan . headE

44− now = liftPlan now

46instance MonadSample (Pure Int) PurePlan where

43instance MonadSample (Pure Int) PurePlan where

47 sample = liftPlan . sample

44 sample = liftPlan . sample

@@ -56,15 +53,15 @@ instance TestPlan (Pure Int) PurePlan where

56runPure :: PurePlan a -> (a, IntSet)

53runPure :: PurePlan a -> (a, IntSet)

57runPure (PurePlan p) = runStateT p mempty $ 0

54runPure (PurePlan p) = runStateT p mempty $ 0

59−relevantTimes :: IntSet -> IntSet

56+relavantTimes :: IntSet -> IntSet

60−relevantTimes occs = IntSet.fromList [0..l + 1]

57+relavantTimes occs = IntSet.fromList [0..l + 1]

61 where l = fromMaybe 0 (fst <$> IntSet.maxView occs)

58 where l = fromMaybe 0 (fst <$> IntSet.maxView occs)

63testBehavior :: (Behavior (Pure Int) a, IntSet) -> IntMap a

60testBehavior :: (Behavior (Pure Int) a, IntSet) -> IntMap a

64−testBehavior (b, occs) = IntMap.fromSet (sample b) (relevantTimes occs)

61+testBehavior (b, occs) = IntMap.fromSet (sample b) (relavantTimes occs)

66testEvent :: (Event (Pure Int) a, IntSet) -> IntMap (Maybe a)

63testEvent :: (Event (Pure Int) a, IntSet) -> IntMap (Maybe a)

67−testEvent (Event readEvent, occs) = IntMap.fromSet readEvent (relevantTimes occs)

64+testEvent (Event readEvent, occs) = IntMap.fromSet readEvent (relavantTimes occs)

test/Reflex/Plan/Reflex.hs+2−2

@@ -74,13 +74,13 @@ deriving instance ReflexHost t => MonadFix (Plan t)

76instance (ReflexHost t, MonadRef (HostFrame t), Ref (HostFrame t) ~ Ref IO) => TestPlan t (Plan t) where

77− plan occurrences = Plan $ do

77+ plan occurances = Plan $ do

78 (e, ref) <- newEventWithTriggerRef

79 modify (IntMap.unionWith mappend (firings ref))

80 return e

82 where

83− firings ref = IntMap.fromList (makeFiring ref <$> occurrences)

83+ firings ref = IntMap.fromList (makeFiring ref <$> occurances)

84 makeFiring ref (t, a) = (fromIntegral t, [Firing ref a])

test/Reflex/Test/CrossImpl.hs+35−58

@@ -4,14 +4,15 @@

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FunctionalDependencies #-}

6{-# LANGUAGE GADTs #-}

7+{-# LANGUAGE LambdaCase #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE NoMonomorphismRestriction #-}

9{-# LANGUAGE NoMonomorphismRestriction #-}

9{-# LANGUAGE RankNTypes #-}

10{-# LANGUAGE RankNTypes #-}

10−{-# LANGUAGE RecursiveDo #-}

11{-# LANGUAGE ScopedTypeVariables #-}

12{-# LANGUAGE TypeFamilies #-}

13{-# LANGUAGE TypeOperators #-}

14{-# LANGUAGE UndecidableInstances #-}

15+module Reflex.Test.CrossImpl (test) where

16import Prelude hiding (and, foldl, mapM, mapM_, sequence, sequence_)

17import Prelude hiding (and, foldl, mapM, mapM_, sequence, sequence_)

@@ -21,21 +22,22 @@ import Reflex.Dynamic

21import Reflex.Host.Class

22import Reflex.Host.Class

22import qualified Reflex.Pure as P

23import qualified Reflex.Pure as P

23import qualified Reflex.Spider.Internal as S

24import qualified Reflex.Spider.Internal as S

24−import qualified Reflex.Profiled as Prof

26import Control.Arrow (second, (&&&))

27import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

28import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

29−import Data.Dependent.Sum (DSum (..))

29+import Control.Monad.Writer hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

30+import Data.Dependent.Map (DSum (..))

30import Data.Foldable

31import Data.Foldable

31import Data.Map.Strict (Map)

32import Data.Map.Strict (Map)

32import qualified Data.Map.Strict as Map

33import qualified Data.Map.Strict as Map

33import qualified Data.Set as Set

34import qualified Data.Set as Set

34−import Data.Monoid

35import Data.Traversable

36import System.Exit

37import System.Mem

39+import System.IO.Unsafe

40+

39mapToPureBehavior :: Map Int a -> Behavior PureReflexDomain a

41mapToPureBehavior :: Map Int a -> Behavior PureReflexDomain a

40mapToPureBehavior m = P.Behavior $ \t -> case Map.lookupLE t m of

42mapToPureBehavior m = P.Behavior $ \t -> case Map.lookupLE t m of

41 Nothing -> error $ "mapToPureBehavior: no value for time " <> show t

43 Nothing -> error $ "mapToPureBehavior: no value for time " <> show t

@@ -72,14 +74,11 @@ instance MapMSignals (Event t a) (Event t' a) t t' where

72instance (MapMSignals a a' t t', MapMSignals b b' t t') => MapMSignals (a, b) (a', b') t t' where

74instance (MapMSignals a a' t t', MapMSignals b b' t t') => MapMSignals (a, b) (a', b') t t' where

73 mapMSignals fb fe (a, b) = liftM2 (,) (mapMSignals fb fe a) (mapMSignals fb fe b)

75 mapMSignals fb fe (a, b) = liftM2 (,) (mapMSignals fb fe a) (mapMSignals fb fe b)

75−testTimeline

77+testSpider :: (forall m t. TestCaseConstraint t m => (Behavior t a, Event t b) -> m (Behavior t c, Event t d)) -> (Map Int a, Map Int b) -> (Map Int c, Map Int d)

76− :: (forall m t. TestCaseConstraint t m => (Behavior t a, Event t b) -> m (Behavior t c, Event t d))

78+testSpider builder (bMap, eMap) = unsafePerformIO $ S.runSpiderHost $ do

77− -> (Map Int a, Map Int b)

78− -> (forall m t. (MonadReflexHost t m, MonadIO m, MonadRef m, Ref m ~ Ref IO, MonadSample t m) => m (Map Int c, Map Int d))

79−testTimeline builder (bMap, eMap) = do

80 (re, reTrigger) <- newEventWithTriggerRef

79 (re, reTrigger) <- newEventWithTriggerRef

81 (rb, rbTrigger) <- newEventWithTriggerRef

80 (rb, rbTrigger) <- newEventWithTriggerRef

82− b <- runHostFrame $ hold (error "testTimeline: No value for input behavior yet") rb

81+ b <- runHostFrame $ hold (error "testSpider: No value for input behavior yet") rb

83 (b', e') <- runHostFrame $ builder (b, re)

82 (b', e') <- runHostFrame $ builder (b, re)

84 e'Handle <- subscribeEvent e' --TODO: This should be unnecessary

83 e'Handle <- subscribeEvent e' --TODO: This should be unnecessary

85 let times = relevantTestingTimes (bMap, eMap)

84 let times = relevantTestingTimes (bMap, eMap)

@@ -104,19 +103,15 @@ testAgreement :: (Eq c, Eq d, Show c, Show d) => (forall m t. TestCaseConstraint

104testAgreement builder inputs = do

103testAgreement builder inputs = do

105 let identityResult = testPure builder inputs

104 let identityResult = testPure builder inputs

106 tracePerf "---------" $ return ()

105 tracePerf "---------" $ return ()

107− spiderResult <- S.runSpiderHost $ testTimeline builder inputs

106+ let spiderResult = testSpider builder inputs

108− tracePerf "---------" $ return ()

109− profiledResult <- S.runSpiderHost $ Prof.runProfiledM $ testTimeline builder inputs

110 tracePerf "---------" $ return ()

107 tracePerf "---------" $ return ()

111− let resultsAgree = identityResult == spiderResult && identityResult == profiledResult

108+ let resultsAgree = identityResult == spiderResult

112 if resultsAgree

109 if resultsAgree

113− then do --putStrLn "Success:"

110+ then do putStrLn "Success:"

114− --print identityResult

111+ print identityResult

115− return ()

116 else do putStrLn "Failure:"

112 else do putStrLn "Failure:"

117 putStrLn $ "Pure result: " <> show identityResult

113 putStrLn $ "Pure result: " <> show identityResult

118 putStrLn $ "Spider result: " <> show spiderResult

114 putStrLn $ "Spider result: " <> show spiderResult

119− putStrLn $ "Profiled result: " <> show profiledResult

120 return resultsAgree

115 return resultsAgree

121

116

122type TestCaseConstraint t m = (Reflex t, MonadSample t m, MonadHold t m, MonadFix m, MonadFix (PushM t))

117type TestCaseConstraint t m = (Reflex t, MonadSample t m, MonadHold t m, MonadFix m, MonadFix (PushM t))

@@ -132,8 +127,8 @@ testCases =

132 e' <- updated <$> count e

127 e' <- updated <$> count e

133 b' <- hold (0 :: Int) e'

128 b' <- hold (0 :: Int) e'

134 return (b', e')

129 return (b', e')

135− , (,) "headE-1" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

130+ , (,) "onceE-1" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

136− e' <- headE $ leftmost [e, e]

131+ e' <- onceE $ leftmost [e, e]

137 return (b, e')

132 return (b, e')

138 , (,) "switch-1" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

133 , (,) "switch-1" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

139 let e' = fmap (const e) e

134 let e' = fmap (const e) e

@@ -156,35 +151,35 @@ testCases =

156 let e' = leftmost [e, e]

151 let e' = leftmost [e, e]

157 e'' <- switch <$> hold e' (fmap (const e) e)

152 e'' <- switch <$> hold e' (fmap (const e) e)

158 return (b, e'')

153 return (b, e'')

159− , (,) "switchHoldPromptly-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

154+ , (,) "switchPromptly-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

160 let e' = fmap (const e) e

155 let e' = fmap (const e) e

161− e'' <- switchHoldPromptly never e'

156+ e'' <- switchPromptly never e'

162 return (b, e'')

157 return (b, e'')

163− , (,) "switchHoldPromptly-2" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

158+ , (,) "switchPromptly-2" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

164 let e' = fmap (const e) e

159 let e' = fmap (const e) e

165− e'' <- switchHoldPromptly never $ leftmost [e', e']

160+ e'' <- switchPromptly never $ leftmost [e', e']

166 return (b, e'')

161 return (b, e'')

167− , (,) "switchHoldPromptly-3" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

162+ , (,) "switchPromptly-3" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

168 let e' = leftmost [e, e]

163 let e' = leftmost [e, e]

169− e'' <- switchHoldPromptly never (fmap (const e) e')

164+ e'' <- switchPromptly never (fmap (const e) e')

170 return (b, e'')

165 return (b, e'')

171− , (,) "switchHoldPromptly-4" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do

166+ , (,) "switchPromptly-4" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do

172 let e' = leftmost [e, e]

167 let e' = leftmost [e, e]

173− e'' <- switchHoldPromptly never (fmap (const e') e)

168+ e'' <- switchPromptly never (fmap (const e') e)

174 return (b, e'')

169 return (b, e'')

175 , (,) "switch-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

170 , (,) "switch-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

176 let e' = leftmost [e, e]

171 let e' = leftmost [e, e]

177 e'' <- switch <$> hold never (fmap (const e') e)

172 e'' <- switch <$> hold never (fmap (const e') e)

178 return (b, e'')

173 return (b, e'')

179− , (,) "switchHoldPromptly-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

174+ , (,) "switchPromptly-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

180 let e' = flip push e $ \_ -> do

175 let e' = flip push e $ \_ -> do

181− Just <$> headE e

176+ Just <$> onceE e

182− e'' <- switchHoldPromptly never e'

177+ e'' <- switchPromptly never e'

183 return (b, e'')

178 return (b, e'')

184− , (,) "switchHoldPromptly-6" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

179+ , (,) "switchPromptly-6" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

185 let e' = flip pushAlways e $ \_ -> do

180 let e' = flip pushAlways e $ \_ -> do

186− switchHoldPromptly e never

181+ switchPromptly e never

187− e'' <- switchHoldPromptly never e'

182+ e'' <- switchPromptly never e'

188 return (b, e'')

183 return (b, e'')

189 , (,) "coincidence-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

184 , (,) "coincidence-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

190 let e' = flip pushAlways e $ \_ -> return e

185 let e' = flip pushAlways e $ \_ -> return e

@@ -199,7 +194,7 @@ testCases =

199 e'' = coincidence e'

194 e'' = coincidence e'

200 return (b, e'')

195 return (b, e'')

201 , (,) "coincidence-4" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do

196 , (,) "coincidence-4" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do

202− let e' = flip pushAlways e $ \_ -> headE e

197+ let e' = flip pushAlways e $ \_ -> onceE e

203 e'' = coincidence e'

198 e'' = coincidence e'

204 return (b, e'')

199 return (b, e'')

205 , (,) "coincidence-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer")]) $ \(b, e) -> do

200 , (,) "coincidence-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer")]) $ \(b, e) -> do

@@ -219,35 +214,17 @@ testCases =

219 eCoincidences = coincidence $ fmap (const e') e

214 eCoincidences = coincidence $ fmap (const e') e

220 return (b, eCoincidences)

215 return (b, eCoincidences)

221 , (,) "holdWhileFiring" $ TestCase (Map.singleton 0 "zxc", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

216 , (,) "holdWhileFiring" $ TestCase (Map.singleton 0 "zxc", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

222− eo <- headE e

217+ eo <- onceE e

223 bb <- hold b $ pushAlways (const $ hold "asdf" eo) eo

218 bb <- hold b $ pushAlways (const $ hold "asdf" eo) eo

224 let b' = pull $ sample =<< sample bb

219 let b' = pull $ sample =<< sample bb

225 return (b', e)

220 return (b', e)

226− , (,) "foldDynWhileFiring" $ TestCase (Map.singleton 0 "zxc", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(_, e) -> do

227− d <- foldDyn (:) [] $

228− pushAlways (\a -> foldDyn (:) [a] e) e

229− let b = current (join (fmap distributeListOverDynPure d))

230− return (b, e)

231 , (,) "joinDyn" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

221 , (,) "joinDyn" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

232 bb <- hold "b" e

222 bb <- hold "b" e

233− bd <- hold never . fmap (const e) =<< headE e

223+ bd <- hold never . fmap (const e) =<< onceE e

234− eOuter <- pushAlways sample . fmap (const bb) <$> headE e

224+ eOuter <- pushAlways sample . fmap (const bb) <$> onceE e

235 let eInner = switch bd

225 let eInner = switch bd

236 e' = leftmost [eOuter, eInner]

226 e' = leftmost [eOuter, eInner]

237 return (b, e')

227 return (b, e')

238− , (,) "holdUniqDyn-laziness" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList (zip [1 :: Int ..] [1 :: Int, 2, 2, 3, 3, 3, 4, 4, 4, 4])) $ \(_, e :: Event t Int) -> do

239− rec result <- holdUniqDyn d

240− d <- holdDyn (0 :: Int) e

241− return (current result, updated result)

242−

243−

244−

245− {-

246− , (,) "mergeIncrementalWithMove" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, PatchDMapWithMove.moveDMapKey LeftTag RightTag), (2, mempty)]) $ \(b, e :: Event t (PatchDMapWithMove (EitherTag () ()) (Const2 () ()))) -> do

247− x <- holdIncremental (DMap.singleton LeftTag $ void e) $ PatchDMapWithMove.mapPatchDMapWithMove (\(Const2 _) -> void e) <$> e

248− let e' = mergeIncrementalWithMove x :: Event t (DMap (EitherTag () ()) Identity)

249− return (b, e')

250− -}

251 ]

228 ]

252

229

253splitRecombineEvent :: Reflex t => Event t a -> Event t String

230splitRecombineEvent :: Reflex t => Event t a -> Event t String

@@ -257,8 +234,8 @@ splitRecombineEvent e =

257 in leftmost [ea, eb]

234 in leftmost [ea, eb]

258

235

259

236

260−main :: IO ()

237+test :: IO ()

261−main = do

238+test = do

262 results <- forM testCases $ \(name, TestCase inputs builder) -> do

239 results <- forM testCases $ \(name, TestCase inputs builder) -> do

263 putStrLn $ "Test: " <> name

240 putStrLn $ "Test: " <> name

264 testAgreement builder inputs

241 testAgreement builder inputs

test/Reflex/Test/Micro.hs+17−84

@@ -3,7 +3,6 @@

3{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE GADTs #-}

6−{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE RankNTypes #-}

7{-# LANGUAGE RankNTypes #-}

9{-# LANGUAGE RecursiveDo #-}

8{-# LANGUAGE RecursiveDo #-}

@@ -24,24 +23,6 @@ import Data.Monoid

25import Prelude

24import Prelude

27−pushDyn :: (Reflex t, MonadHold t m) => (a -> PushM t b) -> Dynamic t a -> m (Dynamic t b)

28−pushDyn f d = buildDynamic (sample (current d) >>= f) (pushAlways f (updated d))

29−

30−foldedDyn :: (Reflex t, MonadHold t m) => (a -> a -> a) -> Dynamic t a -> m (Dynamic t a)

31−foldedDyn f d = fmap join $ flip buildDynamic never $ do

32− a <- sample (current d)

33− foldDyn f a (updated d)

34−

35−scannedDyn :: (Reflex t, MonadHold t m) => Dynamic t a -> m (Dynamic t [a])

36−scannedDyn = fmap (fmap reverse) . foldedDyn (<>) . fmap pure

37−

38−scanInnerDyns :: (Reflex t, MonadHold t m) => Dynamic t (Dynamic t a) -> m (Dynamic t [a])

39−scanInnerDyns d = do

40− scans <- scannedDyn d

41− return (join (fmap distributeListOverDynPure scans))

42−

43−

44−

45{-# ANN testCases "HLint: ignore Functor law" #-}

26{-# ANN testCases "HLint: ignore Functor law" #-}

46testCases :: [(String, TestCase)]

27testCases :: [(String, TestCase)]

47testCases =

28testCases =

@@ -147,36 +128,36 @@ testCases =

147 return $ coincidence $ flip pushAlways e $ const $ do

128 return $ coincidence $ flip pushAlways e $ const $ do

148 switch <$> hold ("x" <$ e) (e <$ e)

129 switch <$> hold ("x" <$ e) (e <$ e)

149

130

150− , testE "switchHoldPromptly-1" $ do

131+ , testE "switchPromptly-1" $ do

151 e <- events1

132 e <- events1

152 let e' = e <$ e

133 let e' = e <$ e

153− switchHoldPromptly never $ e <$ e'

134+ switchPromptly never $ e <$ e'

154

135

155− , testE "switchHoldPromptly-2" $ do

136+ , testE "switchPromptly-2" $ do

156 e <- events1

137 e <- events1

157− switchHoldPromptly never $ deep (e <$ e)

138+ switchPromptly never $ deep (e <$ e)

158

139

159− , testE "switchHoldPromptly-3" $ do

140+ , testE "switchPromptly-3" $ do

160 e <- events1

141 e <- events1

161− switchHoldPromptly never $ (e <$ deep e)

142+ switchPromptly never $ (e <$ deep e)

162

143

163− , testE "switchHoldPromptly-4" $ do

144+ , testE "switchPromptly-4" $ do

164 e <- events1

145 e <- events1

165− switchHoldPromptly never $ (deep e <$ e)

146+ switchPromptly never $ (deep e <$ e)

166

147

167 , testE "switch-5" $ do

148 , testE "switch-5" $ do

168 e <- events1

149 e <- events1

169 switch <$> hold never (deep e <$ e)

150 switch <$> hold never (deep e <$ e)

170

151

171− , testE "switchHoldPromptly-5" $ do

152+ , testE "switchPromptly-5" $ do

172 e <- events1

153 e <- events1

173− switchHoldPromptly never $ flip push e $

154+ switchPromptly never $ flip push e $

174 const (Just <$> headE e)

155 const (Just <$> headE e)

175

156

176− , testE "switchHoldPromptly-6" $ do

157+ , testE "switchPromptly-6" $ do

177 e <- events1

158 e <- events1

178− switchHoldPromptly never $ flip pushAlways e $

159+ switchPromptly never $ flip pushAlways e $

179− const (switchHoldPromptly e never)

160+ const (switchPromptly e never)

180

161

181 , testE "coincidence-1" $ do

162 , testE "coincidence-1" $ do

182 e <- events1

163 e <- events1

@@ -220,14 +201,6 @@ testCases =

220 bb <- hold (constant "x") $ pushAlways (const $ hold "a" eo) eo

201 bb <- hold (constant "x") $ pushAlways (const $ hold "a" eo) eo

221 return $ pull $ sample =<< sample bb

202 return $ pull $ sample =<< sample bb

222

203

223−

224− , testB "foldDynWhileFiring" $ do

225− e <- events1

226− d <- foldDyn (:) [] $

227− pushAlways (\a -> foldDyn (:) [a] e) e

228−

229− return $ current (join (fmap distributeListOverDynPure d))

230−

231 , testE "joinDyn" $ do

204 , testE "joinDyn" $ do

232 e <- events1

205 e <- events1

233 bb <- hold "b" e

206 bb <- hold "b" e

@@ -250,38 +223,6 @@ testCases =

250 d2 <- fmap (fmap (map toUpper)) $ foldDyn (++) "0" =<< events2

223 d2 <- fmap (fmap (map toUpper)) $ foldDyn (++) "0" =<< events2

251

224

252 return $ current $ zipDynWith (<>) d1 d2

225 return $ current $ zipDynWith (<>) d1 d2

253−

254− , testB "buildDynamicStrictness" $ do

255− rec

256− d'' <- pushDyn return d'

257− d' <- pushDyn return d

258− d <- holdDyn "0" =<< events1

259−

260− _ <- sample (current d'')

261− return (current d'')

262−

263− , testB "factorDyn" $ do

264− d <- holdDyn (Left "a") =<< eithers

265−

266− eithers' <- eitherDyn d

267− let unFactor = either id id

268− return $ current (join (fmap unFactor eithers'))

269−

270− , testB "pushDynDeep" $ do

271− _ <- events1

272− _ <- events2

273−

274− d1 <- holdDyn "d1" =<< events1

275− d2 <- holdDyn "d2" =<< events2

276−

277− d <- flip pushDyn d1 $ \a ->

278− flip pushDyn d2 $ \b ->

279− flip pushDyn d1 $ \c ->

280− return (a <> b <> c)

281−

282− d' <- pushDyn scanInnerDyns d >>= scanInnerDyns

283− return $ current d'

284−

285 , testE "fan-1" $ do

226 , testE "fan-1" $ do

286 e <- fmap toMap <$> events1

227 e <- fmap toMap <$> events1

287 let es = select (fanMap e) . Const2 <$> values

228 let es = select (fanMap e) . Const2 <$> values

@@ -322,24 +263,14 @@ testCases =

322 let e = never <$ switch b

263 let e = never <$ switch b

323 return $ void e

264 return $ void e

324 lazyHold

265 lazyHold

325− , testE "now-1" $ do

266+

326− e1 <- events1

327− switchHoldPromptly never . pushAlways (\a -> fmap (a <$) now) $ e1

328− , testE "now-2" $ do

329− e1 <- events1

330− let e = pushAlways (\a -> if a == "a" then now else return never) e1

331− x <- accumDyn (<>) never e

332− return . coincidence $ updated x

333 ] where

267 ] where

334

268

335 events1, events2, events3 :: TestPlan t m => m (Event t String)

269 events1, events2, events3 :: TestPlan t m => m (Event t String)

336 events1 = plan [(1, "a"), (2, "b"), (5, "c"), (7, "d"), (8, "e")]

270 events1 = plan [(1, "a"), (2, "b"), (5, "c"), (7, "d"), (8, "e")]

337 events2 = plan [(1, "e"), (3, "d"), (4, "c"), (6, "b"), (7, "a")]

271 events2 = plan [(1, "e"), (3, "d"), (4, "c"), (6, "b"), (7, "a")]

338− events3 = liftA2 mappend events1 events2

339−

340− eithers :: TestPlan t m => m (Event t (Either String String))

341− eithers = plan [(1, Left "e"), (3, Left "d"), (4, Right "c"), (6, Right "b"), (7, Left "a")]

342

272

273+ events3 = liftA2 mappend events1 events2

343

274

344 values = "abcde"

275 values = "abcde"

345 toMap str = Map.fromList $ map (\c -> (c, c)) str

276 toMap str = Map.fromList $ map (\c -> (c, c)) str

@@ -350,3 +281,5 @@ testCases =

350

281

351 deep e = leftmost [e, e]

282 deep e = leftmost [e, e]

352 leftmost2 e1 e2 = leftmost [e1, e2]

283 leftmost2 e1 e2 = leftmost [e1, e2]

284+

285+

test/Reflex/TestPlan.hs+2−2

@@ -26,8 +26,8 @@ import Reflex.Class

26import Prelude

28class (Reflex t, MonadHold t m, MonadFix m) => TestPlan t m where

29− -- | Specify a plan of an input Event firing

29+ -- | Speicify a plan of an input Event firing

30− -- Occurrences must be in the future (i.e. Time > 0)

30+ -- Occurances must be in the future (i.e. Time > 0)

31 -- Initial specification is

33 plan :: [(Word, a)] -> m (Event t a)

test/RequesterT.hs+49−214

@@ -1,235 +1,70 @@

1−{-# LANGUAGE CPP #-}

1+{-# LANGUAGE FlexibleContexts, GADTs #-}

2−{-# LANGUAGE BangPatterns #-}

3−{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE FlexibleInstances #-}

5−{-# LANGUAGE GADTs #-}

6−{-# LANGUAGE LambdaCase #-}

7−{-# LANGUAGE MultiParamTypeClasses #-}

8−{-# LANGUAGE RecursiveDo #-}

9−{-# LANGUAGE ScopedTypeVariables #-}

10−{-# LANGUAGE TemplateHaskell #-}

11−{-# LANGUAGE TypeApplications #-}

12−{-# LANGUAGE TypeFamilies #-}

13module Main where

2module Main where

15−import Control.Lens hiding (has)

16import Control.Monad

4import Control.Monad

17−import Control.Monad.Fix

5+import Control.Monad.IO.Class

18−import Control.Monad.IO.Class (MonadIO)

6+import Control.Monad.Ref

19−import Data.Constraint.Extras

20−import Data.Constraint.Extras.TH

21−import Data.Constraint.Forall

22import qualified Data.Dependent.Map as DMap

7import qualified Data.Dependent.Map as DMap

23import Data.Dependent.Sum

8import Data.Dependent.Sum

24−import Data.Functor.Misc

9+import Data.IORef

25−import Data.List (words)

10+import Data.List

26−import Data.Map (Map)

11+import Data.Functor.Identity

27−import qualified Data.Map as M

28−#if !MIN_VERSION_these(4,11,0)

29−import Data.Semigroup ((<>))

30−#endif

31−import Data.Text (Text)

32−import Data.These

33−import Text.Read (readMaybe)

34−

35−#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0))

36−import Data.These.Lens

37−#endif

39import Reflex

13import Reflex

14+import Reflex.Host.Class

15+import Reflex.PerformEvent.Base

40import Reflex.Requester.Base

16import Reflex.Requester.Base

41import Reflex.Requester.Class

17import Reflex.Requester.Class

42−import Test.Run

18+

19+import System.Exit (exitFailure, exitSuccess)

44data RequestInt a where

21data RequestInt a where

45 RequestInt :: Int -> RequestInt Int

22 RequestInt :: Int -> RequestInt Int

47main :: IO ()

24main :: IO ()

48main = do

25main = do

49− os1 <- runApp' (unwrapApp testOrdering) $

26+ (Just out1, Nothing) <- runApp app1

50− [ Just ()

27+ print out1

51− ]

28+ (Just out2, Just (out3, out4)) <- runApp app2

52− print os1

29+ print out2

53− os2 <- runApp' (unwrapApp testSimultaneous) $ map Just $

30+ print out3

54− [ This ()

31+ print out4

55− , That ()

32+ when (sort out1 /= out1 || map (+1) out2 /= out3 || out3 /= out4) exitFailure

56− , This ()

33+

57− , These () ()

34+runApp :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global)

58− ]

35+ => (Event t () -> RequesterT t RequestInt Identity (PerformEventT t m) (Maybe (Ref m (Maybe (EventTrigger t ())))))

59− print os2

36+ -> IO (Maybe [Int], Maybe ([Int], [Int]))

60− os3 <- runApp' (unwrapApp testMoribundRequest) [Just ()]

37+runApp x = runSpiderHost $ do

61− print os3

38+ (pulseE, pulseTriggerRef) <- newEventWithTriggerRef

62− os4 <- runApp' (unwrapApp testMoribundRequestDMap) [Just ()]

39+ ((mactuateRef, e), FireCommand fire) <- hostPerformEventT $ runRequesterT (x pulseE) never

63− print os4

40+ hnd <- subscribeEvent (map unwrapRequest . DMap.toList <$> e)

64− os5 <- runApp' (unwrapApp testLiveRequestDMap) [Just ()]

41+ out1 <- fireEventRefAndRead pulseTriggerRef () hnd

65− print os5

42+ out2 <- fmap join $ forM mactuateRef $ \actuateRef -> do

66− os6 <- runApp' (unwrapApp delayedPulse) [Just ()]

43+ let readPhase = do

67− print os6

44+ mGetValue <- readEvent hnd

68− os7 <- runApp' testMatchRequestsWithResponses [ Just $ TestRequest_Increment 1 ]

45+ case mGetValue of

69− print os7

46+ Nothing -> return Nothing

70− os8 <- runApp' testMatchRequestsWithResponses [ Just $ TestRequest_Reverse "yoyo" ]

47+ Just getValue -> fmap Just getValue

71− print os8

48+ mactuate <- readRef actuateRef

72− let ![[Just [1,2,3,4,5,6,7,8,9,10]]] = os1 -- The order is reversed here: see the documentation for 'runRequesterT'

49+ mpulse <- readRef pulseTriggerRef

73− let ![[Just [9,7,5,3,1]],[Nothing,Nothing],[Just [10,8,6,4,2]],[Just [10,8,6,4,2],Nothing]] = os2

50+ forM ((,) <$> mactuate <*> mpulse) $ \(actuate, pulse) -> do

74− let ![[Nothing, Just [2]]] = os3

51+ _ <- fire [actuate :=> Identity ()] $ return ()

75− let ![[Nothing, Just [2]]] = os4

52+ [Just a] <- fire [pulse :=> Identity ()] $ readPhase

76− let ![[Nothing, Just [1, 2]]] = os5

53+ [Just b, Nothing] <- fire [actuate :=> Identity (), pulse :=> Identity ()] $ readPhase

77− -- let ![[Nothing, Nothing]] = os6 -- TODO re-enable this test after issue #233 has been resolved

54+ return (a,b)

78− let !(Just [(1,"2")]) = M.toList <$> head (head os7)

55+ return (out1, out2)

79− let !(Just [(1,"oyoy")]) = M.toList <$> head (head os8)

80−

81− return ()

83unwrapRequest :: DSum tag RequestInt -> Int

57unwrapRequest :: DSum tag RequestInt -> Int

84unwrapRequest (_ :=> RequestInt i) = i

58unwrapRequest (_ :=> RequestInt i) = i

86−unwrapApp :: ( Reflex t, Monad m )

60+app1 :: (Reflex t, Ref m ~ IORef, Requester t m, Response m ~ Identity, Request m ~ RequestInt) => Event t () -> m (Maybe (Ref m (Maybe (EventTrigger t ()))))

87− => (a -> RequesterT t RequestInt Identity m ())

61+app1 e = do

88− -> a

62+ forM_ [1..10] $ \i -> requestingIdentity (RequestInt i <$ e)

89− -> m (Event t [Int])

63+ return Nothing

90−unwrapApp x appIn = do

91− ((), e) <- runRequesterT (x appIn) never

92− return $ fmap (map unwrapRequest . requesterDataToList) e

93−

94−testOrdering :: ( Response m ~ Identity

95− , Request m ~ RequestInt

96− , Requester t m

97− , Adjustable t m)

98− => Event t ()

99− -> m ()

100−testOrdering pulse = forM_ [10,9..1] $ \i ->

101− requestingIdentity (RequestInt i <$ pulse)

102−

103−testSimultaneous :: ( Response m ~ Identity

104− , Request m ~ RequestInt

105− , Requester t m

106− , Adjustable t m)

107− => Event t (These () ())

108− -> m ()

109−testSimultaneous pulse = do

110− let tellE = fmapMaybe (^? here) pulse

111− switchE = fmapMaybe (^? there) pulse

112− forM_ [1,3..9] $ \i -> runWithReplace (requestingIdentity (RequestInt i <$ tellE)) $ ffor switchE $ \_ ->

113− requestingIdentity (RequestInt (i+1) <$ tellE)

114−

115−-- | Test that a widget requesting and event which fires at the same time it has been replaced

116−-- doesn't count along with the new widget.

117−testMoribundRequest

118− :: forall t m

119− . ( Reflex t

120− , Adjustable t m

121− , MonadHold t m

122− , MonadFix m

123− , Response m ~ Identity

124− , Request m ~ RequestInt

125− , Requester t m

126− )

127− => Event t ()

128− -> m ()

129−testMoribundRequest pulse = do

130− rec let requestIntOnReplace x = requestingIdentity $ RequestInt x <$ rwrFinished

131− (_, rwrFinished) <- runWithReplace (requestIntOnReplace 1) $ requestIntOnReplace 2 <$ pulse

132− return ()

133−

134−-- | The equivalent of 'testMoribundRequest' for 'traverseDMapWithKeyWithAdjust'.

135−testMoribundRequestDMap

136− :: forall t m

137− . ( Reflex t

138− , Adjustable t m

139− , MonadHold t m

140− , MonadFix m

141− , Response m ~ Identity

142− , Request m ~ RequestInt

143− , Requester t m

144− )

145− => Event t ()

146− -> m ()

147−testMoribundRequestDMap pulse = do

148− rec let requestIntOnReplace :: Int -> m ()

149− requestIntOnReplace x = void $ requestingIdentity $ RequestInt x <$ rwrFinished

150− (_, rwrFinished :: Event t (PatchDMap (Const2 () Int) Identity)) <-

151− traverseDMapWithKeyWithAdjust

152− (\(Const2 ()) (Identity v) -> Identity . const v <$> requestIntOnReplace v)

153− (mapToDMap $ M.singleton () 1)

154− ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton () 2) <$ pulse)

155− return ()

156−

157−-- | Ensures that elements which are _not_ removed can still fire requests

158−-- during the same frame as other elements are updated.

159−testLiveRequestDMap

160− :: forall t m

161− . ( Reflex t

162− , Adjustable t m

163− , MonadHold t m

164− , MonadFix m

165− , Response m ~ Identity

166− , Request m ~ RequestInt

167− , Requester t m

168− )

169− => Event t ()

170− -> m ()

171−testLiveRequestDMap pulse = do

172− rec let requestIntOnReplace :: Int -> m ()

173− requestIntOnReplace x = void $ requestingIdentity $ RequestInt x <$ rwrFinished

174− (_, rwrFinished :: Event t (PatchDMap (Const2 Int ()) Identity)) <-

175− traverseDMapWithKeyWithAdjust

176− (\(Const2 k) (Identity ()) -> Identity <$> requestIntOnReplace k)

177− (mapToDMap $ M.singleton 1 ())

178− ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton 2 ()) <$ pulse)

179− return ()

180−

181−delayedPulse

182− :: forall t m

183− . ( Reflex t

184− , Adjustable t m

185− , MonadHold t m

186− , MonadFix m

187− , Response m ~ Identity

188− , Request m ~ RequestInt

189− , PerformEvent t m

190− , Requester t m

191− )

192− => Event t ()

193− -> m ()

194−delayedPulse pulse = void $ flip runWithReplace (pure () <$ pulse) $ do

195− -- This has the effect of delaying pulse' from pulse

196− (_, pulse') <- runWithReplace (pure ()) $ pure (RequestInt 1) <$ pulse

197− requestingIdentity pulse'

198−

199−data TestRequest a where

200− TestRequest_Reverse :: String -> TestRequest String

201− TestRequest_Increment :: Int -> TestRequest Int

202−

203−testMatchRequestsWithResponses

204− :: forall m t req a

205− . ( MonadFix m

206− , MonadHold t m

207− , Reflex t

208− , PerformEvent t m

209− , MonadIO (Performable m)

210− , ForallF Show req

211− , Has Read req

212− )

213− => Event t (req a) -> m (Event t (Map Int String))

214−testMatchRequestsWithResponses pulse = mdo

215− (_, requests) <- runRequesterT (requesting pulse) responses

216− let rawResponses = M.map (\v ->

217− case words v of

218− ["reverse", str] -> reverse str

219− ["increment", i] -> show $ succ $ (read i :: Int)

220− ) <$> rawRequestMap

221− (rawRequestMap, responses) <- matchResponsesWithRequests reqEncoder requests (head . M.toList <$> rawResponses)

222− pure rawResponses

223− where

224− reqEncoder :: forall a. req a -> (String, String -> Maybe a)

225− reqEncoder r =

226− ( whichever @Show @req @a $ show r

227− , \x -> has @Read r $ readMaybe x

228− )

229

230−deriveArgDict ''TestRequest

65+app2 :: (Reflex t, Ref m ~ IORef, Requester t m, Response m ~ Identity, Request m ~ RequestInt, MonadAdjust t m, MonadReflexCreateTrigger t m, MonadRef m) => Event t () -> m (Maybe (Ref m (Maybe (EventTrigger t ()))))

66+app2 e = do

67+ (pulse, pulseTriggerRef) <- newEventWithTriggerRef

68+ forM_ [1,3..9] $ \i -> runWithReplace (requestingIdentity (RequestInt i <$ e)) $ ffor pulse $ \_ -> requestingIdentity (RequestInt (i+1) <$ e)

69+ return (Just pulseTriggerRef)

231

232−instance Show (TestRequest a) where

233− show = \case

234− TestRequest_Reverse str -> "reverse " <> str

235− TestRequest_Increment i -> "increment " <> show i

test/Test/Run.hsdeleted−74

@@ -1,74 +0,0 @@

1−{-# LANGUAGE GADTs #-}

2−{-# LANGUAGE LambdaCase #-}

3−module Test.Run where

4−

5−import Control.Monad

6−import Control.Monad.Ref

7−import Data.Dependent.Sum

8−import Data.Functor.Identity

9−import Data.These

10−

11−import Reflex

12−import Reflex.Host.Class

13−

14−data AppIn t b e = AppIn

15− { _appIn_behavior :: Behavior t b

16− , _appIn_event :: Event t e

17− }

18−

19−data AppOut t b e = AppOut

20− { _appOut_behavior :: Behavior t b

21− , _appOut_event :: Event t e

22− }

23−

24−runApp :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global)

25− => (AppIn t bIn eIn -> PerformEventT t m (AppOut t bOut eOut))

26− -> bIn

27− -> [Maybe (These bIn eIn)]

28− -> IO [[(bOut, Maybe eOut)]]

29−runApp app b0 input = runSpiderHost $ do

30− (appInHoldE, pulseHoldTriggerRef) <- newEventWithTriggerRef

31− (appInE, pulseEventTriggerRef) <- newEventWithTriggerRef

32− appInB <- hold b0 appInHoldE

33− (out, FireCommand fire) <- hostPerformEventT $ app $ AppIn

34− { _appIn_event = appInE

35− , _appIn_behavior = appInB

36− }

37− hnd <- subscribeEvent (_appOut_event out)

38− mpulseB <- readRef pulseHoldTriggerRef

39− mpulseE <- readRef pulseEventTriggerRef

40− let readPhase = do

41− b <- sample (_appOut_behavior out)

42− frames <- sequence =<< readEvent hnd

43− return (b, frames)

44− forM input $ \case

45− Nothing ->

46− fire [] $ readPhase

47− Just i -> case i of

48− This b' -> case mpulseB of

49− Nothing -> error "tried to fire in-behavior but ref was empty"

50− Just pulseB -> fire [ pulseB :=> Identity b' ] $ readPhase

51− That e' -> case mpulseE of

52− Nothing -> error "tried to fire in-event but ref was empty"

53− Just pulseE -> fire [ pulseE :=> Identity e' ] $ readPhase

54− These b' e' -> case mpulseB of

55− Nothing -> error "tried to fire in-behavior but ref was empty"

56− Just pulseB -> case mpulseE of

57− Nothing -> error "tried to fire in-event but ref was empty"

58− Just pulseE -> fire [ pulseB :=> Identity b', pulseE :=> Identity e' ] $ readPhase

59−

60−runApp' :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global)

61− => (Event t eIn -> PerformEventT t m (Event t eOut))

62− -> [Maybe eIn]

63− -> IO [[Maybe eOut]]

64−runApp' app input = do

65− let app' = fmap (AppOut (pure ())) . app

66− map (map snd) <$> runApp (app' . _appIn_event) () (map (fmap That) input)

67−

68−runAppB :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global)

69− => (Event t eIn -> PerformEventT t m (Behavior t bOut))

70− -> [Maybe eIn]

71− -> IO [[bOut]]

72−runAppB app input = do

73− let app' = fmap (flip AppOut never) . app

74− map (map fst) <$> runApp (app' . _appIn_event) () (map (fmap That) input)

test/hlint.hs+14−34

@@ -1,39 +1,19 @@

1−module Main where

1+import Language.Haskell.HLint3 (hlint)

2−

3−import Control.Monad

4−import Language.Haskell.HLint (hlint)

5−import System.Directory

6import System.Exit (exitFailure, exitSuccess)

2import System.Exit (exitFailure, exitSuccess)

7−import System.FilePath

8−import System.FilePath.Find

10main :: IO ()

4main :: IO ()

11main = do

5main = do

12− pwd <- getCurrentDirectory

6+ ideas <- hlint

13− let runHlint f = hlint $ f:

7+ [ "."

14− [ "--ignore=Redundant do"

8+ , "--ignore=Redundant do"

15− , "--ignore=Use camelCase"

9+ , "--ignore=Use camelCase"

16− , "--ignore=Redundant $"

10+ , "--ignore=Redundant $"

17− , "--ignore=Use &&"

11+ , "--ignore=Use &&"

18− , "--ignore=Use &&&"

12+ , "--ignore=Use &&&"

19− , "--ignore=Use const"

13+ , "--ignore=Use const"

20− , "--ignore=Use >=>"

14+ , "--ignore=Use >=>"

21− , "--ignore=Use ."

15+ , "--ignore=Use ."

22− , "--ignore=Use unless"

16+ , "--ignore=Use unless"

23− , "--ignore=Reduce duplication"

17+ , "--cpp-define=USE_TEMPLATE_HASKELL"

24− , "--cpp-define=USE_TEMPLATE_HASKELL"

18+ ]

25− , "--cpp-define=DEBUG"

26− , "--ignore=Use tuple-section"

27− ]

28− recurseInto = and <$> sequence

29− [ fileType ==? Directory

30− , fileName /=? ".git"

31− ]

32− matchFile = and <$> sequence

33− [ extension ==? ".hs"

34− ]

35− files <- find recurseInto matchFile (pwd </> "src") --TODO: Someday fix all hints in tests, etc.

36− ideas <- fmap concat $ forM files $ \f -> do

37− putStr $ "linting file " ++ drop (length pwd + 1) f ++ "... "

38− runHlint f

39 if null ideas then exitSuccess else exitFailure

19 if null ideas then exitSuccess else exitFailure

test/rootCleanup.hs+3−3

@@ -1,10 +1,10 @@

1−import Control.Concurrent

2import Control.Monad

1import Control.Monad

3−import Data.IORef

2+import Control.Concurrent

4import Reflex

3import Reflex

5import Reflex.Host.Class

4import Reflex.Host.Class

6−import System.Exit

7import System.Mem

5import System.Mem

6+import Data.IORef

7+import System.Exit

9main :: IO ()

10main = do

test/semantics.hs+2

@@ -45,3 +45,5 @@ main = do

45 ]

47 makeGroup name tests = first (\test -> intercalate "/" [name, test]) <$> tests

48+

49+