develop..011edf2 · reflex

git.iko.soy/reflex

on 011edf2 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: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.;

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+75−303

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

47− manual: True

48−

49−flag fast-weak

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

51 default: False

33 default: False

52 manual: True

34 manual: True

54−flag debug-propagation

36+flag debug-trace-events

55− description: Enable debugging of spider internals

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!

56 default: False

38 default: False

57 manual: True

39 manual: True

59−flag debug-cycles

41+flag experimental-dependent-sum-instances

60− description: Enable debugging of event cycles

42+ description: Use experimental incoherent instances for certain forked dependent-sum typeclasses

61 default: False

43 default: False

62 manual: True

44 manual: True

64−flag split-these

65− description: Use split these/semialign packages

66− manual: False

67− default: True

68−

69library

46library

70− default-language: Haskell2010

71 hs-source-dirs: src

47 hs-source-dirs: src

72 build-depends:

48 build-depends:

73 MemoTrie == 0.6.*,

49 MemoTrie == 0.6.*,

74− base >= 4.11 && < 4.15,

50+ base >= 4.7 && < 4.11,

75− bifunctors >= 5.2 && < 5.6,

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

52+ containers == 0.5.*,

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

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

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

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

82 exception-transformers == 0.4.*,

55 exception-transformers == 0.4.*,

83 lens >= 4.7 && < 5,

56 lens >= 4.7 && < 5,

84− mmorph >= 1.0 && < 1.2,

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

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

86 mtl >= 2.1 && < 2.3,

58 mtl >= 2.1 && < 2.3,

87− patch >= 0.0.1 && < 0.1,

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

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

89− primitive >= 0.5 && < 0.8,

60+ primitive >= 0.5 && < 0.7,

90− profunctors >= 5.3 && < 5.7,

91− random == 1.1.*,

92 ref-tf == 0.4.*,

61 ref-tf == 0.4.*,

93 reflection == 2.1.*,

62 reflection == 2.1.*,

94 semigroupoids >= 4.0 && < 6,

63 semigroupoids >= 4.0 && < 6,

64+ semigroups >= 0.16 && < 0.19,

95− stm >= 2.4 && < 2.6,

65+ stm == 2.4.*,

96− syb >= 0.5 && < 0.8,

66+ syb >= 0.5 && < 0.7,

97− time >= 1.4 && < 1.10,

67+ these >= 0.4 && < 0.8,

98− transformers >= 0.5.6.0 && < 0.6,

68+ transformers >= 0.2,

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

69+ 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:

71 exposed-modules:

111− Control.Monad.ReaderIO

112 Data.AppendMap,

72 Data.AppendMap,

113− Data.FastMutableIntMap,

73+ Data.Functor.Misc,

114− Data.FastWeakBag,

115− Data.Map.Misc,

116 Data.WeakBag,

74 Data.WeakBag,

117 Reflex,

75 Reflex,

118 Reflex.Class,

76 Reflex.Class,

119− Reflex.Adjustable.Class,

77+ Reflex.EventWriter,

120− Reflex.BehaviorWriter.Base,

121− Reflex.BehaviorWriter.Class,

122− Reflex.Collection,

123 Reflex.Dynamic,

78 Reflex.Dynamic,

124 Reflex.Dynamic.Uniq,

79 Reflex.Dynamic.Uniq,

125 Reflex.DynamicWriter,

80 Reflex.DynamicWriter,

126− Reflex.DynamicWriter.Base,

127− Reflex.DynamicWriter.Class,

128− Reflex.EventWriter,

129− Reflex.EventWriter.Base,

130− Reflex.EventWriter.Class,

131 Reflex.FastWeak,

81 Reflex.FastWeak,

132 Reflex.FunctorMaybe,

82 Reflex.FunctorMaybe,

133 Reflex.Host.Class,

83 Reflex.Host.Class,

134− Reflex.Host.Headless,

84+ Reflex.Patch,

135− Reflex.Network,

85+ Reflex.Patch.Class,

86+ Reflex.Patch.DMap,

87+ Reflex.Patch.DMapWithMove,

88+ Reflex.Patch.Map,

89+ Reflex.Patch.MapWithMove,

90+ Reflex.TriggerEvent.Base,

136− Reflex.NotReady.Class,

91+ Reflex.TriggerEvent.Class,

137 Reflex.PerformEvent.Base,

92 Reflex.PerformEvent.Base,

138 Reflex.PerformEvent.Class,

93 Reflex.PerformEvent.Class,

139 Reflex.PostBuild.Base,

94 Reflex.PostBuild.Base,

140 Reflex.PostBuild.Class,

95 Reflex.PostBuild.Class,

141− Reflex.Profiled,

142− Reflex.Pure,

143 Reflex.Query.Base,

96 Reflex.Query.Base,

144 Reflex.Query.Class,

97 Reflex.Query.Class,

145 Reflex.Requester.Base,

98 Reflex.Requester.Base,

146 Reflex.Requester.Class,

99 Reflex.Requester.Class,

147 Reflex.Spider,

100 Reflex.Spider,

148− Reflex.Spider.Internal,

101+ Reflex.Spider.Internal

149− Reflex.Time,

150− Reflex.TriggerEvent.Base,

151− Reflex.TriggerEvent.Class,

152− Reflex.Widget.Basic,

153− Reflex.Workflow

154

102

155− reexported-modules:

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

156− patch:Data.Functor.Misc,

104+ 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

105

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

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

107+ cpp-options: -DSPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

108+ else

109+ exposed-modules: Reflex.Pure

166

110

167 if flag(debug-trace-events)

111 if flag(debug-trace-events)

168 cpp-options: -DDEBUG_TRACE_EVENTS

112 cpp-options: -DDEBUG_TRACE_EVENTS

169− build-depends:

113+ build-depends: bytestring

170− bytestring >= 0.10.8 && < 0.11

171

114

172 if flag(use-reflex-optimizer)

115 if flag(use-reflex-optimizer)

173 cpp-options: -DUSE_REFLEX_OPTIMIZER

116 cpp-options: -DUSE_REFLEX_OPTIMIZER

174 build-depends: ghc

117 build-depends: ghc

175 exposed-modules: Reflex.Optimizer

118 exposed-modules: Reflex.Optimizer

176

119

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)

120 if flag(use-template-haskell)

184 cpp-options: -DUSE_TEMPLATE_HASKELL

121 cpp-options: -DUSE_TEMPLATE_HASKELL

185 build-depends:

122 build-depends:

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

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

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

124+ haskell-src-exts >= 1.16 && < 1.19,

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

125+ haskell-src-meta >= 0.6 && < 0.8,

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

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

190 exposed-modules:

127 exposed-modules:

191 Reflex.Dynamic.TH

128 Reflex.Dynamic.TH

192 other-extensions: TemplateHaskell

129 other-extensions: TemplateHaskell

193 else

130 else

194 build-depends:

131 build-depends:

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

132+ dependent-sum == 0.4.*

133+

134+ if flag(expose-all-unfoldings)

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

196

136

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

137+ if flag(experimental-dependent-sum-instances)

198− cpp-options: -DGHCJS_FAST_WEAK

138+ ghc-options: -DEXPERIMENTAL_DEPENDENT_SUM_INSTANCES

199

139

200 if impl(ghcjs)

140 if impl(ghcjs)

201− build-depends:

141+ build-depends: ghcjs-base

202− ghcjs-base == 0.2.*

203

142

204test-suite semantics

143test-suite semantics

205− default-language: Haskell2010

206 type: exitcode-stdio-1.0

144 type: exitcode-stdio-1.0

207 main-is: semantics.hs

145 main-is: semantics.hs

208 hs-source-dirs: test

146 hs-source-dirs: test

@@ -211,273 +149,111 @@ test-suite semantics

211 base,

149 base,

212 bifunctors,

150 bifunctors,

213 containers,

151 containers,

214− deepseq,

152+ deepseq >= 1.3 && < 1.5,

215 dependent-map,

153 dependent-map,

216 dependent-sum,

154 dependent-sum,

217 mtl,

155 mtl,

218 ref-tf,

156 ref-tf,

219 reflex,

157 reflex,

220 split,

158 split,

221− transformers

159+ transformers >= 0.3

222− other-modules:

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

223− Reflex.Bench.Focused

161+ buildable: False

224− Reflex.Plan.Pure

225− Reflex.Plan.Reflex

226− Reflex.Test

227− Reflex.Test.Micro

228− Reflex.TestPlan

229

162

230test-suite CrossImpl

163test-suite CrossImpl

231− default-language: Haskell2010

232 type: exitcode-stdio-1.0

164 type: exitcode-stdio-1.0

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

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

234 hs-source-dirs: test

166 hs-source-dirs: test

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

167+ ghc-options: -O2 -Wall -rtsopts -main-is Reflex.Test.CrossImpl.test

236 build-depends:

168 build-depends:

237 base,

169 base,

238 containers,

170 containers,

239 dependent-map,

171 dependent-map,

240− dependent-sum,

241− deepseq,

242 mtl,

172 mtl,

243− transformers,

244 ref-tf,

173 ref-tf,

245 reflex

174 reflex

246− other-modules:

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

247− Reflex.Test

176+ buildable: False

248− Reflex.TestPlan

249− Reflex.Plan.Reflex

250− Reflex.Plan.Pure

251

177

252test-suite hlint

178test-suite hlint

253− default-language: Haskell2010

254 type: exitcode-stdio-1.0

179 type: exitcode-stdio-1.0

255 main-is: hlint.hs

180 main-is: hlint.hs

256 hs-source-dirs: test

181 hs-source-dirs: test

257− build-depends: base

182+ 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)

183 if impl(ghcjs)

266 buildable: False

184 buildable: False

267

185

268test-suite EventWriterT

186test-suite EventWriterT

269− default-language: Haskell2010

270 type: exitcode-stdio-1.0

187 type: exitcode-stdio-1.0

271 main-is: EventWriterT.hs

188 main-is: EventWriterT.hs

272 hs-source-dirs: test

189 hs-source-dirs: test

273 build-depends: base

190 build-depends: base

274− , containers

275− , deepseq

276− , dependent-map

277 , dependent-sum

191 , dependent-sum

278− , lens

279− , mtl

280− , these

281 , transformers

192 , transformers

282 , reflex

193 , reflex

283 , ref-tf

194 , ref-tf

284

195

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

196test-suite RequesterT

322− default-language: Haskell2010

323 type: exitcode-stdio-1.0

197 type: exitcode-stdio-1.0

324 main-is: RequesterT.hs

198 main-is: RequesterT.hs

325 hs-source-dirs: test

199 hs-source-dirs: test

326 build-depends: base

200 build-depends: base

327− , constraints

328− , constraints-extras

329− , containers

330− , deepseq

331− , dependent-map

332 , dependent-sum

201 , dependent-sum

333− , lens

202+ , dependent-map

334− , mtl

335− , ref-tf

336− , reflex

337− , text

338− , these

339 , transformers

203 , 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

204 , reflex

366 , ref-tf

205 , 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

206

400test-suite GC-Semantics

207test-suite GC-Semantics

401− default-language: Haskell2010

402 type: exitcode-stdio-1.0

208 type: exitcode-stdio-1.0

403 main-is: GC.hs

209 main-is: GC.hs

404 hs-source-dirs: test

210 hs-source-dirs: test

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

212+ buildable: False

405 build-depends: base

213 build-depends: base

406− , containers

407 , dependent-sum

214 , dependent-sum

408 , dependent-map

215 , dependent-map

409− , deepseq

410− , mtl

411− , patch

412 , these

216 , these

413 , transformers

217 , transformers

414 , reflex

218 , reflex

415 , ref-tf

219 , ref-tf

416

220

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

221test-suite rootCleanup

427− default-language: Haskell2010

428 type: exitcode-stdio-1.0

222 type: exitcode-stdio-1.0

429 main-is: rootCleanup.hs

223 main-is: rootCleanup.hs

430 hs-source-dirs: test

224 hs-source-dirs: test

431 build-depends: base

225 build-depends: base

432− , containers

433− , deepseq

434− , dependent-sum

435− , mtl

436 , reflex

226 , reflex

437− , ref-tf

438− , these

439− other-modules:

440− Reflex.Plan.Pure

441− Reflex.TestPlan

442− Test.Run

443

227

444benchmark spider-bench

228benchmark spider-bench

445− default-language: Haskell2010

446 type: exitcode-stdio-1.0

229 type: exitcode-stdio-1.0

447− hs-source-dirs: bench test

230+ hs-source-dirs: bench

448 main-is: Main.hs

231 main-is: Main.hs

449 ghc-options: -Wall -O2 -rtsopts

232 ghc-options: -Wall -O2 -rtsopts

450 build-depends:

233 build-depends:

451 base,

234 base,

452− containers,

453− criterion,

235+ criterion == 1.1.*,

454− deepseq,

236+ deepseq >= 1.3 && < 1.5,

455 dependent-map,

237 dependent-map,

456 dependent-sum,

238 dependent-sum,

457− ref-tf,

458 mtl,

239 mtl,

459 primitive,

240 primitive,

460 reflex,

241 reflex,

461− split,

462 stm,

242 stm,

463− transformers

243+ transformers >= 0.3

464− other-modules:

465− Reflex.TestPlan

466− Reflex.Plan.Reflex

467− Reflex.Bench.Focused

468

244

469benchmark saulzar-bench

245benchmark saulzar-bench

470− default-language: Haskell2010

471 type: exitcode-stdio-1.0

246 type: exitcode-stdio-1.0

472 hs-source-dirs: bench test

247 hs-source-dirs: bench test

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

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

474 main-is: RunAll.hs

249 main-is: RunAll.hs

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

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

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

476 build-depends:

252 build-depends:

477 base,

253 base,

478− containers,

254+ containers == 0.5.*,

479− criterion,

255+ criterion == 1.1.*,

480− deepseq,

256+ deepseq >= 1.3 && < 1.5,

481 dependent-map,

257 dependent-map,

482 dependent-sum,

258 dependent-sum,

483 loch-th,

259 loch-th,

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

489 split,

265 split,

490 stm,

266 stm,

491 time,

267 time,

492− transformers

268+ transformers >= 0.3

493− other-modules:

494− Reflex.TestPlan

495− Reflex.Plan.Reflex

496− Reflex.Bench.Focused

497

269

498source-repository head

270source-repository head

499 type: git

271 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.hs+384−59

@@ -1,84 +1,409 @@

1−{-# LANGUAGE CPP #-}

1+{-# LANGUAGE DeriveFunctor #-}

2+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE DeriveTraversable #-}

2{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

5−{-# LANGUAGE PatternSynonyms #-}

6{-# LANGUAGE RoleAnnotations #-}

8{-# LANGUAGE RoleAnnotations #-}

7{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10+{-# LANGUAGE TypeApplications #-}

8{-# LANGUAGE TypeFamilies #-}

11{-# LANGUAGE TypeFamilies #-}

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

12+-- | 'Data.Map' with a better 'Monoid' instance

10−-- |

13+--

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'

14+-- 'Data.Map' has @mappend = union@, which is left-biased. AppendMap has

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

15+-- @mappend = unionWith mappend@ instead.

18−module Data.AppendMap

16+module Data.AppendMap where

19− ( module Data.AppendMap

20− , module Data.Map.Monoidal

21− ) where

22−

23−import Prelude hiding (null)

18+import Prelude hiding (map)

19+

20+import Control.Lens

21+import Data.Align

25import Data.Coerce

22import Data.Coerce

26import Data.Default

23import Data.Default

27import Data.Map (Map)

24import Data.Map (Map)

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

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

25+import qualified Data.Map as Map

30−#else

26+import Data.Semigroup

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

27+import Data.Set (Set)

32−#endif

33−import qualified Data.Witherable as W

28+import Data.Typeable

34−import Data.Map.Monoidal

29+import GHC.Generics (Generic)

35−import qualified Data.Map.Monoidal as MonoidalMap

30+import Reflex (FunctorMaybe (..))

36−

31+import Reflex.Patch (Additive, Group (..))

37−

32+

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

33+newtype AppendMap k m = AppendMap { _unAppendMap :: Map k m }

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

34+ deriving (Eq, Ord, Show, Read, Typeable, Generic, Functor, Foldable, Traversable, Align)

40−type AppendMap = MonoidalMap

35+

41−

36+type instance (Index (AppendMap k m)) = k

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

37+type instance (IxValue (AppendMap k m)) = m

43−-- | A synonym for 'getMonoidalMap'

38+

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

39+instance Ord k => Ixed (AppendMap k m) where

45−_unAppendMap = getMonoidalMap

40+ ix i = _Wrapped . ix i

46−

41+

47−-- | Pattern synonym for 'MonoidalMap'

42+instance Ord k => At (AppendMap k m) where

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

43+ at i = _Wrapped . at i

49−pattern AppendMap m = MonoidalMap m

44+

50−

45+instance FunctorMaybe (AppendMap k) where

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

46+ fmapMaybe = mapMaybe

52−instance W.Filterable (MonoidalMap k) where

53− mapMaybe = MonoidalMap.mapMaybe

54−#endif

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

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

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

49+nonEmptyDelete :: Ord k => k -> AppendMap k a -> Maybe (AppendMap k a)

58nonEmptyDelete k vs =

50nonEmptyDelete k vs =

59 let deleted = delete k vs

51 let deleted = delete k vs

60− in if null deleted

52+ in if Data.AppendMap.null deleted

61 then Nothing

53 then Nothing

62 else Just deleted

54 else Just deleted

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

65mapMaybeNoNull :: (a -> Maybe b)

56mapMaybeNoNull :: (a -> Maybe b)

66− -> MonoidalMap token a

57+ -> AppendMap token a

67− -> Maybe (MonoidalMap token b)

58+ -> Maybe (AppendMap token b)

68mapMaybeNoNull f as =

59mapMaybeNoNull f as =

69− let bs = mapMaybe f as

60+ let bs = fmapMaybe f as

70− in if null bs

61+ in if Data.AppendMap.null bs

71 then Nothing

62 then Nothing

72 else Just bs

63 else Just bs

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

65+instance FunctorWithIndex k (AppendMap k) where

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

66+ imap f = AppendMap . imap f . _unAppendMap

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

67+ imapped = _Wrapped . imapped

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

68+

69+instance FoldableWithIndex k (AppendMap k) where

70+ ifolded = _Wrapped . ifolded

71+

72+instance TraversableWithIndex k (AppendMap k) where

73+ itraverse = itraverseOf itraversed

74+ itraversed = _Wrapped . itraversed

75+

76+instance (Ord k, Semigroup m) => Semigroup (AppendMap k m) where

77+ (AppendMap m0) <> (AppendMap m1) = AppendMap $ Map.unionWith (<>) m0 m1

78+

79+instance (Ord k, Semigroup m) => Monoid (AppendMap k m) where

80+ mempty = empty

81+ mappend = (<>)

82+

83+instance (Ord k, Group q) => Group (AppendMap k q) where

84+ negateG = map negateG

85+

86+instance (Ord k, Additive q) => Additive (AppendMap k q)

87+

88+(!) :: forall k a. Ord k => AppendMap k a -> k -> a

89+(!) = coerce ((Map.!) @k @a)

90+infixl 9 !

91+

92+(\\) :: forall k a b. Ord k => AppendMap k a -> AppendMap k b -> AppendMap k a

93+(\\) = coerce ((Map.\\) @k @a @b)

94+infixl 9 \\

95+

96+null :: forall k a. AppendMap k a -> Bool

97+null = coerce (Map.null @k @a)

98+

99+size :: forall k a. AppendMap k a -> Int

100+size = coerce (Map.size @k @a)

101+

102+member :: forall k a. Ord k => k -> AppendMap k a -> Bool

103+member = coerce (Map.member @k @a)

104+

105+notMember :: forall k a. Ord k => k -> AppendMap k a -> Bool

106+notMember = coerce (Map.notMember @k @a)

107+

108+lookup :: forall k a. Ord k => k -> AppendMap k a -> Maybe a

109+lookup = coerce (Map.lookup @k @a)

110+

111+findWithDefault :: forall k a. Ord k => a -> k -> AppendMap k a -> a

112+findWithDefault = coerce (Map.findWithDefault @k @a)

113+

114+lookupLT :: forall k a. Ord k => k -> AppendMap k a -> Maybe (k, a)

115+lookupLT = coerce (Map.lookupLT @k @a)

116+

117+lookupGT :: forall k a. Ord k => k -> AppendMap k a -> Maybe (k, a)

118+lookupGT = coerce (Map.lookupGT @k @a)

119+

120+lookupLE :: forall k a. Ord k => k -> AppendMap k a -> Maybe (k, a)

121+lookupLE = coerce (Map.lookupLE @k @a)

122+

123+lookupGE :: forall k a. Ord k => k -> AppendMap k a -> Maybe (k, a)

124+lookupGE = coerce (Map.lookupGE @k @a)

125+

126+empty :: forall k a. AppendMap k a

127+empty = coerce (Map.empty @k @a)

128+

129+singleton :: forall k a. k -> a -> AppendMap k a

130+singleton = coerce (Map.singleton @k @a)

131+

132+insert :: forall k a. Ord k => k -> a -> AppendMap k a -> AppendMap k a

133+insert = coerce (Map.insert @k @a)

134+

135+insertWith :: Ord k => (a -> a -> a) -> k -> a -> AppendMap k a -> AppendMap k a

136+insertWith f = coerce (Map.insertWith f)

137+

138+insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> AppendMap k a -> AppendMap k a

139+insertWithKey f = coerce (Map.insertWithKey f)

140+

141+insertLookupWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> AppendMap k a -> (Maybe a, AppendMap k a)

142+insertLookupWithKey f = coerce (Map.insertLookupWithKey f)

143+

144+delete :: forall k a. Ord k => k -> AppendMap k a -> AppendMap k a

145+delete = coerce (Map.delete @k @a)

146+

147+adjust :: Ord k => (a -> a) -> k -> AppendMap k a -> AppendMap k a

148+adjust f = coerce (Map.adjust f)

149+

150+adjustWithKey :: Ord k => (k -> a -> a) -> k -> AppendMap k a -> AppendMap k a

151+adjustWithKey f = coerce (Map.adjustWithKey f)

152+

153+update :: Ord k => (a -> Maybe a) -> k -> AppendMap k a -> AppendMap k a

154+update f = coerce (Map.update f)

155+

156+updateWithKey :: Ord k => (k -> a -> Maybe a) -> k -> AppendMap k a -> AppendMap k a

157+updateWithKey f = coerce (Map.updateWithKey f)

158+

159+updateLookupWithKey :: Ord k => (k -> a -> Maybe a) -> k -> AppendMap k a -> (Maybe a, AppendMap k a)

160+updateLookupWithKey f = coerce (Map.updateLookupWithKey f)

161+

162+alter :: Ord k => (Maybe a -> Maybe a) -> k -> AppendMap k a -> AppendMap k a

163+alter f = coerce (Map.alter f)

164+

165+unionWith :: Ord k => (a -> a -> a) -> AppendMap k a -> AppendMap k a -> AppendMap k a

166+unionWith f = coerce (Map.unionWith f)

167+

168+unionWithKey :: Ord k => (k -> a -> a -> a) -> AppendMap k a -> AppendMap k a -> AppendMap k a

169+unionWithKey f = coerce (Map.unionWithKey f)

170+

171+unionsWith :: Ord k => (a -> a -> a) -> [AppendMap k a] -> AppendMap k a

172+unionsWith f = coerce (Map.unionsWith f)

173+

174+difference :: Ord k => AppendMap k a -> AppendMap k b -> AppendMap k a

175+difference = (\\)

176+

177+differenceWith :: Ord k => (a -> b -> Maybe a) -> AppendMap k a -> AppendMap k b -> AppendMap k a

178+differenceWith f = coerce (Map.differenceWith f)

179+

180+differenceWithKey :: Ord k => (k -> a -> b -> Maybe a) -> AppendMap k a -> AppendMap k b -> AppendMap k a

181+differenceWithKey f = coerce (Map.differenceWithKey f)

182+

183+intersectionWith :: Ord k => (a -> b -> c) -> AppendMap k a -> AppendMap k b -> AppendMap k c

184+intersectionWith f = coerce (Map.intersectionWith f)

185+

186+intersectionWithKey :: Ord k => (k -> a -> b -> c) -> AppendMap k a -> AppendMap k b -> AppendMap k c

187+intersectionWithKey f = coerce (Map.intersectionWithKey f)

188+

189+mergeWithKey :: Ord k => (k -> a -> b -> Maybe c) -> (AppendMap k a -> AppendMap k c) -> (AppendMap k b -> AppendMap k c) -> AppendMap k a -> AppendMap k b -> AppendMap k c

190+mergeWithKey f = coerce (Map.mergeWithKey f)

191+

192+map :: (a -> b) -> AppendMap k a -> AppendMap k b

193+map = fmap

194+

195+mapWithKey :: (k -> a -> b) -> AppendMap k a -> AppendMap k b

196+mapWithKey = imap

197+

198+traverseWithKey :: Applicative t => (k -> a -> t b) -> AppendMap k a -> t (AppendMap k b)

199+traverseWithKey = itraverse

200+

201+mapAccum :: (a -> b -> (a, c)) -> a -> AppendMap k b -> (a, AppendMap k c)

202+mapAccum f = coerce (Map.mapAccum f)

203+

204+mapAccumWithKey :: (a -> k -> b -> (a, c)) -> a -> AppendMap k b -> (a, AppendMap k c)

205+mapAccumWithKey f = coerce (Map.mapAccumWithKey f)

206+

207+mapAccumRWithKey :: (a -> k -> b -> (a, c)) -> a -> AppendMap k b -> (a, AppendMap k c)

208+mapAccumRWithKey f = coerce (Map.mapAccumRWithKey f)

209+

210+mapKeys :: forall k1 k2 a. Ord k2 => (k1 -> k2) -> AppendMap k1 a -> AppendMap k2 a

211+mapKeys = coerce (Map.mapKeys @k2 @k1 @a)

212+

213+mapKeysWith :: Ord k2 => (a -> a -> a) -> (k1 -> k2) -> AppendMap k1 a -> AppendMap k2 a

214+mapKeysWith f = coerce (Map.mapKeysWith f)

215+

216+mapKeysMonotonic :: forall k1 k2 a. (k1 -> k2) -> AppendMap k1 a -> AppendMap k2 a

217+mapKeysMonotonic = coerce (Map.mapKeysMonotonic @k1 @k2 @a)

218+

219+foldr :: (a -> b -> b) -> b -> AppendMap k a -> b

220+foldr f = coerce (Map.foldr f)

221+

222+foldl :: (a -> b -> a) -> a -> AppendMap k b -> a

223+foldl f = coerce (Map.foldl f)

224+

225+foldrWithKey :: (k -> a -> b -> b) -> b -> AppendMap k a -> b

226+foldrWithKey f = coerce (Map.foldrWithKey f)

227+

228+foldlWithKey :: (a -> k -> b -> a) -> a -> AppendMap k b -> a

229+foldlWithKey f = coerce (Map.foldlWithKey f)

230

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

231+foldMapWithKey :: Monoid m => (k -> a -> m) -> AppendMap k a -> m

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

232+foldMapWithKey f = coerce (Map.foldMapWithKey f)

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

233

234+foldr' :: (a -> b -> b) -> b -> AppendMap k a -> b

235+foldr' f = coerce (Map.foldr' f)

236+

237+foldl' :: (a -> b -> a) -> a -> AppendMap k b -> a

238+foldl' f = coerce (Map.foldl' f)

239+

240+foldrWithKey' :: (k -> a -> b -> b) -> b -> AppendMap k a -> b

241+foldrWithKey' f = coerce (Map.foldrWithKey' f)

242+

243+foldlWithKey' :: (a -> k -> b -> a) -> a -> AppendMap k b -> a

244+foldlWithKey' f = coerce (Map.foldlWithKey' f)

245+

246+elems :: forall k a. AppendMap k a -> [a]

247+elems = coerce (Map.elems @k @a)

248+

249+keys :: forall k a. AppendMap k a -> [k]

250+keys = coerce (Map.keys @k @a)

251+

252+assocs :: forall k a. AppendMap k a -> [(k, a)]

253+assocs = coerce (Map.assocs @k @a)

254+

255+keysSet :: forall k a. AppendMap k a -> Set k

256+keysSet = coerce (Map.keysSet @k @a)

257+

258+fromSet :: (k -> a) -> Set k -> AppendMap k a

259+fromSet f = coerce (Map.fromSet f)

260+

261+toList :: forall k a. AppendMap k a -> [(k, a)]

262+toList = coerce (Map.toList @k @a)

263+

264+fromList :: forall k a. Ord k => [(k, a)] -> AppendMap k a

265+fromList = coerce (Map.fromList @k @a)

266+

267+fromListWith :: Ord k => (a -> a -> a) -> [(k, a)] -> AppendMap k a

268+fromListWith f = coerce (Map.fromListWith f)

269+

270+fromListWithKey :: Ord k => (k -> a -> a -> a) -> [(k, a)] -> AppendMap k a

271+fromListWithKey f = coerce (Map.fromListWithKey f)

272+

273+toAscList :: forall k a. AppendMap k a -> [(k, a)]

274+toAscList = coerce (Map.toAscList @k @a)

275+

276+toDescList :: forall k a. AppendMap k a -> [(k, a)]

277+toDescList = coerce (Map.toDescList @k @a)

278+

279+fromAscList :: forall k a. Eq k => [(k, a)] -> AppendMap k a

280+fromAscList = coerce (Map.fromAscList @k @a)

281+

282+fromAscListWith :: Eq k => (a -> a -> a) -> [(k, a)] -> AppendMap k a

283+fromAscListWith f = coerce (Map.fromAscListWith f)

284+

285+fromAscListWithKey :: Eq k => (k -> a -> a -> a) -> [(k, a)] -> AppendMap k a

286+fromAscListWithKey f = coerce (Map.fromAscListWithKey f)

287+

288+fromDistinctAscList :: forall k a. [(k, a)] -> AppendMap k a

289+fromDistinctAscList = coerce (Map.fromDistinctAscList @k @a)

290+

291+filter :: (a -> Bool) -> AppendMap k a -> AppendMap k a

292+filter f = coerce (Map.filter f)

293+

294+filterWithKey :: (k -> a -> Bool) -> AppendMap k a -> AppendMap k a

295+filterWithKey f = coerce (Map.filterWithKey f)

296+

297+partition :: (a -> Bool) -> AppendMap k a -> (AppendMap k a, AppendMap k a)

298+partition f = coerce (Map.partition f)

299+

300+partitionWithKey :: (k -> a -> Bool) -> AppendMap k a -> (AppendMap k a, AppendMap k a)

301+partitionWithKey f = coerce (Map.partitionWithKey f)

302+

303+mapMaybe :: (a -> Maybe b) -> AppendMap k a -> AppendMap k b

304+mapMaybe f = coerce (Map.mapMaybe f)

305+

306+mapMaybeWithKey :: (k -> a -> Maybe b) -> AppendMap k a -> AppendMap k b

307+mapMaybeWithKey f = coerce (Map.mapMaybeWithKey f)

308+

309+mapEither :: (a -> Either b c) -> AppendMap k a -> (AppendMap k b, AppendMap k c)

310+mapEither f = coerce (Map.mapEither f)

311+

312+mapEitherWithKey :: (k -> a -> Either b c) -> AppendMap k a -> (AppendMap k b, AppendMap k c)

313+mapEitherWithKey f = coerce (Map.mapEitherWithKey f)

314+

315+split :: forall k a. Ord k => k -> AppendMap k a -> (AppendMap k a, AppendMap k a)

316+split = coerce (Map.split @k @a)

317+

318+splitLookup :: forall k a. Ord k => k -> AppendMap k a -> (AppendMap k a, Maybe a, AppendMap k a)

319+splitLookup = coerce (Map.splitLookup @k @a)

320+

321+splitRoot :: forall k a. AppendMap k a -> [AppendMap k a]

322+splitRoot = coerce (Map.splitRoot @k @a)

323+

324+isSubmapOf :: forall k a. (Ord k, Eq a) => AppendMap k a -> AppendMap k a -> Bool

325+isSubmapOf = coerce (Map.isSubmapOf @k @a)

326+

327+isSubmapOfBy :: Ord k => (a -> b -> Bool) -> AppendMap k a -> AppendMap k b -> Bool

328+isSubmapOfBy f = coerce (Map.isSubmapOfBy f)

329+

330+isProperSubmapOf :: forall k a. (Ord k, Eq a) => AppendMap k a -> AppendMap k a -> Bool

331+isProperSubmapOf = coerce (Map.isProperSubmapOf @k @a)

332+

333+isProperSubmapOfBy :: Ord k => (a -> b -> Bool) -> AppendMap k a -> AppendMap k b -> Bool

334+isProperSubmapOfBy f = coerce (Map.isProperSubmapOfBy f)

335+

336+lookupIndex :: forall k a. Ord k => k -> AppendMap k a -> Maybe Int

337+lookupIndex = coerce (Map.lookupIndex @k @a)

338+

339+findIndex :: forall k a. Ord k => k -> AppendMap k a -> Int

340+findIndex = coerce (Map.findIndex @k @a)

341+

342+elemAt :: forall k a. Int -> AppendMap k a -> (k, a)

343+elemAt = coerce (Map.elemAt @k @a)

344+

345+updateAt :: forall k a. (k -> a -> Maybe a) -> Int -> AppendMap k a -> AppendMap k a

346+updateAt = coerce (Map.updateAt @k @a)

347+

348+deleteAt :: forall k a. Int -> AppendMap k a -> AppendMap k a

349+deleteAt = coerce (Map.deleteAt @k @a)

350+

351+findMin :: forall k a. AppendMap k a -> (k, a)

352+findMin = coerce (Map.findMin @k @a)

353+

354+findMax :: forall k a. AppendMap k a -> (k, a)

355+findMax = coerce (Map.findMax @k @a)

356+

357+deleteMin :: forall k a. AppendMap k a -> AppendMap k a

358+deleteMin = coerce (Map.deleteMin @k @ a)

359+

360+deleteMax :: forall k a. AppendMap k a -> AppendMap k a

361+deleteMax = coerce (Map.deleteMax @k @a)

362+

363+deleteFindMin :: forall k a. AppendMap k a -> ((k, a), AppendMap k a)

364+deleteFindMin = coerce (Map.deleteFindMin @k @a)

365+

366+deleteFindMax :: forall k a. AppendMap k a -> ((k, a), AppendMap k a)

367+deleteFindMax = coerce (Map.deleteFindMax @k @a)

368+

369+updateMin :: (a -> Maybe a) -> AppendMap k a -> AppendMap k a

370+updateMin f = coerce (Map.updateMin f)

371+

372+updateMax :: (a -> Maybe a) -> AppendMap k a -> AppendMap k a

373+updateMax f = coerce (Map.updateMax f)

374+

375+updateMinWithKey :: (k -> a -> Maybe a) -> AppendMap k a -> AppendMap k a

376+updateMinWithKey f = coerce (Map.updateMinWithKey f)

377+

378+updateMaxWithKey :: (k -> a -> Maybe a) -> AppendMap k a -> AppendMap k a

379+updateMaxWithKey f = coerce (Map.updateMaxWithKey f)

380+

381+minView :: forall k a. AppendMap k a -> Maybe (a, AppendMap k a)

382+minView = coerce (Map.minView @k @a)

383+

384+maxView :: forall k a. AppendMap k a -> Maybe (a, AppendMap k a)

385+maxView = coerce (Map.maxView @k @a)

386+

387+minViewWithKey :: forall k a. AppendMap k a -> Maybe ((k, a), AppendMap k a)

388+minViewWithKey = coerce (Map.minViewWithKey @k @a)

389+

390+maxViewWithKey :: forall k a. AppendMap k a -> Maybe ((k, a), AppendMap k a)

391+maxViewWithKey = coerce (Map.maxViewWithKey @k @a)

392+

393+showTree :: forall k a. (Show k, Show a) => AppendMap k a -> String

394+showTree = coerce (Map.showTree @k @a)

395+

396+showTreeWith :: (k -> a -> String) -> Bool -> Bool -> AppendMap k a -> String

397+showTreeWith f = coerce (Map.showTreeWith f)

398+

399+valid :: forall k a. Ord k => AppendMap k a -> Bool

400+valid = coerce (Map.valid @k @a)

401+

83−instance Default (MonoidalMap k a) where

402+instance Default (AppendMap k a) where

84 def = empty

403 def = empty

404+

405+instance AppendMap k' v' ~ t => Rewrapped (AppendMap k a) t

406+

407+instance Wrapped (AppendMap k a) where

408+ type Unwrapped (AppendMap k a) = Map k a

409+ _Wrapped' = iso (\(AppendMap m) -> m) AppendMap

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

@@ -1,12 +1,9 @@

1+{-# LANGUAGE BangPatterns #-}

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE CPP #-}

2{-# LANGUAGE ExistentialQuantification #-}

3{-# LANGUAGE ExistentialQuantification #-}

3#ifdef USE_REFLEX_OPTIMIZER

4#ifdef USE_REFLEX_OPTIMIZER

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

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

5#endif

6#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

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

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

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

@@ -15,88 +12,77 @@ module Data.FastWeakBag

15 ( FastWeakBag

12 ( FastWeakBag

16 , FastWeakBagTicket

13 , FastWeakBagTicket

17 , empty

14 , empty

18− , isEmpty

15+ , singleton

19 , insert

16 , insert

20 , traverse

17 , traverse

21− , traverse_

22 , remove

18 , remove

23 -- * Internal functions

19 -- * Internal functions

24 -- These will not always be available.

20 -- These will not always be available.

25−#ifndef GHCJS_FAST_WEAK

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

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

27−#endif

28 ) where

22 ) where

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

39import Control.Exception

24import Control.Exception

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

26+import Control.Monad.IO.Class

27+import Data.Foldable (forM_, mapM_)

40import Data.IntMap.Strict (IntMap)

28import Data.IntMap.Strict (IntMap)

41import qualified Data.IntMap.Strict as IntMap

29import qualified Data.IntMap.Strict as IntMap

42import Data.IORef

30import Data.IORef

31+import Reflex.FastWeak

43import System.Mem.Weak

32import System.Mem.Weak

44−#endif

34+import Prelude hiding (mapM_, traverse)

35+

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

36+-- | A @FastWeakBag a@ 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

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

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

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

49−#ifdef GHCJS_FAST_WEAK

50−newtype FastWeakBag a = FastWeakBag JSVal

51−#else

52data FastWeakBag a = FastWeakBag

39data FastWeakBag a = FastWeakBag

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

40 { _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'

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

55 }

42 }

56−#endif

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

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

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

46-- 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'.

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

48+data FastWeakBagTicket = forall a. FastWeakBagTicket

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

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

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

50 , _weakBagTicket_item :: {-# NOUNPACK #-} !a

68 }

51 }

69−#endif

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

53-- | Insert an item into a 'FastWeakBag'.

72{-# INLINE insert #-}

54{-# INLINE insert #-}

73insert :: a -- ^ The item

55insert :: a -- ^ The item

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

56 -> FastWeakBag a -- ^ The 'FastWeakBag' to insert into

57+ -> FastWeak b -- ^ An arbitrary value to be used in the following

58+ -- callback

59+ -> (b -> IO ()) -- ^ A callback to be invoked when the item is removed

60+ -- (whether automatically by the item being garbage

61+ -- collected or manually via 'remove')

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

62+ -> IO FastWeakBagTicket -- ^ Returns a 'FastWeakBagTicket' that ensures the item

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

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

64+insert a (FastWeakBag nextId children) wb finalizer = {-# SCC "insert" #-} do

82 a' <- evaluate a

65 a' <- evaluate a

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

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

67+ let cleanup = do

68+ mb <- getFastWeakValue wb

69+ forM_ mb $ \b -> do

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

70+ csWithoutMe <- atomicModifyIORef children $ \cs ->

71+ let !csWithoutMe = IntMap.delete myId cs

72+ in (csWithoutMe, csWithoutMe)

73+ when (IntMap.null csWithoutMe) $ finalizer b

74+ return ()

75+ return ()

85 wa <- mkWeakPtr a' $ Just cleanup

76 wa <- mkWeakPtr a' $ Just cleanup

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

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

87 return $ FastWeakBagTicket

78 return $ FastWeakBagTicket

88 { _weakBagTicket_weakItem = wa

79 { _weakBagTicket_weakItem = wa

89 , _weakBagTicket_item = a'

80 , _weakBagTicket_item = a'

90 }

81 }

91−#endif

93-- | Create an empty 'FastWeakBag'.

83-- | Create an empty 'FastWeakBag'.

94{-# INLINE empty #-}

84{-# INLINE empty #-}

95empty :: IO (FastWeakBag a)

85empty :: 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

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

86empty = {-# SCC "empty" #-} do

101 nextId <- newIORef 1

87 nextId <- newIORef 1

102 children <- newIORef IntMap.empty

88 children <- newIORef IntMap.empty

@@ -105,57 +91,33 @@ empty = {-# SCC "empty" #-} do

105 , _weakBag_children = children

91 , _weakBag_children = children

106 }

92 }

107 return bag

93 return bag

108−#endif

109

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

95+-- | Create a 'FastWeakBag' with one item; equivalent to creating the 'FastWeakBag' with

96+-- 'empty', then using 'insert'.

111−{-# INLINE isEmpty #-}

97+{-# INLINE singleton #-}

112−isEmpty :: FastWeakBag a -> IO Bool

98+singleton :: a -> FastWeak b -> (b -> IO ()) -> IO (FastWeakBag a, FastWeakBagTicket)

113−#ifdef GHCJS_FAST_WEAK

99+singleton a wb finalizer = {-# SCC "singleton" #-} do

114−isEmpty = js_isEmpty

100+ bag <- empty

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

101+ ticket <- insert a bag wb finalizer

116−#else

102+ return (bag, ticket)

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

118−#endif

119

103

120−{-# INLINE traverse_ #-}

104+{-# INLINE traverse #-}

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

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

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

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

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

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

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

109+traverse :: 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

110+traverse (FastWeakBag _ children) f = {-# SCC "traverse" #-} do

139 cs <- liftIO $ readIORef children

111 cs <- liftIO $ readIORef children

140 forM_ cs $ \c -> do

112 forM_ cs $ \c -> do

141 ma <- liftIO $ deRefWeak c

113 ma <- liftIO $ deRefWeak c

142 mapM_ f ma

114 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

115

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

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

150-- on the same 'FastWeakBagTicket'.

117-- on the same 'FastWeakBagTicket'.

151{-# INLINE remove #-}

118{-# INLINE remove #-}

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

119+remove :: FastWeakBagTicket -> 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

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

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

158−#endif

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

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

160

122

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

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

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

@@ -0,0 +1,339 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DeriveDataTypeable #-}

3+{-# LANGUAGE DeriveFunctor #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE GADTs #-}

7+{-# LANGUAGE KindSignatures #-}

8+{-# LANGUAGE LambdaCase #-}

9+{-# LANGUAGE MultiParamTypeClasses #-}

10+{-# LANGUAGE PolyKinds #-}

11+{-# LANGUAGE RankNTypes #-}

12+{-# LANGUAGE ScopedTypeVariables #-}

13+{-# LANGUAGE StandaloneDeriving #-}

14+#ifdef USE_REFLEX_OPTIMIZER

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

16+#endif

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

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

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

20+module Data.Functor.Misc

21+ ( -- * Const2

22+ Const2 (..)

23+ , unConst2

24+ , dmapToMap

25+ , dmapToMapWith

26+ , mapToDMap

27+ , weakenDMapWith

28+ -- * WrapArg

29+ , WrapArg (..)

30+ -- * Convenience functions for DMap

31+ , mapWithFunctorToDMap

32+ , mapKeyValuePairsMonotonic

33+ , combineDMapsWithKey

34+ , EitherTag (..)

35+ , dmapToThese

36+ , eitherToDSum

37+ , dsumToEither

38+ -- * Deprecated functions

39+ , sequenceDmap

40+ , wrapDMap

41+ , rewrapDMap

42+ , unwrapDMap

43+ , unwrapDMapMaybe

44+ , extractFunctorDMap

45+ , ComposeMaybe (..)

46+ ) where

47+

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

49+import Control.Monad.Identity

50+import Data.Dependent.Map (DMap)

51+import qualified Data.Dependent.Map as DMap

52+import Data.Dependent.Sum

53+import Data.GADT.Compare

54+import Data.GADT.Show

55+import Data.Map (Map)

56+import qualified Data.Map as Map

57+import Data.Some (Some)

58+import qualified Data.Some as Some

59+import Data.These

60+import Data.Typeable hiding (Refl)

61+

62+--------------------------------------------------------------------------------

63+-- Const2

64+--------------------------------------------------------------------------------

65+

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

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

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

69+ Const2 :: k -> Const2 k v v

70+ deriving (Typeable)

71+

72+unConst2 :: Const2 k v v' -> k

73+unConst2 (Const2 k) = k

74+

75+deriving instance Eq k => Eq (Const2 k v v')

76+deriving instance Ord k => Ord (Const2 k v v')

77+deriving instance Show k => Show (Const2 k v v')

78+deriving instance Read k => Read (Const2 k v v)

79+

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

81+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

82+ gshowToShow (Const2 _) = id

83+#else

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

85+#endif

86+

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

88+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

89+ showTagToShow (Const2 _) _ = id

90+#else

91+ showTaggedPrec (Const2 _) = showsPrec

92+#endif

93+

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

95+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

96+ geqToEq _ = id

97+ geqUnify (Const2 _) (Const2 _) _ = id

98+#else

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

100+ if a == b

101+ then Just Refl

102+ else Nothing

103+#endif

104+

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

106+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

107+ gcompareToOrd (Const2 _) = id

108+ gcompare (Const2 a) (Const2 b) = strengthenOrdering $ compare a b

109+#else

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

111+ LT -> GLT

112+ EQ -> GEQ

113+ GT -> GGT

114+#endif

115+

116+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

117+instance {-# INCOHERENT #-} (Eq k, Eq v) => EqTag (Const2 k v) Identity where

118+ eqTagToEq (Const2 _) _ = id

119+

120+instance {-# INCOHERENT #-} Eq k => EqTag (Const2 k v) (Const2 k v) where

121+ eqTagToEq (Const2 _) _ = id

122+#endif

123+

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

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

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

127+

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

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

130+

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

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

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

134+

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

136+-- to a 'DMap'

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

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

139+

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

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

142+

143+--------------------------------------------------------------------------------

144+-- WrapArg

145+--------------------------------------------------------------------------------

146+

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

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

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

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

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

152+

153+deriving instance Eq (f a) => Eq (WrapArg g f (g' a))

154+deriving instance Ord (f a) => Ord (WrapArg g f (g' a))

155+deriving instance Show (f a) => Show (WrapArg g f (g' a))

156+deriving instance Read (f a) => Read (WrapArg g f (g a))

157+

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

159+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

160+ geqToEq (WrapArg f) = geqToEq f

161+ geqUnify (WrapArg a) (WrapArg b) = geqUnify a b

162+#else

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

164+#endif

165+

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

167+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

168+ gcompareToOrd (WrapArg f) = gcompareToOrd f

169+#endif

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

171+ GLT -> GLT

172+ GEQ -> GEQ

173+ GGT -> GGT

174+

175+--------------------------------------------------------------------------------

176+-- Convenience functions for DMap

177+--------------------------------------------------------------------------------

178+

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

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

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

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

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

184+

185+{-# INLINE combineDMapsWithKey #-}

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

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

188+combineDMapsWithKey :: forall f g h i.

189+ GCompare f

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

191+ -> DMap f g

192+ -> DMap f h

193+ -> DMap f i

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

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

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

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

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

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

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

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

202+

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

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

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

206+ (Nothing, Nothing) -> Nothing

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

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

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

210+

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

212+data EitherTag l r a where

213+ LeftTag :: EitherTag l r l

214+ RightTag :: EitherTag l r r

215+ deriving (Typeable)

216+

217+deriving instance Show (EitherTag l r a)

218+deriving instance Eq (EitherTag l r a)

219+deriving instance Ord (EitherTag l r a)

220+

221+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

222+instance {-# INCOHERENT #-} (Show (f l), Show (f r)) => ShowTag (EitherTag l r) f where

223+ showTagToShow e _ = case e of

224+ LeftTag -> id

225+ RightTag -> id

226+

227+instance {-# INCOHERENT #-} (Eq (f l), Eq (f r)) => EqTag (EitherTag l r) f where

228+ eqTagToEq e _ = case e of

229+ LeftTag -> id

230+ RightTag -> id

231+#endif

232+

233+instance GEq (EitherTag l r) where

234+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

235+ geqToEq _ = id

236+ geqUnify LeftTag LeftTag _ same = same

237+ geqUnify RightTag RightTag _ same = same

238+ geqUnify _ _ unknown _ = unknown

239+#endif

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

241+ (LeftTag, LeftTag) -> Just Refl

242+ (RightTag, RightTag) -> Just Refl

243+ _ -> Nothing

244+

245+instance GCompare (EitherTag l r) where

246+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

247+ gcompareToOrd _ = id

248+#endif

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

250+ (LeftTag, LeftTag) -> GEQ

251+ (LeftTag, RightTag) -> GLT

252+ (RightTag, LeftTag) -> GGT

253+ (RightTag, RightTag) -> GEQ

254+

255+instance GShow (EitherTag l r) where

256+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

257+ gshowToShow _ = id

258+#else

259+ gshowsPrec _ a = case a of

260+ LeftTag -> showString "LeftTag"

261+ RightTag -> showString "RightTag"

262+#endif

263+

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

265+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

266+ showTagToShow t _ = case t of

267+ LeftTag -> id

268+ RightTag -> id

269+#else

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

271+ LeftTag -> showsPrec n a

272+ RightTag -> showsPrec n a

273+#endif

274+

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

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

277+eitherToDSum = \case

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

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

280+

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

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

283+dsumToEither = \case

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

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

286+

287+--------------------------------------------------------------------------------

288+-- ComposeMaybe

289+--------------------------------------------------------------------------------

290+

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

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

293+-- representational so that we can use safe 'coerce'.

294+newtype ComposeMaybe f a = ComposeMaybe { getComposeMaybe :: Maybe (f a) } deriving (Show, Eq, Ord)

295+

296+deriving instance Functor f => Functor (ComposeMaybe f)

297+

298+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

299+instance {-# INCOHERENT #-} EqTag f g => EqTag f (ComposeMaybe g) where

300+ eqTagToEq f _ = eqTagToEq f (Proxy :: Proxy g)

301+

302+instance {-# INCOHERENT #-} GShow k => ShowTag k (ComposeMaybe k) where

303+ showTagToShow k _ r = gshowToShow k (showTagToShow k (Proxy :: Proxy k) r)

304+#endif

305+--------------------------------------------------------------------------------

306+-- Deprecated functions

307+--------------------------------------------------------------------------------

308+

309+{-# INLINE sequenceDmap #-}

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

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

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

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

314+

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

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

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

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

319+

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

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

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

323+rewrapDMap = DMap.map

324+

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

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

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

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

329+

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

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

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

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

334+

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

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

337+-- underlying functor

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

339+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−11

@@ -6,30 +6,21 @@ 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

28import Reflex.Query.Base as X

20import Reflex.Query.Base as X

29import Reflex.Query.Class as X

21import Reflex.Query.Class as X

30import Reflex.Requester.Base as X

22import Reflex.Requester.Base as X

31import Reflex.Requester.Class as X

23import Reflex.Requester.Class as X

32import Reflex.Spider as X

24import Reflex.Spider as X

33−import Reflex.Time as X

34import Reflex.TriggerEvent.Base as X

25import Reflex.TriggerEvent.Base as X

35import Reflex.TriggerEvent.Class as X

26import 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+359−930

@@ -1,14 +1,12 @@

1−{-# LANGUAGE BangPatterns #-}

2{-# LANGUAGE CPP #-}

1{-# LANGUAGE CPP #-}

3−{-# LANGUAGE ConstraintKinds #-}

4{-# LANGUAGE DefaultSignatures #-}

2{-# LANGUAGE DefaultSignatures #-}

5{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

6{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

7{-# LANGUAGE FunctionalDependencies #-}

5{-# LANGUAGE FunctionalDependencies #-}

8{-# LANGUAGE GADTs #-}

6{-# LANGUAGE GADTs #-}

9{-# LANGUAGE LambdaCase #-}

7{-# LANGUAGE LambdaCase #-}

8+{-# LANGUAGE MultiParamTypeClasses #-}

10{-# LANGUAGE NoMonomorphismRestriction #-}

9{-# LANGUAGE NoMonomorphismRestriction #-}

11−{-# LANGUAGE PolyKinds #-}

12{-# LANGUAGE RankNTypes #-}

10{-# LANGUAGE RankNTypes #-}

13{-# LANGUAGE RecursiveDo #-}

11{-# LANGUAGE RecursiveDo #-}

14{-# LANGUAGE RoleAnnotations #-}

12{-# LANGUAGE RoleAnnotations #-}

@@ -16,56 +14,43 @@

16{-# LANGUAGE TypeFamilies #-}

14{-# LANGUAGE TypeFamilies #-}

17{-# LANGUAGE TypeOperators #-}

15{-# LANGUAGE TypeOperators #-}

18{-# LANGUAGE UndecidableInstances #-}

16{-# LANGUAGE UndecidableInstances #-}

19−{-# LANGUAGE Trustworthy #-}

20#ifdef USE_REFLEX_OPTIMIZER

17#ifdef USE_REFLEX_OPTIMIZER

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

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

22#endif

19#endif

20+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

21+{-# LANGUAGE EmptyDataDecls #-}

22+{-# OPTIONS_GHC -Wno-redundant-constraints #-}

23+#endif

24−-- |

25−-- Module:

26−-- Reflex.Class

27−-- Description:

28−-- This module contains the Reflex interface, as well as a variety of

25+-- | This module contains the Reflex interface, as well as a variety of

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

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

30−-- signals.

27+-- signals.

31module Reflex.Class

28module Reflex.Class

32− ( module Data.Patch

29+ ( module Reflex.Patch

33 -- * Primitives

30 -- * Primitives

34 , Reflex (..)

31 , Reflex (..)

35− , mergeInt

36 , coerceBehavior

32 , coerceBehavior

37 , coerceEvent

33 , coerceEvent

38 , coerceDynamic

34 , coerceDynamic

39− , coerceIncremental

40 , MonadSample (..)

35 , MonadSample (..)

41 , MonadHold (..)

36 , MonadHold (..)

42− -- ** 'fan' related types

37+ -- ** 'fan'-related types

43 , EventSelector (..)

38 , EventSelector (..)

44− , EventSelectorG (..)

39+ -- ** 'Incremental'-related types

45− , EventSelectorInt (..)

46 -- * Convenience functions

40 -- * Convenience functions

47 , constDyn

41 , constDyn

48 , pushAlways

42 , pushAlways

49 -- ** Combining 'Event's

43 -- ** Combining 'Event's

50 , leftmost

44 , leftmost

51− , merge

52− , mergeIncremental

53− , mergeIncrementalWithMove

54 , mergeMap

45 , mergeMap

55− , mergeIntMap

56 , mergeMapIncremental

46 , mergeMapIncremental

57 , mergeMapIncrementalWithMove

47 , mergeMapIncrementalWithMove

58− , mergeIntMapIncremental

59− , coincidencePatchMap

60− , coincidencePatchMapWithMove

61− , coincidencePatchIntMap

62 , mergeList

48 , mergeList

63 , mergeWith

49 , mergeWith

64 , difference

50 , difference

65 , alignEventWithMaybe

51 , alignEventWithMaybe

66 -- ** Breaking up 'Event's

52 -- ** Breaking up 'Event's

67 , splitE

53 , splitE

68− , fan

69 , fanEither

54 , fanEither

70 , fanThese

55 , fanThese

71 , fanMap

56 , fanMap

@@ -73,16 +58,11 @@ module Reflex.Class

73 , EitherTag (..)

58 , EitherTag (..)

74 , eitherToDSum

59 , eitherToDSum

75 , dsumToEither

60 , dsumToEither

76− , factorEvent

61+ -- ** Switching between 'Event's

77− , filterEventKey

62+ , switchPromptly

78− -- ** Collapsing 'Event . Event'

63+ , switchPromptOnly

79− , switchHold

80− , switchHoldPromptly

81− , switchHoldPromptOnly

82− , switchHoldPromptOnlyIncremental

83 -- ** Using 'Event's to sample 'Behavior's

64 -- ** Using 'Event's to sample 'Behavior's

84 , tag

65 , tag

85− , tagMaybe

86 , attach

66 , attach

87 , attachWith

67 , attachWith

88 , attachWithMaybe

68 , attachWithMaybe

@@ -90,53 +70,25 @@ module Reflex.Class

90 , gate

70 , gate

91 -- ** Combining 'Dynamic's

71 -- ** Combining 'Dynamic's

92 , distributeDMapOverDynPure

72 , distributeDMapOverDynPure

93− , distributeDMapOverDynPureG

94 , distributeListOverDyn

73 , distributeListOverDyn

95 , distributeListOverDynWith

74 , distributeListOverDynWith

96 , zipDyn

75 , zipDyn

97 , zipDynWith

76 , zipDynWith

98 -- ** Accumulating state

77 -- ** Accumulating state

99 , Accumulator (..)

78 , 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_

79 , mapAccum_

117 , mapAccumM_

80 , mapAccumM_

118 , mapAccumMaybe_

81 , mapAccumMaybe_

119 , mapAccumMaybeM_

82 , mapAccumMaybeM_

120− , accumIncremental

121− , accumMIncremental

122− , accumMaybeIncremental

123− , accumMaybeMIncremental

124− , mapAccumIncremental

125− , mapAccumMIncremental

126− , mapAccumMaybeIncremental

127− , mapAccumMaybeMIncremental

128 , zipListWithEvent

83 , zipListWithEvent

129 , numberOccurrences

84 , numberOccurrences

130 , numberOccurrencesFrom

85 , numberOccurrencesFrom

131− , numberOccurrencesFrom_

132 , (<@>)

86 , (<@>)

133 , (<@)

87 , (<@)

88+ , headE

134 , tailE

89 , tailE

135 , headTailE

90 , headTailE

136 , takeWhileE

91 , takeWhileE

137− , takeWhileJustE

138− , dropWhileE

139− , takeDropWhileJustE

140 , switcher

92 , switcher

141 -- * Debugging functions

93 -- * Debugging functions

142 , traceEvent

94 , traceEvent

@@ -144,24 +96,21 @@ module Reflex.Class

144 -- * Unsafe functions

96 -- * Unsafe functions

145 , unsafeDynamic

97 , unsafeDynamic

146 , unsafeMapIncremental

98 , unsafeMapIncremental

147− -- * 'Filterable' convenience functions

99+ -- * 'FunctorMaybe'

148− , FunctorMaybe -- fmapMaybe is purposely not exported from deprecated 'FunctorMaybe' and the new alias is exported instead

100+ , FunctorMaybe (..)

149− , mapMaybe -- Re-exported for convenience

150− , fmapMaybe

151 , fforMaybe

101 , fforMaybe

152 , ffilter

102 , ffilter

153− , filterLeft

154− , filterRight

155 -- * Miscellaneous convenience functions

103 -- * Miscellaneous convenience functions

156 , ffor

104 , ffor

157− , ffor2

105+ , MonadAdjust (..)

158− , ffor3

106+ , sequenceDMapWithAdjust

107+ , sequenceDMapWithAdjustWithMove

108+ , mapMapWithAdjustWithMove

159 -- * Deprecated functions

109 -- * Deprecated functions

160− , switchPromptly

110+ , appendEvents

161− , switchPromptOnly

111+ , onceE

162− -- * "Cheap" functions

112+ , sequenceThese

163 , fmapMaybeCheap

113 , fmapMaybeCheap

164− , mapMaybeCheap

165 , fmapCheap

114 , fmapCheap

166 , fforCheap

115 , fforCheap

167 , fforMaybeCheap

116 , fforMaybeCheap

@@ -169,65 +118,94 @@ module Reflex.Class

169 , tagCheap

118 , tagCheap

170 , mergeWithCheap

119 , mergeWithCheap

171 , mergeWithCheap'

120 , mergeWithCheap'

172− -- * Slow, but general, implementations

121+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

173− , slowHeadE

122+ , Spider

174− ) where

123+ , SpiderEnv

175−

124+ , SpiderTimeline

176−#ifdef MIN_VERSION_semialign

125+ , Global

177−import Prelude hiding (zip, zipWith)

126+ , Behavior (..)

178−

127+ , Event (..)

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

128+ , Dynamic (..)

180−import Data.These.Combinators (justThese)

129+ , Incremental (..)

181−#endif

130+ , never

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

131+ , constant

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

132+ , push

184−#endif

133+ , pushCheap

134+ , pull

135+ , merge

136+ , fan

137+ , switch

138+ , coincidence

139+ , current

140+ , updated

141+ , unsafeBuildDynamic

142+ , unsafeBuildIncremental

143+ , mergeIncremental

144+ , mergeIncrementalWithMove

145+ , currentIncremental

146+ , updatedIncremental

147+ , incrementalToDynamic

148+ , behaviorCoercion

149+ , eventCoercion

150+ , dynamicCoercion

185#endif

151#endif

152+ ) where

186

153

187import Control.Applicative

154import Control.Applicative

188−import Control.Monad.Identity

155+import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

189−import Control.Monad.Reader

156+import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

190−import Control.Monad.State.Strict

157+import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

191−import Control.Monad.Trans.Cont (ContT)

158+import Control.Monad.Trans.Cont (ContT ())

192−import Control.Monad.Trans.Except (ExceptT)

159+import Control.Monad.Trans.Except (ExceptT ())

193−import Control.Monad.Trans.RWS (RWST)

160+import Control.Monad.Trans.RWS (RWST ())

194−import Control.Monad.Trans.Writer (WriterT)

161+import Control.Monad.Trans.Writer (WriterT ())

195import Data.Align

162import Data.Align

196import Data.Bifunctor

163import Data.Bifunctor

197import Data.Coerce

164import Data.Coerce

198import Data.Default

165import Data.Default

199−import Data.Dependent.Map (DMap)

166+import Data.Dependent.Map (DMap, DSum (..), GCompare (..))

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

201import qualified Data.Dependent.Map as DMap

167import qualified Data.Dependent.Map as DMap

202−import Data.Functor.Compose

168+import Data.Either

203−import Data.Functor.Product

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

205−import Data.FastMutableIntMap (PatchIntMap)

206import Data.Foldable

169import Data.Foldable

207−import Data.Functor.Bind

170+import Data.Functor.Bind hiding (join)

171+import qualified Data.Functor.Bind as Bind

172+import Data.Functor.Constant

208import Data.Functor.Misc

173import Data.Functor.Misc

209import Data.Functor.Plus

174import Data.Functor.Plus

210−import Data.IntMap.Strict (IntMap)

211−import qualified Data.IntMap.Strict as IntMap

212import Data.List.NonEmpty (NonEmpty (..))

175import Data.List.NonEmpty (NonEmpty (..))

213import Data.Map (Map)

176import Data.Map (Map)

214−import Data.Semigroup (Semigroup (..))

177+import Data.Maybe

215−import Data.Some (Some(Some))

178+import Data.Monoid hiding (Alt, (<>))

179+import Data.Semigroup (Semigroup, sconcat, stimes, (<>))

216import Data.String

180import Data.String

217import Data.These

181import Data.These

182+import Data.Traversable

218import Data.Type.Coercion

183import Data.Type.Coercion

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

184+import Reflex.FunctorMaybe

220−import Data.Witherable (Filterable(..))

185+import Reflex.Patch

221−import qualified Data.Witherable as W

186+

222−import Reflex.FunctorMaybe (FunctorMaybe)

187+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

188+import Reflex.Spider.Internal (EventM, Global, HasSpiderTimeline, SpiderHost (..), SpiderHostFrame (..),

189+ SpiderPullM, SpiderPushM (..), behaviorHoldIdentity, dynamicConst,

190+ dynamicCurrent, dynamicDynIdentity, dynamicHold, dynamicHoldIdentity,

191+ dynamicUpdated, newMapDyn, readBehaviorTracked, readBehaviorUntracked,

192+ runFrame, runSpiderHostFrame)

193+import qualified Reflex.Spider.Internal

223−import qualified Reflex.FunctorMaybe

194+import qualified Reflex.Spider.Internal as S

224−import Data.Patch

195+import Unsafe.Coerce

225−import qualified Data.Patch.MapWithMove as PatchMapWithMove

196+#endif

197+

198+-- Note: must come last to silence warnings due to AMP on GHC < 7.10

199+import Prelude hiding (foldl, mapM, mapM_, sequence, sequence_)

226

200

227import Debug.Trace (trace)

201import Debug.Trace (trace)

228

202

203+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

204+#include "Spider/SpiderTimeline.include.hs"

205+#endif

206+

229-- | The 'Reflex' class contains all the primitive functionality needed for

207-- | The 'Reflex' class contains all the primitive functionality needed for

230−-- Functional Reactive Programming (FRP). The @/t/@ type parameter indicates

208+-- Functional Reactive Programming (FRP). The @t@ type parameter indicates

231-- which "timeline" is in use. Timelines are fully-independent FRP contexts,

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

210-- and the type of the timeline determines the FRP engine to be used. For most

233-- purposes, the 'Reflex.Spider' implementation is recommended.

211-- purposes, the 'Reflex.Spider' implementation is recommended.

@@ -237,6 +215,9 @@ class ( MonadHold t (PushM t)

237 , Functor (Dynamic t)

215 , Functor (Dynamic t)

238 , Applicative (Dynamic t) -- Necessary for GHC <= 7.8

216 , Applicative (Dynamic t) -- Necessary for GHC <= 7.8

239 , Monad (Dynamic t)

217 , Monad (Dynamic t)

218+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

219+ , t ~ SpiderTimeline Global

220+#endif

240 ) => Reflex t where

221 ) => Reflex t where

241 -- | A container for a value that can change over time. 'Behavior's can be

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

223 -- sampled at will, but it is not possible to be notified when they change

@@ -259,6 +240,7 @@ class ( MonadHold t (PushM t)

259 type PushM t :: * -> *

240 type PushM t :: * -> *

260 -- | A monad for doing complex pull-based calculations efficiently

241 -- | A monad for doing complex pull-based calculations efficiently

261 type PullM t :: * -> *

242 type PullM t :: * -> *

243+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

262 -- | An 'Event' with no occurrences

244 -- | An 'Event' with no occurrences

263 never :: Event t a

245 never :: Event t a

264 -- | Create a 'Behavior' that always has the given value

246 -- | Create a 'Behavior' that always has the given value

@@ -273,23 +255,18 @@ class ( MonadHold t (PushM t)

273 -- recomputed whenever any of the read 'Behavior's changes

255 -- recomputed whenever any of the read 'Behavior's changes

274 pull :: PullM t a -> Behavior t a

256 pull :: PullM t a -> Behavior t a

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

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

258+ -- least one input event is occuring, and will contain all of the input keys

277 -- that are occurring simultaneously

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

260+ 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

261+ -- | 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

262+ -- be partially applied, and then the result applied repeatedly to create

285− -- create child events

263+ -- child events

286− fanG :: GCompare k => Event t (DMap k v) -> EventSelectorG t k v

264+ 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

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

289 -- 'Event' occurs

266 -- 'Event' occurs

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

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

268+ -- | Create an 'Event' that will occur whenever the input event is occurring

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

269+ -- and its occurrence value, another 'Event', is also occurring

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

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

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

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

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

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

@@ -298,19 +275,14 @@ class ( MonadHold t (PushM t)

298 -- | Create a new 'Dynamic'. The given 'PullM' must always return the most

275 -- | Create a new 'Dynamic'. The given 'PullM' must always return the most

299 -- recent firing of the given 'Event', if any.

276 -- recent firing of the given 'Event', if any.

300 unsafeBuildDynamic :: PullM t a -> Event t a -> Dynamic t a

277 unsafeBuildDynamic :: PullM t a -> Event t a -> Dynamic t a

301− -- | Create a new 'Incremental'. The given "PullM"'s value must always change

278+ -- | 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

279 -- in the same way that the accumulated application of patches would change

303 -- that value.

280 -- that value.

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

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

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

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

283+ 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

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

285+ mergeIncrementalWithMove :: GCompare k => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)

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

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

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

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

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

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

@@ -326,30 +298,79 @@ class ( MonadHold t (PushM t)

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

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

327 -- occurrence type

299 -- occurrence type

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

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

329− -- | Construct a 'Coercion' for an 'Incremental' given 'Coercion's for its

301+#endif

330− -- patch target and patch types.

302+

331− incrementalCoercion

303+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

332− :: Coercion (PatchTarget a) (PatchTarget b) -> Coercion a b -> Coercion (Incremental t a) (Incremental t b)

304+instance t ~ SpiderTimeline Global => Reflex t where

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

305+ newtype Behavior t a = SpiderBehavior { unSpiderBehavior :: Reflex.Spider.Internal.Behavior Global a }

334− fanInt :: Event t (IntMap a) -> EventSelectorInt t a

306+ newtype Event t a = SpiderEvent { unSpiderEvent :: Reflex.Spider.Internal.Event Global a }

335−

307+ 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

308+ 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

309+ type PullM t = SpiderPullM Global

338−-- create child events

310+ type PushM t = SpiderPushM Global

339−fan :: forall t k. (Reflex t, GCompare k)

311+never :: Reflex t => Event t a

340− => Event t (DMap k Identity) -> EventSelector t k

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

313+push :: Reflex t => (a -> PushM t (Maybe b)) -> Event t a -> Event t b

352−mergeInt m = mergeIntIncremental $ unsafeBuildIncremental (return m) never

314+pushCheap :: Reflex t => (a -> PushM t (Maybe b)) -> Event t a -> Event t b

315+pull :: Reflex t => PullM t a -> Behavior t a

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

317+fan :: (Reflex t, GCompare k) => Event t (DMap k Identity) -> EventSelector t k

318+switch :: Reflex t => Behavior t (Event t a) -> Event t a

319+coincidence :: Reflex t => Event t (Event t a) -> Event t a

320+current :: Reflex t => Dynamic t a -> Behavior t a

321+updated :: Reflex t => Dynamic t a -> Event t a

322+unsafeBuildDynamic :: Reflex t => PullM t a -> Event t a -> Dynamic t a

323+unsafeBuildIncremental :: (Reflex t, Patch p) => PullM t (PatchTarget p) -> Event t p -> Incremental t p

324+mergeIncremental :: (Reflex t, GCompare k) => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)

325+mergeIncrementalWithMove :: (Reflex t, GCompare k) => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)

326+currentIncremental :: (Reflex t, Patch p) => Incremental t p -> Behavior t (PatchTarget p)

327+updatedIncremental :: (Reflex t, Patch p) => Incremental t p -> Event t p

328+incrementalToDynamic :: (Reflex t, Patch p) => Incremental t p -> Dynamic t (PatchTarget p)

329+behaviorCoercion :: Reflex t => Coercion a b -> Coercion (Behavior t a) (Behavior t b)

330+eventCoercion :: Reflex t => Coercion a b -> Coercion (Event t a) (Event t b)

331+dynamicCoercion :: Reflex t => Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)

332+{-# INLINE never #-}

333+never = SpiderEvent S.eventNever

334+{-# INLINE constant #-}

335+constant = SpiderBehavior . S.behaviorConst

336+{-# INLINE push #-}

337+push f = SpiderEvent . S.push (coerce f) . unSpiderEvent

338+{-# INLINE pushCheap #-}

339+pushCheap f = SpiderEvent . S.pushCheap (coerce f) . unSpiderEvent

340+{-# INLINE pull #-}

341+pull = SpiderBehavior . S.pull . coerce

342+{-# INLINE merge #-}

343+merge = SpiderEvent . S.merge . S.dynamicConst . (coerce :: DMap k (Event (SpiderTimeline x)) -> DMap k (S.Event x))

344+{-# INLINE fan #-}

345+fan e = EventSelector $ SpiderEvent . S.select (S.fan (unSpiderEvent e))

346+{-# INLINE switch #-}

347+switch = SpiderEvent . S.switch . (coerce :: S.Behavior x (Event (SpiderTimeline x) a) -> S.Behavior x (S.Event x a)) . unSpiderBehavior

348+{-# INLINE coincidence #-}

349+coincidence = SpiderEvent . S.coincidence . (coerce :: S.Event x (Event (SpiderTimeline x) a) -> S.Event x (S.Event x a)) . unSpiderEvent

350+{-# INLINE current #-}

351+current = SpiderBehavior . S.dynamicCurrent . unSpiderDynamic

352+{-# INLINE updated #-}

353+updated = coerceEvent . SpiderEvent . dynamicUpdated . unSpiderDynamic

354+{-# INLINE unsafeBuildDynamic #-}

355+unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ S.unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'

356+{-# INLINE unsafeBuildIncremental #-}

357+unsafeBuildIncremental readV0 dv = SpiderIncremental $ S.dynamicDyn $ S.unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv

358+{-# INLINE mergeIncremental #-}

359+mergeIncremental = SpiderEvent . S.merge . (unsafeCoerce :: S.Dynamic x (PatchDMap k (Event (SpiderTimeline x))) -> S.Dynamic x (PatchDMap k (S.Event x))) . unSpiderIncremental

360+{-# INLINE mergeIncrementalWithMove #-}

361+mergeIncrementalWithMove = SpiderEvent . S.mergeWithMove . (unsafeCoerce :: S.Dynamic x (PatchDMapWithMove k (Event (SpiderTimeline x))) -> S.Dynamic x (PatchDMapWithMove k (S.Event x))) . unSpiderIncremental

362+{-# INLINE currentIncremental #-}

363+currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental

364+{-# INLINE updatedIncremental #-}

365+updatedIncremental = SpiderEvent . dynamicUpdated . unSpiderIncremental

366+{-# INLINE incrementalToDynamic #-}

367+incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ dynamicDynIdentity $ S.unsafeBuildDynamic (readBehaviorUntracked $ dynamicCurrent i) $ flip S.push (dynamicUpdated i) $ \p -> do

368+ c <- readBehaviorUntracked $ dynamicCurrent i

369+ return $ Identity <$> apply p c

370+eventCoercion Coercion = Coercion

371+behaviorCoercion Coercion = Coercion

372+dynamicCoercion = unsafeCoerce

373+#endif

353

374

354-- | Coerce a 'Behavior' between representationally-equivalent value types

375-- | Coerce a 'Behavior' between representationally-equivalent value types

355coerceBehavior :: (Reflex t, Coercible a b) => Behavior t a -> Behavior t b

376coerceBehavior :: (Reflex t, Coercible a b) => Behavior t a -> Behavior t b

@@ -363,14 +384,8 @@ coerceEvent = coerceWith $ eventCoercion Coercion

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

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

364coerceDynamic = coerceWith $ dynamicCoercion Coercion

385coerceDynamic = coerceWith $ dynamicCoercion Coercion

365

386

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'

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

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

388+-- _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';

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

390-- if this is not the case, the resulting 'Dynamic' will behave

376-- nondeterministically.

391-- nondeterministically.

@@ -398,7 +413,7 @@ class MonadSample t m => MonadHold t m where

398 -- value and will be updated whenever the given 'Event' occurs. The update

413 -- value and will be updated whenever the given 'Event' occurs. The update

399 -- takes effect immediately after the 'Event' occurs; if the occurrence that

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

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

416+ -- the 'Behavior', it will see the _old_ value of the 'Behavior', not the new

402 -- one.

417 -- one.

403 hold :: a -> Event t a -> m (Behavior t a)

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

419 default hold :: (m ~ f m', MonadTrans f, MonadHold t m') => a -> Event t a -> m (Behavior t a)

@@ -413,153 +428,24 @@ class MonadSample t m => MonadHold t m where

413 holdIncremental :: Patch p => PatchTarget p -> Event t p -> m (Incremental t p)

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

429 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

430 holdIncremental v0 = lift . holdIncremental v0

416− buildDynamic :: PushM t a -> Event t a -> m (Dynamic t a)

431+ buildDynamic :: PullM 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)

432 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

433 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

434

534-- | An 'EventSelector' allows you to efficiently 'select' an 'Event' based on a

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

436-- key. This is much more efficient than filtering for each key with

536−-- 'mapMaybe'.

437+-- 'fmapMaybe'.

537newtype EventSelector t k = EventSelector

438newtype EventSelector t k = EventSelector

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

439 { -- | 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

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

441 -- 'Event's whose sub-'Event's have different types.

541 --

442 --

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

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

543− -- (but equivalent to) using 'mapMaybe' to select only the relevant

444+ -- (but equivalent to) using 'fmapMaybe' to select only the relevant

544 -- occurrences of an 'Event'.

445 -- occurrences of an 'Event'.

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

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

546 }

447 }

547

448

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

449--------------------------------------------------------------------------------

564-- Instances

450-- Instances

565--------------------------------------------------------------------------------

451--------------------------------------------------------------------------------

@@ -572,8 +458,6 @@ instance MonadHold t m => MonadHold t (ReaderT r m) where

572 holdDyn a0 = lift . holdDyn a0

458 holdDyn a0 = lift . holdDyn a0

573 holdIncremental a0 = lift . holdIncremental a0

459 holdIncremental a0 = lift . holdIncremental a0

574 buildDynamic a0 = lift . buildDynamic a0

460 buildDynamic a0 = lift . buildDynamic a0

575− headE = lift . headE

576− now = lift now

577

461

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

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

579 sample = lift . sample

463 sample = lift . sample

@@ -583,8 +467,6 @@ instance (MonadHold t m, Monoid r) => MonadHold t (WriterT r m) where

583 holdDyn a0 = lift . holdDyn a0

467 holdDyn a0 = lift . holdDyn a0

584 holdIncremental a0 = lift . holdIncremental a0

468 holdIncremental a0 = lift . holdIncremental a0

585 buildDynamic a0 = lift . buildDynamic a0

469 buildDynamic a0 = lift . buildDynamic a0

586− headE = lift . headE

587− now = lift now

588

470

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

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

590 sample = lift . sample

472 sample = lift . sample

@@ -594,8 +476,6 @@ instance MonadHold t m => MonadHold t (StateT s m) where

594 holdDyn a0 = lift . holdDyn a0

476 holdDyn a0 = lift . holdDyn a0

595 holdIncremental a0 = lift . holdIncremental a0

477 holdIncremental a0 = lift . holdIncremental a0

596 buildDynamic a0 = lift . buildDynamic a0

478 buildDynamic a0 = lift . buildDynamic a0

597− headE = lift . headE

598− now = lift now

599

479

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

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

601 sample = lift . sample

481 sample = lift . sample

@@ -604,9 +484,6 @@ instance MonadHold t m => MonadHold t (ExceptT e m) where

604 hold a0 = lift . hold a0

484 hold a0 = lift . hold a0

605 holdDyn a0 = lift . holdDyn a0

485 holdDyn a0 = lift . holdDyn a0

606 holdIncremental a0 = lift . holdIncremental a0

486 holdIncremental a0 = lift . holdIncremental a0

607− buildDynamic a0 = lift . buildDynamic a0

608− headE = lift . headE

609− now = lift now

610

487

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

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

612 sample = lift . sample

489 sample = lift . sample

@@ -615,9 +492,6 @@ instance (MonadHold t m, Monoid w) => MonadHold t (RWST r w s m) where

615 hold a0 = lift . hold a0

492 hold a0 = lift . hold a0

616 holdDyn a0 = lift . holdDyn a0

493 holdDyn a0 = lift . holdDyn a0

617 holdIncremental a0 = lift . holdIncremental a0

494 holdIncremental a0 = lift . holdIncremental a0

618− buildDynamic a0 = lift . buildDynamic a0

619− headE = lift . headE

620− now = lift now

621

495

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

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

623 sample = lift . sample

497 sample = lift . sample

@@ -626,9 +500,6 @@ instance MonadHold t m => MonadHold t (ContT r m) where

626 hold a0 = lift . hold a0

500 hold a0 = lift . hold a0

627 holdDyn a0 = lift . holdDyn a0

501 holdDyn a0 = lift . holdDyn a0

628 holdIncremental a0 = lift . holdIncremental a0

502 holdIncremental a0 = lift . holdIncremental a0

629− buildDynamic a0 = lift . buildDynamic a0

630− headE = lift . headE

631− now = lift now

632

503

633--------------------------------------------------------------------------------

504--------------------------------------------------------------------------------

634-- Convenience functions

505-- Convenience functions

@@ -643,14 +514,6 @@ pushAlways f = push (fmap Just . f)

643ffor :: Functor f => f a -> (a -> b) -> f b

514ffor :: Functor f => f a -> (a -> b) -> f b

644ffor = flip fmap

515ffor = flip fmap

645

516

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

517instance Reflex t => Applicative (Behavior t) where

655 pure = constant

518 pure = constant

656 f <*> x = pull $ sample f `ap` sample x

519 f <*> x = pull $ sample f `ap` sample x

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

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

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

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

543 return = constant

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

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

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

683−#endif

684

545

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

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

686 mempty = constant mempty

547 mempty = constant mempty

@@ -696,51 +557,32 @@ instance (Reflex t, Num a) => Num (Behavior t a) where

696 negate = fmap negate

557 negate = fmap negate

697 signum = fmap signum

558 signum = fmap signum

698

559

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

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

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

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

710 sconcat = pull . fmap sconcat . mapM sample

562 sconcat = pull . fmap sconcat . mapM sample

563+#if MIN_VERSION_semigroups(0,17,0)

711 stimes n = fmap $ stimes n

564 stimes n = fmap $ stimes n

565+#else

566+ times1p n = fmap $ times1p n

567+#endif

712

568

713−-- | Alias for 'mapMaybe'

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

715−fmapMaybe = mapMaybe

716−

717−-- | Flipped version of 'mapMaybe'.

569+-- | Flipped version of 'fmapMaybe'.

718−fforMaybe :: Filterable f => f a -> (a -> Maybe b) -> f b

570+fforMaybe :: FunctorMaybe f => f a -> (a -> Maybe b) -> f b

719−fforMaybe = flip mapMaybe

571+fforMaybe = flip fmapMaybe

720

572

721-- | Filter 'f a' using the provided predicate.

573-- | Filter 'f a' using the provided predicate.

574+-- Relies on 'fforMaybe'.

722−ffilter :: Filterable f => (a -> Bool) -> f a -> f a

575+ffilter :: FunctorMaybe f => (a -> Bool) -> f a -> f a

723−ffilter = W.filter

576+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

577

733-- | Left-biased event union (prefers left event on simultaneous

578-- | Left-biased event union (prefers left event on simultaneous

734-- occurrence).

579-- occurrence).

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

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

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

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

737

582

738−-- | 'Event' intersection. Only occurs when both events are co-incident.

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

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

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

740− evf <.> evx = mapMaybe f (align evf evx) where

585+ evf <.> evx = coincidence (fmap (<$> evx) evf)

741− f (These g a) = Just (g a)

742− f _ = Nothing

743−

744

586

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

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

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

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

@@ -749,18 +591,11 @@ instance Reflex t => Bind (Event t) where

749

591

750instance Reflex t => Functor (Event t) where

592instance Reflex t => Functor (Event t) where

751 {-# INLINE fmap #-}

593 {-# INLINE fmap #-}

752− fmap f = mapMaybe $ Just . f

594+ fmap f = fmapMaybe $ Just . f

753− {-# INLINE (<$) #-}

754− x <$ e = fmapCheap (const x) e

755

595

756−-- TODO Remove this instance

757instance Reflex t => FunctorMaybe (Event t) where

596instance Reflex t => FunctorMaybe (Event t) where

758 {-# INLINE fmapMaybe #-}

597 {-# INLINE fmapMaybe #-}

759− fmapMaybe = mapMaybe

760−

761−instance Reflex t => Filterable (Event t) where

762− {-# INLINE mapMaybe #-}

763− mapMaybe f = push $ return . f

598+ fmapMaybe f = push $ return . f

764

599

765-- | Never: @'zero' = 'never'@.

600-- | Never: @'zero' = 'never'@.

766instance Reflex t => Plus (Event t) where

601instance Reflex t => Plus (Event t) where

@@ -771,13 +606,7 @@ instance Reflex t => Plus (Event t) where

771tag :: Reflex t => Behavior t b -> Event t a -> Event t b

606tag :: Reflex t => Behavior t b -> Event t a -> Event t b

772tag b = pushAlways $ \_ -> sample b

607tag b = pushAlways $ \_ -> sample b

773

608

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

609+-- | Create a new 'Event' that combines occurences of supplied 'Event' with the

781-- current value of the 'Behavior'.

610-- current value of the 'Behavior'.

782attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b)

611attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b)

783attach = attachWith (,)

612attach = attachWith (,)

@@ -787,118 +616,61 @@ attach = attachWith (,)

787attachWith :: Reflex t => (a -> b -> c) -> Behavior t a -> Event t b -> Event t c

616attachWith :: Reflex t => (a -> b -> c) -> Behavior t a -> Event t b -> Event t c

788attachWith f = attachWithMaybe $ \a b -> Just $ f a b

617attachWith f = attachWithMaybe $ \a b -> Just $ f a b

789

618

790−-- | Create a new 'Event' by combining each occurrence with the current value of

619+-- | 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

620-- the 'Behavior'. The occurrence is discarded if the combining function returns

792-- Nothing

621-- Nothing

793attachWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c

622attachWithMaybe :: 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

623attachWithMaybe f b e = flip push e $ \o -> (`f` o) <$> sample b

795

624

625+-- | Create a new 'Event' that only occurs only once, on the first occurence of

626+-- the supplied 'Event'.

627+headE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)

628+headE e = do

629+ rec be <- hold e $ fmap (const never) e'

630+ let e' = switch be

631+ return e'

632+

796−-- | Create a new 'Event' that occurs on all but the first occurrence of the

633+-- | Create a new 'Event' that occurs on all but the first occurence of the

797-- supplied 'Event'.

634-- supplied 'Event'.

798−tailE :: (Reflex t, MonadHold t m) => Event t a -> m (Event t a)

635+tailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)

799tailE e = snd <$> headTailE e

636tailE e = snd <$> headTailE e

800

637

801−-- | Create a tuple of two 'Event's with the first one occurring only the first

638+-- | 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

639+-- time the supplied 'Event' occurs and the second occuring on all but the first

803−-- occurrence.

640+-- occurence.

804−headTailE :: (Reflex t, MonadHold t m) => Event t a -> m (Event t a, Event t a)

641+headTailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a, Event t a)

805headTailE e = do

642headTailE e = do

806 eHead <- headE e

643 eHead <- headE e

807 be <- hold never $ fmap (const e) eHead

644 be <- hold never $ fmap (const e) eHead

808 return (eHead, switch be)

645 return (eHead, switch be)

809

646

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

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

648+-- which the given predicate returns 'True'. When 'False' is returned, do not

815−-- do not fire, and permanently stop firing, even if 'True' values would have

649+-- fire, and permanently stop firing, even if 'True' values are encountered

816−-- been encountered later.

650+-- later.

817−takeWhileE

818− :: forall t m a

819− . (Reflex t, MonadFix m, MonadHold t m)

651+takeWhileE :: forall t m a. (Reflex t, MonadFix m, MonadHold t m) => (a -> Bool) -> Event t a -> m (Event t a)

820− => (a -> Bool)

652+takeWhileE f e = do

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

653+ rec let (eFalse, eTrue) = fanEither $ ffor e' $ \a -> if f a

654+ then Right a

840− Nothing -> Left never

655+ else Left never

841− Just b -> Right b

656+ be <- hold e eFalse

842− eFirstBad <- headE eBad

657+ let e' = switch be

843− e' <- switchHold e eFirstBad

844 return eTrue

658 return eTrue

845

659

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

660+-- | Split the supplied 'Event' into two individual 'Event's occuring at the

889-- same time with the respective values from the tuple.

661-- same time with the respective values from the tuple.

890splitE :: Reflex t => Event t (a, b) -> (Event t a, Event t b)

662splitE :: Reflex t => Event t (a, b) -> (Event t a, Event t b)

891splitE e = (fmap fst e, fmap snd e)

663splitE e = (fmap fst e, fmap snd e)

892

664

893-- | Print the supplied 'String' and the value of the 'Event' on each

665-- | Print the supplied 'String' and the value of the 'Event' on each

894−-- occurrence. This should /only/ be used for debugging.

666+-- occurence. This should /only/ be used for debugging.

895--

667--

896-- Note: As with Debug.Trace.trace, the message will only be printed if the

668-- Note: As with Debug.Trace.trace, the message will only be printed if the

897-- 'Event' is actually used.

669-- 'Event' is actually used.

898traceEvent :: (Reflex t, Show a) => String -> Event t a -> Event t a

670traceEvent :: (Reflex t, Show a) => String -> Event t a -> Event t a

899traceEvent s = traceEventWith $ \x -> s <> ": " <> show x

671traceEvent s = traceEventWith $ \x -> s <> ": " <> show x

900

672

901−-- | Print the output of the supplied function on each occurrence of the

673+-- | Print the output of the supplied function on each occurence of the

902-- 'Event'. This should /only/ be used for debugging.

674-- 'Event'. This should /only/ be used for debugging.

903--

675--

904-- Note: As with Debug.Trace.trace, the message will only be printed if the

676-- Note: As with Debug.Trace.trace, the message will only be printed if the

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

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

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

910 (<>) = alignWith (mergeThese (<>))

682 (<>) = alignWith (mergeThese (<>))

911 sconcat = fmap sconcat . mergeList . toList

683 sconcat = fmap sconcat . mergeList . toList

684+#if MIN_VERSION_semigroups(0,17,0)

912 stimes n = fmap $ stimes n

685 stimes n = fmap $ stimes n

686+#else

687+ times1p n = fmap $ times1p n

688+#endif

913

689

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

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

915 mempty = never

691 mempty = never

@@ -925,9 +701,10 @@ mergeWith = mergeWith' id

925

701

926{-# INLINE mergeWith' #-}

702{-# INLINE mergeWith' #-}

927mergeWith' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b

703mergeWith' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b

928−mergeWith' f g es = fmap (Prelude.foldl1 g . fmap f)

704+mergeWith' f g es = fmap (Prelude.foldl1 g . map (\(Const2 _ :=> Identity v) -> f v) . DMap.toList)

929− . mergeInt

705+ . merge

930− . IntMap.fromDistinctAscList

706+ . DMap.fromDistinctAscList

707+ . map (\(k, v) -> Const2 k :=> v)

931 $ zip [0 :: Int ..] es

708 $ zip [0 :: Int ..] es

932

709

933-- | Create a new 'Event' that occurs if at least one of the 'Event's in the

710-- | Create a new 'Event' that occurs if at least one of the 'Event's in the

@@ -938,38 +715,25 @@ leftmost :: Reflex t => [Event t a] -> Event t a

938leftmost = mergeWith const

715leftmost = mergeWith const

939

716

940-- | Create a new 'Event' that occurs if at least one of the 'Event's in the

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

718+-- list occurs and has a list of the values of all 'Event's occuring at that

942-- time.

719-- time.

943mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a)

720mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a)

944mergeList [] = never

721mergeList [] = never

945mergeList es = mergeWithFoldCheap' id es

722mergeList es = mergeWithFoldCheap' id es

946

723

947−unsafeMapIncremental

948− :: (Reflex t, Patch p, Patch p')

949− => (PatchTarget p -> PatchTarget p')

724+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

725unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ g <$> updatedIncremental a

954

726

955-- | Create a new 'Event' combining the map of 'Event's into an 'Event' that

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

728-- occurs if at least one of them occurs and has a map of values of all 'Event's

957−-- occurring at that time.

729+-- occuring at that time.

958mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a)

730mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a)

959mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap

731mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap

960

732

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

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

734mergeMapIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Event t a)) -> Event t (Map k a)

967mergeMapIncremental = fmap dmapToMap . mergeIncremental . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWith id)

735mergeMapIncremental = fmap dmapToMap . mergeIncremental . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWith id)

968

736

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

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

738mergeMapIncrementalWithMove :: (Reflex t, Ord k) => Incremental t (PatchMapWithMove k (Event t a)) -> Event t (Map k a)

975mergeMapIncrementalWithMove = fmap dmapToMap . mergeIncrementalWithMove . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWithMoveWith id)

739mergeMapIncrementalWithMove = fmap dmapToMap . mergeIncrementalWithMove . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWithMoveWith id)

@@ -979,7 +743,7 @@ fanEither :: Reflex t => Event t (Either a b) -> (Event t a, Event t b)

979fanEither e =

743fanEither e =

980 let justLeft = either Just (const Nothing)

744 let justLeft = either Just (const Nothing)

981 justRight = either (const Nothing) Just

745 justRight = either (const Nothing) Just

982− in (mapMaybe justLeft e, mapMaybe justRight e)

746+ in (fmapMaybe justLeft e, fmapMaybe justRight e)

983

747

984-- | Split the event into separate events for 'This' and 'That' values,

748-- | Split the event into separate events for 'This' and 'That' values,

985-- allowing them to fire simultaneously when the input value is 'These'.

749-- allowing them to fire simultaneously when the input value is 'These'.

@@ -991,141 +755,47 @@ fanThese e =

991 that (That y) = Just y

755 that (That y) = Just y

992 that (These _ y) = Just y

756 that (These _ y) = Just y

993 that _ = Nothing

757 that _ = Nothing

994− in (mapMaybe this e, mapMaybe that e)

758+ in (fmapMaybe this e, fmapMaybe that e)

995

759

996-- | Split the event into an 'EventSelector' that allows efficient selection of

760-- | Split the event into an 'EventSelector' that allows efficient selection of

997-- the individual 'Event's.

761-- the individual 'Event's.

998fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a)

762fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a)

999fanMap = fan . fmap mapToDMap

763fanMap = fan . fmap mapToDMap

1000

764

1001−-- | Switches to the new event whenever it receives one. Only the old event is

765+-- | 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

766+-- 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.

767+-- 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)

768+switchPromptly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)

1023−switchHoldPromptly ea0 eea = do

769+switchPromptly ea0 eea = do

1024 bea <- hold ea0 eea

770 bea <- hold ea0 eea

1025 let eLag = switch bea

771 let eLag = switch bea

1026 eCoincidences = coincidence eea

772 eCoincidences = coincidence eea

1027 return $ leftmost [eCoincidences, eLag]

773 return $ leftmost [eCoincidences, eLag]

1028

774

1029−-- | switches to a new event whenever it receives one. At the moment of

775+-- | '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

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

777-- used if it fires; this is the opposite of 'switch', which will use only the

1032-- old value.

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

779+switchPromptOnly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)

1039−switchHoldPromptOnly e0 e' = do

780+switchPromptOnly e0 e' = do

1040 eLag <- switch <$> hold e0 e'

781 eLag <- switch <$> hold e0 e'

1041 return $ coincidence $ leftmost [e', eLag <$ eLag]

782 return $ coincidence $ leftmost [e', eLag <$ eLag]

1042

783

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

784instance Reflex t => Align (Event t) where

1095 nil = never

785 nil = never

1096−#if MIN_VERSION_these(0, 8, 0)

1097−instance Reflex t => Semialign (Event t) where

1098−#endif

1099 align = alignEventWithMaybe Just

786 align = alignEventWithMaybe Just

1100

787

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

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

1116−-- the 'Behavior' is true at the time of occurrence.

789+-- the 'Behavior' is true at the time of occurence.

1117gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a

790gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a

1118gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing

791gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing

1119

792

1120−-- | Create a new behavior given a starting behavior and switch to the behavior

793+-- | Create a new behavior given a starting behavior and switch to a the behvior

1121−-- carried by the event when it fires.

794+-- carried by the event when it fires.

1122switcher :: (Reflex t, MonadHold t m)

795switcher :: (Reflex t, MonadHold t m)

1123 => Behavior t a -> Event t (Behavior t a) -> m (Behavior t a)

796 => Behavior t a -> Event t (Behavior t a) -> m (Behavior t a)

1124switcher b eb = pull . (sample <=< sample) <$> hold b eb

797switcher b eb = pull . (sample <=< sample) <$> hold b eb

1125

798

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)

799-- | Combine two 'Dynamic's. The result will change whenever either (or both)

1130-- input 'Dynamic' changes. Equivalent to @zipDynWith (,)@.

800-- input 'Dynamic' changes. Equivalent to @zipDynWith (,)@.

1131zipDyn :: Reflex t => Dynamic t a -> Dynamic t b -> Dynamic t (a, b)

801zipDyn :: Reflex t => Dynamic t a -> Dynamic t b -> Dynamic t (a, b)

@@ -1133,7 +803,7 @@ zipDyn = zipDynWith (,)

1133

803

1134-- | Combine two 'Dynamic's with a combining function. The result will change

804-- | Combine two 'Dynamic's with a combining function. The result will change

1135-- whenever either (or both) input 'Dynamic' changes.

805-- whenever either (or both) input 'Dynamic' changes.

1136−-- More efficient than 'liftA2'.

806+-- More efficient than liftA2.

1137zipDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> Dynamic t c

807zipDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> Dynamic t c

1138zipDynWith f da db =

808zipDynWith f da db =

1139 let eab = align (updated da) (updated db)

809 let eab = align (updated da) (updated db)

@@ -1149,10 +819,6 @@ zipDynWith f da db =

1149 return $ Just $ f a b

819 return $ Just $ f a b

1150 in unsafeBuildDynamic (f <$> sample (current da) <*> sample (current db)) ec

820 in unsafeBuildDynamic (f <$> sample (current da) <*> sample (current db)) ec

1151

821

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

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

1157 mconcat = distributeListOverDynWith mconcat

823 mconcat = distributeListOverDynWith mconcat

1158 mempty = constDyn mempty

824 mempty = constDyn mempty

@@ -1160,23 +826,14 @@ instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where

1160

826

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

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

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

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

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

829+-- 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)

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

1165−distributeDMapOverDynPure = distributeDMapOverDynPureG coerceDynamic

831+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

832 [] -> constDyn DMap.empty

1176− [k :=> v] -> DMap.singleton k <$> nt v

833+ [k :=> v] -> fmap (DMap.singleton k . Identity) v

1177 _ ->

834 _ ->

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

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

1179− edmPre = mergeG getCompose $ DMap.map (Compose . updated . nt) dm

836+ edmPre = merge $ DMap.map updated dm

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

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

1181 olds <- sample $ current result

838 olds <- sample $ current result

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

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

@@ -1188,73 +845,21 @@ distributeListOverDyn = distributeListOverDynWith id

1188

845

1189-- | Create a new 'Dynamic' by applying a combining function to a list of 'Dynamic's

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

847distributeListOverDynWith :: Reflex t => ([a] -> b) -> [Dynamic t a] -> Dynamic t b

1191−distributeListOverDynWith f =

848+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

849

1202-- | Create a new 'Event' that occurs when the first supplied 'Event' occurs

850-- | Create a new 'Event' that occurs when the first supplied 'Event' occurs

1203-- unless the second supplied 'Event' occurs simultaneously.

851-- unless the second supplied 'Event' occurs simultaneously.

1204difference :: Reflex t => Event t a -> Event t b -> Event t a

852difference :: Reflex t => Event t a -> Event t b -> Event t a

1205difference = alignEventWithMaybe $ \case

853difference = alignEventWithMaybe $ \case

1206 This a -> Just a

854 This a -> Just a

1207− _ -> Nothing

855+ _ -> Nothing

1208

856

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

857alignEventWithMaybe :: Reflex t => (These a b -> Maybe c) -> Event t a -> Event t b -> Event t c

1212−alignEventWithMaybe f ea eb = mapMaybe (f <=< dmapToThese) $

858+alignEventWithMaybe f ea eb =

859+ fmapMaybe (f <=< dmapToThese)

860+ $ merge

1213− merge $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]

861+ $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]

1214−

862+

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

863

1259--------------------------------------------------------------------------------

864--------------------------------------------------------------------------------

1260-- Accumulator

865-- Accumulator

@@ -1262,12 +867,6 @@ factorEvent k0 kv' = do

1262

867

1263-- | An 'Accumulator' type can be built by accumulating occurrences of an

868-- | An 'Accumulator' type can be built by accumulating occurrences of an

1264-- 'Event'.

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

870class 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)

871 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

872 accum f = accumMaybe $ \v o -> Just $ f v o

@@ -1284,239 +883,61 @@ class Reflex t => Accumulator t f | f -> t where

1284 mapAccumMaybe f = mapAccumMaybeM $ \v o -> return $ f v o

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

884 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

885

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

886-- | Accumulate occurrences of an 'Event', producing an output occurrence each

1475-- time. Discard the underlying 'Accumulator'.

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

888mapAccum_ :: 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

889mapAccum_ f z e = do

1479− (_, result) <- mapAccumB f z e

890+ (_ :: Behavior t a, result) <- mapAccum f z e

1480 return result

891 return result

1481

892

1482-- | Accumulate occurrences of an 'Event', possibly producing an output

893-- | Accumulate occurrences of an 'Event', possibly producing an output

1483-- occurrence each time. Discard the underlying 'Accumulator'.

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

895mapAccumMaybe_ :: 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

896mapAccumMaybe_ f z e = do

1487− (_, result) <- mapAccumMaybeB f z e

897+ (_ :: Behavior t a, result) <- mapAccumMaybe f z e

1488 return result

898 return result

1489

899

1490-- | Accumulate occurrences of an 'Event', using a 'PushM' action and producing

900-- | Accumulate occurrences of an 'Event', using a 'PushM' action and producing

1491-- an output occurrence each time. Discard the underlying 'Accumulator'.

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

902mapAccumM_ :: 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

903mapAccumM_ f z e = do

1495− (_, result) <- mapAccumMB f z e

904+ (_ :: Behavior t a, result) <- mapAccumM f z e

1496 return result

905 return result

1497

906

1498-- | Accumulate occurrences of an 'Event', using a 'PushM' action and possibly

907-- | Accumulate occurrences of an 'Event', using a 'PushM' action and possibly

1499-- producing an output occurrence each time. Discard the underlying

908-- producing an output occurrence each time. Discard the underlying

1500-- 'Accumulator'.

909-- '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)

910mapAccumMaybeM_ :: 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

911mapAccumMaybeM_ f z e = do

1504− (_, result) <- mapAccumMaybeMB f z e

912+ (_ :: Behavior t a, result) <- mapAccumMaybeM f z e

1505 return result

913 return result

1506

914

1507instance Reflex t => Accumulator t (Dynamic t) where

915instance Reflex t => Accumulator t (Dynamic t) where

1508− accumMaybeM = accumMaybeMDyn

916+ accumMaybeM f z e = do

917+ rec let e' = flip push e $ \o -> do

918+ v <- sample $ current d'

919+ f v o

920+ d' <- holdDyn z e'

921+ return d'

1509− mapAccumMaybeM = mapAccumMaybeMDyn

922+ mapAccumMaybeM f z e = do

923+ rec let e' = flip push e $ \o -> do

924+ v <- sample $ current d'

925+ result <- f v o

926+ return $ case result of

927+ (Nothing, Nothing) -> Nothing

928+ _ -> Just result

929+ d' <- holdDyn z $ fmapMaybe fst e'

930+ return (d', fmapMaybe snd e')

1510

931

1511instance Reflex t => Accumulator t (Behavior t) where

932instance Reflex t => Accumulator t (Behavior t) where

1512− accumMaybeM = accumMaybeMB

933+ accumMaybeM f z e = current <$> accumMaybeM f z e

1513− mapAccumMaybeM = mapAccumMaybeMB

934+ mapAccumMaybeM f z e = first current <$> mapAccumMaybeM f z e

1514

935

1515instance Reflex t => Accumulator t (Event t) where

936instance Reflex t => Accumulator t (Event t) where

1516 accumMaybeM f z e = updated <$> accumMaybeM f z e

937 accumMaybeM f z e = updated <$> accumMaybeM f z e

1517 mapAccumMaybeM f z e = first updated <$> mapAccumMaybeM f z e

938 mapAccumMaybeM f z e = first updated <$> mapAccumMaybeM f z e

1518

939

1519−-- | Create a new 'Event' by combining each occurrence with the next value of the

940+-- | 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

941-- list using the supplied function. If the list runs out of items, all

1521-- subsequent 'Event' occurrences will be ignored.

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

943zipListWithEvent :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> c) -> [a] -> Event t b -> m (Event t c)

@@ -1526,27 +947,20 @@ zipListWithEvent f l e = do

1526 _ -> (Nothing, Nothing) --TODO: Unsubscribe the event?

947 _ -> (Nothing, Nothing) --TODO: Unsubscribe the event?

1527 mapAccumMaybe_ f' l e

948 mapAccumMaybe_ f' l e

1528

949

1529−-- | Assign a number to each occurrence of the given 'Event', starting from 0

950+-- | Assign a number to each occurence of the given 'Event', starting from 0

1530−{-# INLINE numberOccurrences #-}

1531numberOccurrences :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Event t (b, a))

951numberOccurrences :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Event t (b, a))

1532numberOccurrences = numberOccurrencesFrom 0

952numberOccurrences = numberOccurrencesFrom 0

1533

953

1534−-- | Assign a number to each occurrence of the given 'Event'

954+-- | Assign a number to each occurence of the given 'Event'

1535−{-# INLINE numberOccurrencesFrom #-}

1536numberOccurrencesFrom :: (Reflex t, MonadHold t m, MonadFix m, Num b) => b -> Event t a -> m (Event t (b, a))

955numberOccurrencesFrom :: (Reflex t, MonadHold t m, MonadFix m, Num b) => b -> Event t a -> m (Event t (b, a))

1537−numberOccurrencesFrom = mapAccum_ (\n a -> let !next = n + 1 in (next, (n, a)))

956+numberOccurrencesFrom = mapAccum_ (\n a -> (n + 1, (n, a)))

1538−

1539−-- | Assign a number to each occurrence of the given 'Event'; discard the occurrences' values

1540−{-# INLINE numberOccurrencesFrom_ #-}

1541−numberOccurrencesFrom_ :: (Reflex t, MonadHold t m, MonadFix m, Num b) => b -> Event t a -> m (Event t b)

1542−numberOccurrencesFrom_ = mapAccum_ (\n _ -> let !next = n + 1 in (next, n))

1543

957

1544-- | This is used to sample the value of a 'Behavior' using an 'Event'.

958-- | This is used to sample the value of a 'Behavior' using an 'Event'.

1545--

959--

1546−-- The '<@>' operator is intended to be used in conjunction with

960+-- The '<@>' operator is intended to be used in conjunction with

1547-- the 'Applicative' instance for 'Behavior'.

961-- the 'Applicative' instance for 'Behavior'.

1548--

962--

1549−-- This is useful when we want to combine the values of one 'Event' and

963+-- This is useful when we want to combine the values of one 'Event' and

1550-- the value of several 'Behavior's at the time the 'Event' is firing.

964-- the value of several 'Behavior's at the time the 'Event' is firing.

1551--

965--

1552-- If we have:

966-- If we have:

@@ -1566,7 +980,7 @@ numberOccurrencesFrom_ = mapAccum_ (\n _ -> let !next = n + 1 in (next, n))

1566--

980--

1567-- > attachWith (\(x1, x2) y -> f x1 x2 y) ((,) <$> b1 <*> b2) e :: Event t d

981-- > attachWith (\(x1, x2) y -> f x1 x2 y) ((,) <$> b1 <*> b2) e :: Event t d

1568--

982--

1569−-- or a variation involing a custom data type to hold the combination of

983+-- 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'.

984-- 'Behavior's even when that combination might only ever be used by 'f'.

1571--

985--

1572-- A more suggestive example might be:

986-- A more suggestive example might be:

@@ -1583,8 +997,8 @@ infixl 4 <@>

1583--

997--

1584-- Alternatively, it is 'tag' in operator form.

998-- Alternatively, it is 'tag' in operator form.

1585--

999--

1586−-- This is useful when we want to combine the values of several

1000+-- This is useful when we want to combine the values of several

1587−-- 'Behavior's at particular points in time using an 'Applicative'

1001+-- 'Behavior's at particular points in time using an 'Applicative'

1588-- style syntax.

1002-- style syntax.

1589--

1003--

1590-- If we have:

1004-- If we have:

@@ -1595,105 +1009,120 @@ infixl 4 <@>

1595-- > e :: Event t c

1009-- > e :: Event t c

1596--

1010--

1597-- where 'e' is firing at the points in time of interest.

1011-- where 'e' is firing at the points in time of interest.

1598−--

1012+--

1599-- Then we can use '<@':

1013-- Then we can use '<@':

1600--

1014--

1601-- > g <$> b1 <*> b2 <@ e :: Event t d

1015-- > g <$> b1 <*> b2 <@ e :: Event t d

1602--

1016--

1603−-- to combine the values of 'b1' and 'b2' at each of those points of time,

1017+-- 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.

1018-- with the function 'g' being used to combine the values.

1605--

1019--

1606-- This is the same as '<@>' except that the 'Event' is being used only

1020-- This is the same as '<@>' except that the 'Event' is being used only

1607−-- to act as a trigger.

1021+-- to act as a trigger.

1608(<@) :: (Reflex t) => Behavior t b -> Event t a -> Event t b

1022(<@) :: (Reflex t) => Behavior t b -> Event t a -> Event t b

1609(<@) = tag

1023(<@) = tag

1610infixl 4 <@

1024infixl 4 <@

1611

1025

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

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

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

1029+-- is some issue here with persistent side-effects: obviously, IO (and some

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

1031+-- to determine what the best meaning for this class is in such cases.

1032+class (Reflex t, Monad m) => MonadAdjust t m | m -> t where

1033+ runWithReplace :: m a -> Event t (m b) -> m (a, Event t b)

1034+ 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'))

1035+ 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'))

1036+

1037+instance MonadAdjust t m => MonadAdjust t (ReaderT r m) where

1038+ runWithReplace a0 a' = do

1039+ r <- ask

1040+ lift $ runWithReplace (runReaderT a0 r) $ fmap (`runReaderT` r) a'

1041+ traverseDMapWithKeyWithAdjust f dm0 dm' = do

1042+ r <- ask

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

1044+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do

1045+ r <- ask

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

1047+

1048+sequenceDMapWithAdjust :: (GCompare k, MonadAdjust t m) => DMap k m -> Event t (PatchDMap k m) -> m (DMap k Identity, Event t (PatchDMap k Identity))

1049+sequenceDMapWithAdjust = traverseDMapWithKeyWithAdjust $ \_ -> fmap Identity

1050+

1051+sequenceDMapWithAdjustWithMove :: (GCompare k, MonadAdjust t m) => DMap k m -> Event t (PatchDMapWithMove k m) -> m (DMap k Identity, Event t (PatchDMapWithMove k Identity))

1052+sequenceDMapWithAdjustWithMove = traverseDMapWithKeyWithAdjustWithMove $ \_ -> fmap Identity

1053+

1054+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'))

1055+mapMapWithAdjustWithMove f m0 m' = do

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

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

1058+

1612------------------

1059------------------

1613-- Cheap Functions

1060-- Cheap Functions

1614------------------

1061------------------

1615

1062

1616−-- | A "cheap" version of 'pushAlways'. See the performance note on 'pushCheap'.

1617{-# INLINE pushAlwaysCheap #-}

1063{-# INLINE pushAlwaysCheap #-}

1618pushAlwaysCheap :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b

1064pushAlwaysCheap :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b

1619pushAlwaysCheap f = pushCheap (fmap Just . f)

1065pushAlwaysCheap f = pushCheap (fmap Just . f)

1620

1066

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 #-}

1067{-# INLINE fmapMaybeCheap #-}

1628fmapMaybeCheap :: Reflex t => (a -> Maybe b) -> Event t a -> Event t b

1068fmapMaybeCheap :: Reflex t => (a -> Maybe b) -> Event t a -> Event t b

1629−fmapMaybeCheap = mapMaybeCheap

1069+fmapMaybeCheap f = pushCheap $ return . f

1630−

1631

1070

1632−-- | A "cheap" version of 'fforMaybe'. See the performance note on 'pushCheap'.

1633{-# INLINE fforMaybeCheap #-}

1071{-# INLINE fforMaybeCheap #-}

1634fforMaybeCheap :: Reflex t => Event t a -> (a -> Maybe b) -> Event t b

1072fforMaybeCheap :: Reflex t => Event t a -> (a -> Maybe b) -> Event t b

1635−fforMaybeCheap = flip mapMaybeCheap

1073+fforMaybeCheap = flip fmapMaybeCheap

1636

1074

1637−-- | A "cheap" version of 'ffor'. See the performance note on 'pushCheap'.

1638{-# INLINE fforCheap #-}

1075{-# INLINE fforCheap #-}

1639fforCheap :: Reflex t => Event t a -> (a -> b) -> Event t b

1076fforCheap :: Reflex t => Event t a -> (a -> b) -> Event t b

1640fforCheap = flip fmapCheap

1077fforCheap = flip fmapCheap

1641

1078

1642−-- | A "cheap" version of 'fmap'. See the performance note on 'pushCheap'.

1643{-# INLINE fmapCheap #-}

1079{-# INLINE fmapCheap #-}

1644fmapCheap :: Reflex t => (a -> b) -> Event t a -> Event t b

1080fmapCheap :: Reflex t => (a -> b) -> Event t a -> Event t b

1645fmapCheap f = pushCheap $ return . Just . f

1081fmapCheap f = pushCheap $ return . Just . f

1646

1082

1647−-- | A "cheap" version of 'tag'. See the performance note on 'pushCheap'.

1648{-# INLINE tagCheap #-}

1083{-# INLINE tagCheap #-}

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

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

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

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

1651

1086

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 #-}

1087{-# INLINE mergeWithCheap #-}

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

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

1672mergeWithCheap = mergeWithCheap' id

1089mergeWithCheap = mergeWithCheap' id

1673

1090

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

1675{-# INLINE mergeWithCheap' #-}

1091{-# INLINE mergeWithCheap' #-}

1676mergeWithCheap' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b

1092mergeWithCheap' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b

1677mergeWithCheap' f g = mergeWithFoldCheap' $ foldl1 g . fmap f

1093mergeWithCheap' f g = mergeWithFoldCheap' $ foldl1 g . fmap f

1678

1094

1679−-- | A "cheap" version of 'mergeWithFoldCheap''. See the performance note on 'pushCheap'.

1680{-# INLINE mergeWithFoldCheap' #-}

1095{-# INLINE mergeWithFoldCheap' #-}

1681mergeWithFoldCheap' :: Reflex t => (NonEmpty a -> b) -> [Event t a] -> Event t b

1096mergeWithFoldCheap' :: Reflex t => (NonEmpty a -> b) -> [Event t a] -> Event t b

1682mergeWithFoldCheap' f es =

1097mergeWithFoldCheap' f es =

1683− fmapCheap (f . (\(h : t) -> h :| t) . IntMap.elems)

1098+ fmapCheap (f . (\(h : t) -> h :| t) . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList)

1684− . mergeInt

1099+ . merge

1685− . IntMap.fromDistinctAscList

1100+ . DMap.fromDistinctAscList

1101+ . map (\(k, v) -> Const2 k :=> v)

1686 $ zip [0 :: Int ..] es

1102 $ zip [0 :: Int ..] es

1687

1103

1688--------------------------------------------------------------------------------

1104--------------------------------------------------------------------------------

1689-- Deprecated functions

1105-- Deprecated functions

1690--------------------------------------------------------------------------------

1106--------------------------------------------------------------------------------

1691

1107

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'. " #-}

1108+-- | Create a new 'Event' that occurs if at least one of the supplied 'Event's

1693−-- | See 'switchHoldPromptly'

1109+-- occurs. If both occur at the same time they are combined using 'mappend'.

1110+{-# 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)

1111+appendEvents :: (Reflex t, Monoid a) => Event t a -> Event t a -> Event t a

1695−switchPromptly = switchHoldPromptly

1112+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'. " #-}

1113+

1697−-- | See 'switchHoldPromptOnly'

1114+-- | Alias for 'headE'

1698−switchPromptOnly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)

1115+{-# DEPRECATED onceE "Use 'headE' instead" #-}

1699−switchPromptOnly = switchHoldPromptOnly

1116+onceE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)

1117+onceE = headE

1118+

1119+-- | Run both sides of a 'These' monadically, combining the results.

1120+{-# DEPRECATED sequenceThese "Use bisequenceA or bisequence from the bifunctors package instead" #-}

1121+#ifdef USE_TEMPLATE_HASKELL

1122+{-# ANN sequenceThese "HLint: ignore Use fmap" #-}

1123+#endif

1124+sequenceThese :: Monad m => These (m a) (m b) -> m (These a b)

1125+sequenceThese t = case t of

1126+ This ma -> fmap This ma

1127+ These ma mb -> liftM2 These ma mb

1128+ 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+227−114

@@ -17,32 +17,23 @@

17#ifdef USE_REFLEX_OPTIMIZER

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

19#endif

20−-- |

21−-- Module:

22−-- Reflex.Dynamic

23−-- Description:

24−-- This module contains various functions for working with 'Dynamic' values.

20+-- | This module contains various functions for working with 'Dynamic' values.

25−-- 'Dynamic' and its primitives have been moved to the 'Reflex' class.

21+-- 'Dynamic' and its primitives have been moved to the 'Reflex' class.

26module Reflex.Dynamic

22module Reflex.Dynamic

27 ( -- * Basics

23 ( -- * Basics

28 Dynamic -- Abstract so we can preserve the law that the current value is always equal to the most recent update

24 Dynamic -- Abstract so we can preserve the law that the current value is always equal to the most recent update

29 , current

25 , current

30 , updated

26 , updated

31 , holdDyn

27 , holdDyn

32− , mapDynM

33− , forDynM

34 , constDyn

28 , constDyn

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

36 , maybeDyn

44− , eitherDyn

45− , factorDyn

46 , scanDyn

37 , scanDyn

47 , scanDynMaybe

38 , scanDynMaybe

48 , holdUniqDyn

39 , holdUniqDyn

@@ -53,18 +44,15 @@ module Reflex.Dynamic

53 , foldDynMaybe

44 , foldDynMaybe

54 , foldDynMaybeM

45 , foldDynMaybeM

55 , joinDynThroughMap

46 , joinDynThroughMap

56− , joinDynThroughIntMap

57 , traceDyn

47 , traceDyn

58 , traceDynWith

48 , traceDynWith

59 , splitDynPure

49 , splitDynPure

60 , distributeMapOverDynPure

50 , distributeMapOverDynPure

61− , distributeIntMapOverDynPure

62 , distributeDMapOverDynPure

51 , distributeDMapOverDynPure

63 , distributeListOverDynPure

52 , distributeListOverDynPure

64 , Demux

53 , Demux

65 , demux

54 , demux

66 , demuxed

55 , demuxed

67− -- * Miscellaneous

68 -- Things that probably aren't very useful:

56 -- Things that probably aren't very useful:

69 , HList (..)

57 , HList (..)

70 , FHList (..)

58 , FHList (..)

@@ -74,14 +62,35 @@ module Reflex.Dynamic

74 , AllAreFunctors (..)

62 , AllAreFunctors (..)

75 , HListPtr (..)

63 , HListPtr (..)

76 , distributeFHListOverDynPure

64 , distributeFHListOverDynPure

77− -- * Unsafe

65+ -- Unsafe

78 , unsafeDynamic

66 , unsafeDynamic

67+ -- * Deprecated functions

68+ , apDyn

69+ , attachDyn

70+ , attachDynWith

71+ , attachDynWithMaybe

72+ , collectDyn

73+ , combineDyn

74+ , distributeDMapOverDyn

75+ , distributeFHListOverDyn

76+ , forDyn

77+ , forDynM

78+ , getDemuxed

79+ , joinDyn

80+ , mapDyn

81+ , mapDynM

82+ , mconcatDyn

83+ , nubDyn

84+ , splitDyn

85+ , tagDyn

86+ , uniqDyn

87+ , uniqDynBy

79 ) where

88 ) where

81−import Data.Functor.Compose

82import Data.Functor.Misc

90import Data.Functor.Misc

83import Reflex.Class

91import Reflex.Class

93+import Control.Applicative ((<*>))

85import Control.Monad

94import Control.Monad

86import Control.Monad.Fix

95import Control.Monad.Fix

87import Control.Monad.Identity

96import Control.Monad.Identity

@@ -89,25 +98,14 @@ import Data.Align

89import Data.Dependent.Map (DMap)

98import Data.Dependent.Map (DMap)

90import qualified Data.Dependent.Map as DMap

99import qualified Data.Dependent.Map as DMap

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

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

92−import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))

101+import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), GOrdering (..))

93−import Data.IntMap (IntMap)

94−import qualified Data.IntMap as IntMap

95import Data.Map (Map)

102import Data.Map (Map)

96import Data.Maybe

103import Data.Maybe

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

104+import Data.Monoid

98import Data.These

105import Data.These

99−import Data.Type.Equality ((:~:) (..))

100

106

101import Debug.Trace

107import Debug.Trace

102

108

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

109-- | Create a new 'Dynamic' that only signals changes if the values actually

112-- changed.

110-- changed.

113holdUniqDyn :: (Reflex t, MonadHold t m, MonadFix m, Eq a) => Dynamic t a -> m (Dynamic t a)

111holdUniqDyn :: (Reflex t, MonadHold t m, MonadFix m, Eq a) => Dynamic t a -> m (Dynamic t a)

@@ -119,7 +117,7 @@ holdUniqDyn = holdUniqDynBy (==)

119holdUniqDynBy :: (Reflex t, MonadHold t m, MonadFix m) => (a -> a -> Bool) -> Dynamic t a -> m (Dynamic t a)

117holdUniqDynBy :: (Reflex t, MonadHold t m, MonadFix m) => (a -> a -> Bool) -> Dynamic t a -> m (Dynamic t a)

120holdUniqDynBy eq = scanDynMaybe id (\new old -> if new `eq` old then Nothing else Just new)

118holdUniqDynBy eq = scanDynMaybe id (\new old -> if new `eq` old then Nothing else Just new)

121

119

122−-- | @/Dynamic Maybe/@ that can only update from @/Nothing/@ to @/Just/@ or @/Just/@ to @/Just/@ (i.e., cannot revert to @/Nothing/@)

120+-- | Dynamic Maybe that can only update from Nothing to Just or Just to Just (i.e., cannot revert to Nothing)

123improvingMaybe :: (Reflex t, MonadHold t m, MonadFix m) => Dynamic t (Maybe a) -> m (Dynamic t (Maybe a))

121improvingMaybe :: (Reflex t, MonadHold t m, MonadFix m) => Dynamic t (Maybe a) -> m (Dynamic t (Maybe a))

124improvingMaybe = scanDynMaybe id (\new _ -> if isJust new then Just new else Nothing)

122improvingMaybe = scanDynMaybe id (\new _ -> if isJust new then Just new else Nothing)

125

123

@@ -142,12 +140,12 @@ scanDynMaybe z f d = do

142-- 'Event' occurs using a folding function on the previous value and the value

140-- 'Event' occurs using a folding function on the previous value and the value

143-- of the 'Event'.

141-- of the 'Event'.

144foldDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> b) -> b -> Event t a -> m (Dynamic t b)

142foldDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> b) -> b -> Event t a -> m (Dynamic t b)

145−foldDyn = accumDyn . flip

143+foldDyn = accum . flip

146

144

147-- | Like 'foldDyn', but the combining function is a 'PushM' action, so it

145-- | Like 'foldDyn', but the combining function is a 'PushM' action, so it

148-- can 'sample' existing 'Behaviors' and 'hold' new ones.

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

147foldDynM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t b) -> b -> Event t a -> m (Dynamic t b)

150−foldDynM = accumMDyn . flip

148+foldDynM = accumM . flip

151

149

152-- | Create a 'Dynamic' using the provided initial value and change it each time

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

151-- the provided 'Event' occurs, using a function to combine the old value with

@@ -156,14 +154,14 @@ foldDynM = accumMDyn . flip

156-- 'Dynamic''s 'updated' 'Event' will fire in the 'Just' case, and will not fire

154-- 'Dynamic''s 'updated' 'Event' will fire in the 'Just' case, and will not fire

157-- in the 'Nothing' case.

155-- in the 'Nothing' case.

158foldDynMaybe :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe b) -> b -> Event t a -> m (Dynamic t b)

156foldDynMaybe :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe b) -> b -> Event t a -> m (Dynamic t b)

159−foldDynMaybe = accumMaybeDyn . flip

157+foldDynMaybe = accumMaybe . flip

160

158

161-- | Like 'foldDynMaybe', but the combining function is a 'PushM' action, so it

159-- | Like 'foldDynMaybe', but the combining function is a 'PushM' action, so it

162-- can 'sample' existing 'Behaviors' and 'hold' new ones.

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

161foldDynMaybeM :: (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

162+foldDynMaybeM = accumMaybeM . flip

165

163

166−-- | Create a new 'Dynamic' that counts the occurrences of the 'Event'.

164+-- | 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)

165count :: (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

166count e = holdDyn 0 =<< zipListWithEvent const (iterate (+1) 1) e

169

167

@@ -172,25 +170,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)

170toggle :: (Reflex t, MonadHold t m, MonadFix m) => Bool -> Event t a -> m (Dynamic t Bool)

173toggle = foldDyn (const not)

171toggle = foldDyn (const not)

174

172

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

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

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

175-- old and new inner Events fire simultaneously, the output will fire with the

189−-- value of the __new__ 'Event'.

176+-- 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

177switchPromptlyDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a

195switchPromptlyDyn de =

178switchPromptlyDyn de =

196 let eLag = switch $ current de

179 let eLag = switch $ current de

@@ -206,30 +189,28 @@ splitDynPure d = (fmap fst d, fmap snd d)

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

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

207distributeMapOverDynPure = fmap dmapToMap . distributeDMapOverDynPure . mapWithFunctorToDMap

190distributeMapOverDynPure = fmap dmapToMap . distributeDMapOverDynPure . mapWithFunctorToDMap

208

191

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

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

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

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

216−{-# DEPRECATED distributeListOverDynPure "Use 'distributeListOverDyn' instead" #-}

217distributeListOverDynPure :: Reflex t => [Dynamic t v] -> Dynamic t [v]

194distributeListOverDynPure :: Reflex t => [Dynamic t v] -> Dynamic t [v]

218−distributeListOverDynPure = distributeListOverDyn

195+distributeListOverDynPure =

196+ fmap (map fromDSum . DMap.toAscList) .

197+ distributeDMapOverDynPure .

198+ DMap.fromDistinctAscList .

199+ zipWith toDSum [0..]

200+ where

201+ toDSum :: Int -> Dynamic t a -> DSum (Const2 Int a) (Dynamic t)

202+ toDSum k v = Const2 k :=> v

203+ fromDSum :: DSum (Const2 Int a) Identity -> a

204+ fromDSum (Const2 _ :=> Identity v) = v

219

205

220--TODO: Generalize this to functors other than Maps

206--TODO: Generalize this to functors other than Maps

221-- | Combine a 'Dynamic' of a 'Map' of 'Dynamic's into a 'Dynamic'

207-- | Combine a 'Dynamic' of a 'Map' of 'Dynamic's into a 'Dynamic'

222-- with the current values of the 'Dynamic's in a map.

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

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

224−joinDynThroughMap = (distributeMapOverDynPure =<<)

210+joinDynThroughMap = joinDyn . fmap distributeMapOverDynPure

225−

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

211

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

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

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

213+-- subsequent change that is observed (as traceEvent), prefixed with the

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

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

234--

215--

235-- Note: Just like Debug.Trace.trace, the value will only be shown if something

216-- Note: Just like Debug.Trace.trace, the value will only be shown if something

@@ -239,7 +220,7 @@ traceDyn s = traceDynWith $ \x -> s <> ": " <> show x

239

220

240-- | Print the result of applying the provided function to the value

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

222-- of the 'Dynamic' when it is first read and on each subsequent change

242−-- that is observed (as 'traceEvent'). This should /only/ be used for

223+-- that is observed (as traceEvent). This should /only/ be used for

243-- debugging.

224-- debugging.

244--

225--

245-- Note: Just like Debug.Trace.trace, the value will only be shown if something

226-- Note: Just like Debug.Trace.trace, the value will only be shown if something

@@ -255,35 +236,36 @@ traceDynWith f d =

255-- | Replace the value of the 'Event' with the current value of the 'Dynamic'

236-- | Replace the value of the 'Event' with the current value of the 'Dynamic'

256-- each time the 'Event' occurs.

237-- each time the 'Event' occurs.

257--

238--

258−-- Note: @/tagPromptlyDyn d e/@ differs from @/tag (current d) e/@ in the case that @/e/@ is firing

239+-- 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/@

240+-- 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

241+-- 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.

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

243-- 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__

244+-- 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.__

245+-- cyclic data flows, generally `tag (current d) e` is preferred.

265tagPromptlyDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a

246tagPromptlyDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a

266tagPromptlyDyn = attachPromptlyDynWith const

247tagPromptlyDyn = attachPromptlyDynWith const

267

248

268-- | Attach the current value of the 'Dynamic' to the value of the

249-- | Attach the current value of the 'Dynamic' to the value of the

269-- 'Event' each time it occurs.

250-- 'Event' each time it occurs.

270--

251--

271−-- Note: @/attachPromptlyDyn d/@ is not the same as @/attach (current d)/@. See 'tagPromptlyDyn' for details.

252+-- 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)

253attachPromptlyDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b)

273attachPromptlyDyn = attachPromptlyDynWith (,)

254attachPromptlyDyn = attachPromptlyDynWith (,)

274

255

275-- | Combine the current value of the 'Dynamic' with the value of the

256-- | Combine the current value of the 'Dynamic' with the value of the

276-- 'Event' each time it occurs.

257-- 'Event' each time it occurs.

277--

258--

278−-- Note: @/attachPromptlyDynWith f d/@ is not the same as @/attachWith f (current d)/@. See 'tagPromptlyDyn' for details.

259+-- 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

260attachPromptlyDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c

280attachPromptlyDynWith f = attachPromptlyDynWithMaybe $ \a b -> Just $ f a b

261attachPromptlyDynWith f = attachPromptlyDynWithMaybe $ \a b -> Just $ f a b

281

262

282−-- | Create a new 'Event' by combining the value at each occurrence with the

263+-- | 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

264-- current value of the 'Dynamic' value and possibly filtering if the combining

284-- function returns 'Nothing'.

265-- function returns 'Nothing'.

285--

266--

286−-- Note: @/attachPromptlyDynWithMaybe f d/@ is not the same as @/attachWithMaybe f (current d)/@. See 'tagPromptlyDyn' for details.

267+-- Note: `attachPromptlyDynWithMaybe f d` is not the same as `attachWithMaybe f

268+-- (current d)`. See 'tagPromptlyDyn' for details.

287attachPromptlyDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c

269attachPromptlyDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c

288attachPromptlyDynWithMaybe f d e =

270attachPromptlyDynWithMaybe f d e =

289 let e' = attach (current d) e

271 let e' = attach (current d) e

@@ -292,48 +274,23 @@ attachPromptlyDynWithMaybe f d e =

292 These (_, b) a -> f a b -- Both events are firing, so use the newer value

274 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

275 That _ -> Nothing -- The tagging event isn't firing, so don't fire

294

276

295−-- | Factor a @/Dynamic t (Maybe a)/@ into a @/Dynamic t (Maybe (Dynamic t a))/@,

277+-- | 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

278+-- 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

279-- chages from 'Nothing' to 'Just' or vice-versa. Whenever the constructor

298-- becomes 'Just', an inner 'Dynamic' will be provided, whose value will track

280-- becomes 'Just', an inner 'Dynamic' will be provided, whose value will track

299-- the 'a' inside the 'Just'; when the constructor becomes 'Nothing', the

281-- the 'a' inside the 'Just'; when the constructor becomes 'Nothing', the

300-- existing inner 'Dynamic' will become constant, and will not change when the

282-- existing inner 'Dynamic' will become constant, and will not change when the

301-- outer constructor changes back to 'Nothing'.

283-- outer constructor changes back to 'Nothing'.

302maybeDyn :: forall t a m. (Reflex t, MonadFix m, MonadHold t m) => Dynamic t (Maybe a) -> m (Dynamic t (Maybe (Dynamic t a)))

284maybeDyn :: 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

285+maybeDyn d = do

304− where pack = \case

286+ ma <- sample $ current d

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

287+ let inner :: forall m'. (MonadFix m', MonadHold t m') => a -> m' (Dynamic t a)

314−eitherDyn = fmap (fmap unpack) . factorDyn . fmap eitherToDSum

288+ inner a = holdDyn a . fmapMaybe id =<< takeWhileE isJust (updated d)

315− where unpack :: DSum (EitherTag a b) (Compose (Dynamic t) Identity) -> Either (Dynamic t a) (Dynamic t b)

289+ mInner0 :: Maybe (Dynamic t a) <- mapM inner ma

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

290+ rec result <- holdDyn mInner0 $ flip push (updated d) $ \new -> do

328− (oldKey :=> _) <- sample (current d)

291+ old <- sample $ current d

329− case newKey `geq` oldKey of

292+ if isJust old == isJust new then return Nothing else Just <$> mapM inner new

330− Just Refl -> return Nothing

293+ return result

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

294

338--------------------------------------------------------------------------------

295--------------------------------------------------------------------------------

339-- Demux

296-- Demux

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

348--

305--

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

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

350--

307--

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

308+-- However, the when getDemuxed is used multiple times, the complexity is only

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

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

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

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

354 , demuxSelector :: EventSelector t (Const2 k Bool)

311 , demuxSelector :: EventSelector t (Const2 k Bool)

@@ -418,12 +375,21 @@ data FHList f l where

418 FHCons :: f e -> FHList f l -> FHList f (e ': l)

375 FHCons :: f e -> FHList f l -> FHList f (e ': l)

419

376

420instance GEq (HListPtr l) where

377instance GEq (HListPtr l) where

378+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

379+ geqToEq _ = id

380+ geqUnify HHeadPtr HHeadPtr _ same = same

381+ geqUnify (HTailPtr a) (HTailPtr b) different same = geqUnify a b different same

382+ geqUnify _ _ different _ = different

383+#endif

421 HHeadPtr `geq` HHeadPtr = Just Refl

384 HHeadPtr `geq` HHeadPtr = Just Refl

422 HHeadPtr `geq` HTailPtr _ = Nothing

385 HHeadPtr `geq` HTailPtr _ = Nothing

423 HTailPtr _ `geq` HHeadPtr = Nothing

386 HTailPtr _ `geq` HHeadPtr = Nothing

424 HTailPtr a `geq` HTailPtr b = a `geq` b

387 HTailPtr a `geq` HTailPtr b = a `geq` b

425

388

426instance GCompare (HListPtr l) where -- Warning: This ordering can't change, dmapTo*HList will break

389instance GCompare (HListPtr l) where -- Warning: This ordering can't change, dmapTo*HList will break

390+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

391+ gcompareToOrd _ = id

392+#endif

427 HHeadPtr `gcompare` HHeadPtr = GEQ

393 HHeadPtr `gcompare` HHeadPtr = GEQ

428 HHeadPtr `gcompare` HTailPtr _ = GLT

394 HHeadPtr `gcompare` HTailPtr _ = GLT

429 HTailPtr _ `gcompare` HHeadPtr = GGT

395 HTailPtr _ `gcompare` HHeadPtr = GGT

@@ -502,7 +468,7 @@ instance AllAreFunctors f t => AllAreFunctors f (h ': t) where

502

468

503-- | Convert a datastructure whose constituent parts are all 'Dynamic's into a

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

470-- single 'Dynamic' whose value represents all the current values of the input's

505−-- constituent 'Dynamic's.

471+-- consitutent 'Dynamic's.

506collectDynPure :: ( RebuildSortedHList (HListElems b)

472collectDynPure :: ( RebuildSortedHList (HListElems b)

507 , IsHList a, IsHList b

473 , IsHList a, IsHList b

508 , AllAreFunctors (Dynamic t) (HListElems b)

474 , AllAreFunctors (Dynamic t) (HListElems b)

@@ -543,3 +509,150 @@ instance IsHList (a, b, c, d, e, f) where

543#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800

509#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

510 _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139

545#endif

511#endif

512+

513+--------------------------------------------------------------------------------

514+-- Deprecated functions

515+--------------------------------------------------------------------------------

516+

517+-- | Map a function over a 'Dynamic'.

518+{-# DEPRECATED mapDyn "Use 'return . fmap f' instead of 'mapDyn f'; consider eliminating monadic style" #-}

519+mapDyn :: (Reflex t, Monad m) => (a -> b) -> Dynamic t a -> m (Dynamic t b)

520+mapDyn f = return . fmap f

521+

522+-- | 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.

523+{-# DEPRECATED mapDynM "Consider using the Monad instance for Dynamic instead." #-}

524+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)

525+mapDynM f d = do

526+ let e' = push (fmap Just . f :: a -> PushM t (Maybe b)) $ updated d

527+ eb' = fmap constant e'

528+ v0 = pull $ f =<< sample (current d)

529+ bb' :: Behavior t (Behavior t b) <- hold v0 eb'

530+ let b' = pull $ sample =<< sample bb'

531+ return $ unsafeDynamic b' e'

532+

533+-- | Flipped version of 'mapDyn'.

534+{-# DEPRECATED forDyn "Use 'return . ffor a' instead of 'forDyn a'; consider eliminating monadic style" #-}

535+forDyn :: (Reflex t, Monad m) => Dynamic t a -> (a -> b) -> m (Dynamic t b)

536+forDyn a = return . ffor a

537+

538+-- | Flipped version of 'mapDynM'

539+{-# DEPRECATED forDynM "Consider using the Monad instance for Dynamic instead." #-}

540+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)

541+forDynM d f = mapDynM f d

542+

543+-- | Split the 'Dynamic' into two 'Dynamic's, each taking the respective value

544+-- of the tuple.

545+{-# DEPRECATED splitDyn "Use 'return . splitDynPure' instead; consider eliminating monadic style" #-}

546+splitDyn :: (Reflex t, Monad m) => Dynamic t (a, b) -> m (Dynamic t a, Dynamic t b)

547+splitDyn = return . splitDynPure

548+

549+-- | Merge the 'Dynamic' values using their 'Monoid' instance.

550+{-# DEPRECATED mconcatDyn "Use 'return . mconcat' instead; consider eliminating monadic style" #-}

551+mconcatDyn :: forall t m a. (Reflex t, Monad m, Monoid a) => [Dynamic t a] -> m (Dynamic t a)

552+mconcatDyn = return . mconcat

553+

554+-- | This function no longer needs to be monadic; see 'distributeMapOverDynPure'.

555+{-# DEPRECATED distributeDMapOverDyn "Use 'return . distributeDMapOverDynPure' instead; consider eliminating monadic style" #-}

556+distributeDMapOverDyn :: (Reflex t, Monad m, GCompare k) => DMap k (Dynamic t) -> m (Dynamic t (DMap k Identity))

557+distributeDMapOverDyn = return . distributeDMapOverDynPure

558+

559+-- | Merge two 'Dynamic's into a new one using the provided function. The new

560+-- 'Dynamic' changes its value each time one of the original 'Dynamic's changes

561+-- its value.

562+{-# DEPRECATED combineDyn "Use 'return (zipDynWith f a b)' instead of 'combineDyn f a b'; consider eliminating monadic style" #-}

563+combineDyn :: forall t m a b c. (Reflex t, Monad m) => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> m (Dynamic t c)

564+combineDyn f a b = return $ zipDynWith f a b

565+

566+-- | A psuedo applicative version of ap for 'Dynamic'. Example useage:

567+--

568+-- > do

569+-- > person <- Person `mapDyn` dynFirstName

570+-- > `apDyn` dynListName

571+-- > `apDyn` dynAge

572+-- > `apDyn` dynAddress

573+{-# 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" #-}

574+#ifdef USE_TEMPLATE_HASKELL

575+{-# ANN apDyn "HLint: ignore Use fmap" #-}

576+#endif

577+apDyn :: forall t m a b. (Reflex t, Monad m)

578+ => m (Dynamic t (a -> b))

579+ -> Dynamic t a

580+ -> m (Dynamic t b)

581+apDyn m a = fmap (<*> a) m

582+

583+--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

584+-- | This function no longer needs to be monadic, so it has been replaced by

585+-- 'demuxed', which is pure.

586+{-# DEPRECATED getDemuxed "Use 'return . demuxed d' instead of 'getDemuxed d'; consider eliminating monadic style" #-}

587+getDemuxed :: (Reflex t, Monad m, Eq k) => Demux t k -> k -> m (Dynamic t Bool)

588+getDemuxed d = return . demuxed d

589+

590+-- | This function no longer needs to be monadic, so it has been replaced by

591+-- 'distributeFHListOverDynPure', which is pure.

592+{-# DEPRECATED distributeFHListOverDyn "Use 'return . distributeFHListOverDynPure' instead; consider eliminating monadic style" #-}

593+distributeFHListOverDyn :: forall t m l. (Reflex t, Monad m, RebuildSortedHList l) => FHList (Dynamic t) l -> m (Dynamic t (HList l))

594+distributeFHListOverDyn = return . distributeFHListOverDynPure

595+

596+-- | This function no longer needs to be monadic, so it has been replaced by

597+-- 'collectDynPure', which is pure.

598+{-# DEPRECATED collectDyn "Use 'return . collectDynPure' instead; consider eliminating monadic style" #-}

599+collectDyn :: ( RebuildSortedHList (HListElems b)

600+ , IsHList a, IsHList b

601+ , AllAreFunctors (Dynamic t) (HListElems b)

602+ , Reflex t, Monad m

603+ , HListElems a ~ FunctorList (Dynamic t) (HListElems b)

604+ ) => a -> m (Dynamic t b)

605+collectDyn = return . collectDynPure

606+

607+-- | This function has been renamed to 'tagPromptlyDyn' to clarify its

608+-- semantics.

609+{-# DEPRECATED tagDyn "Use 'tagPromptlyDyn' instead" #-}

610+tagDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a

611+tagDyn = tagPromptlyDyn

612+

613+-- | This function has been renamed to 'attachPromptlyDyn' to clarify its

614+-- semantics.

615+{-# DEPRECATED attachDyn "Use 'attachPromptlyDyn' instead" #-}

616+attachDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b)

617+attachDyn = attachPromptlyDyn

618+

619+-- | This function has been renamed to 'attachPromptlyDynWith' to clarify its

620+-- semantics.

621+{-# DEPRECATED attachDynWith "Use 'attachPromptlyDynWith' instead" #-}

622+attachDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c

623+attachDynWith = attachPromptlyDynWith

624+

625+-- | This function has been renamed to 'attachPromptlyDynWithMaybe' to clarify

626+-- its semantics.

627+{-# DEPRECATED attachDynWithMaybe "Use 'attachPromptlyDynWithMaybe' instead" #-}

628+attachDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c

629+attachDynWithMaybe = attachPromptlyDynWithMaybe

630+

631+-- | Combine an inner and outer 'Dynamic' such that the resulting 'Dynamic''s

632+-- current value will always be equal to the current value's current value, and

633+-- will change whenever either the inner or the outer (or both) values change.

634+{-# DEPRECATED joinDyn "Use 'join' instead" #-}

635+joinDyn :: Reflex t => Dynamic t (Dynamic t a) -> Dynamic t a

636+joinDyn = join

637+

638+-- | WARNING: This function is only pure if @a@'s 'Eq' instance tests

639+-- representational equality. Use 'holdUniqDyn' instead, which is pure in all

640+-- circumstances. Also, note that, unlike 'nub', this function does not prevent

641+-- all recurrences of a value, only consecutive recurrences.

642+{-# DEPRECATED nubDyn "Use 'holdUniqDyn' instead; note that it returns a MonadHold action rather than a pure Dynamic" #-}

643+nubDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a

644+nubDyn = uniqDyn

645+

646+-- | WARNING: This function is only pure if @a@'s 'Eq' instance tests

647+-- representational equality. Use 'holdUniqDyn' instead, which is pure in all

648+-- circumstances.

649+{-# DEPRECATED uniqDyn "Use 'holdUniqDyn' instead; note that it returns a MonadHold action rather than a pure Dynamic" #-}

650+uniqDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a

651+uniqDyn = uniqDynBy (==)

652+

653+-- | WARNING: This function is impure. Use 'holdUniqDynBy' instead.

654+{-# DEPRECATED uniqDynBy "Use 'holdUniqDynBy' instead; note that it returns a MonadHold action rather than a pure Dynamic" #-}

655+uniqDynBy :: Reflex t => (a -> a -> Bool) -> Dynamic t a -> Dynamic t a

656+uniqDynBy eq d =

657+ let e' = attachWithMaybe (\x x' -> if x' `eq` x then Nothing else Just x') (current d) (updated d)

658+ in unsafeDynamic (current d) e'

src/Reflex/Dynamic/TH.hs+28−4

@@ -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,7 +84,7 @@ 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

@@ -104,3 +107,24 @@ mkDynExp s = case Hs.parseExpWithMode Hs.defaultParseMode { Hs.extensions = [ Hs

104 reinstateUnqDyn (TH.Name (TH.OccName occName') (TH.NameQ (TH.ModName modName')))

107 reinstateUnqDyn (TH.Name (TH.OccName occName') (TH.NameQ (TH.ModName modName')))

105 | modName == modName' && occName == occName' = 'unqMarker

108 | modName == modName' && occName == occName' = 'unqMarker

106 reinstateUnqDyn x = x

109 reinstateUnqDyn x = x

110+

111+--------------------------------------------------------------------------------

112+-- Deprecated

113+--------------------------------------------------------------------------------

114+

115+{-# DEPRECATED qDyn "Instead of $(qDyn x), use return $(qDynPure x)" #-}

116+-- | Like 'qDynPure', but wraps its result monadically using 'return'. This is

117+-- no longer necessary, due to 'Dynamic' being an instance of 'Functor'.

118+qDyn :: Q Exp -> Q Exp

119+qDyn qe = [| return $(qDynPure qe) |]

120+

121+{-# DEPRECATED mkDyn "Instead of [mkDyn| x |], use return [mkDynPure| x |]" #-}

122+-- | Like 'mkDynPure', but wraps its result monadically using 'return'. This is

123+-- no longer necessary, due to 'Dynamic' being an instance of 'Functor'.

124+mkDyn :: QuasiQuoter

125+mkDyn = QuasiQuoter

126+ { quoteExp = \s -> [| return $(mkDynExp s) |]

127+ , quotePat = error "mkDyn: pattern splices are not supported"

128+ , quoteType = error "mkDyn: type splices are not supported"

129+ , quoteDec = error "mkDyn: declaration splices are not supported"

130+ }

src/Reflex/Dynamic/Uniq.hs+3−3

@@ -31,7 +31,7 @@ newtype UniqDynamic t a = UniqDynamic { unUniqDynamic :: Dynamic t a }

32-- | Construct a 'UniqDynamic' by eliminating redundant updates from a 'Dynamic'.

33uniqDynamic :: Reflex t => Dynamic t a -> UniqDynamic t a

34−uniqDynamic d = UniqDynamic $ unsafeBuildDynamic (sample $ current d) $ flip pushCheap (updated d) $ \new -> do

34+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 return $ unsafeJustChanged old new

@@ -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+188−4

@@ -1,7 +1,191 @@

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 qualified Reflex.Patch.MapWithMove as MapWithMove

42+import Reflex.PerformEvent.Class

43+import Reflex.PostBuild.Class

44+import Reflex.Requester.Class

45+import Reflex.TriggerEvent.Class

46+

47+instance MonadTrans (DynamicWriterT t w) where

48+ lift = DynamicWriterT . lift

49+

50+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')

51+mapIncrementalMapValues f = unsafeMapIncremental (fmap f) (fmap f)

52+

53+mergeDynIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Dynamic t v)) -> Incremental t (PatchMap k v)

54+mergeDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues

55+ where changedValues = fmap (PatchMap . fmap Just) $ mergeMapIncremental $ mapIncrementalMapValues updated a

56+ addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchMap m) -> PatchMap <$> mapM (mapM (sample . current)) m

57+

58+mergeDynIncrementalWithMove :: forall t k v. (Reflex t, Ord k) => Incremental t (PatchMapWithMove k (Dynamic t v)) -> Incremental t (PatchMapWithMove k v)

59+mergeDynIncrementalWithMove a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ alignWith f addedAndRemovedValues changedValues

60+ where changedValues = mergeMapIncrementalWithMove $ mapIncrementalMapValues updated a

61+ addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ fmap unsafePatchMapWithMove . mapM (mapM (sample . current)) . unPatchMapWithMove

62+ f :: These (PatchMapWithMove k v) (Map k v) -> PatchMapWithMove k v

63+ f x = unsafePatchMapWithMove $

64+ let (p, changed) = case x of

65+ This p_ -> (unPatchMapWithMove p_, mempty)

66+ That c -> (mempty, c)

67+ These p_ c -> (unPatchMapWithMove p_, c)

68+ (pWithNewVals, noLongerMoved) = flip runState [] $ forM p $ MapWithMove.nodeInfoMapMFrom $ \case

69+ MapWithMove.From_Insert v -> return $ MapWithMove.From_Insert v

70+ MapWithMove.From_Delete -> return $ MapWithMove.From_Delete

71+ MapWithMove.From_Move k -> case Map.lookup k changed of

72+ Nothing -> return $ MapWithMove.From_Move k

73+ Just v -> do

74+ modify (k:)

75+ return $ MapWithMove.From_Insert v

76+ noLongerMovedMap = Map.fromList $ fmap (\k -> (k, ())) noLongerMoved

77+ in Map.differenceWith (\e _ -> Just $ MapWithMove.nodeInfoSetTo Nothing e) pWithNewVals noLongerMovedMap --TODO: Check if any in the second map are not covered?

78+

79+-- | A basic implementation of 'MonadDynamicWriter'.

80+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

81+

82+instance MonadRef m => MonadRef (DynamicWriterT t w m) where

83+ type Ref (DynamicWriterT t w m) = Ref m

84+ newRef = lift . newRef

85+ readRef = lift . readRef

86+ writeRef r = lift . writeRef r

87+

88+instance MonadAtomicRef m => MonadAtomicRef (DynamicWriterT t w m) where

89+ atomicModifyRef r = lift . atomicModifyRef r

90+

91+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWriterT t w m) where

92+ newEventWithTrigger = lift . newEventWithTrigger

93+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

94+

95+-- | Run a 'DynamicWriterT' action. The dynamic writer output will be provided

96+-- along with the result of the action.

97+runDynamicWriterT :: (MonadFix m, Reflex t, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)

98+runDynamicWriterT (DynamicWriterT a) = do

99+ (result, ws) <- runStateT a []

100+ return (result, mconcat $ reverse ws)

101+

102+-- | 'MonadDynamicWriter' efficiently collects 'Dynamic' values using 'tellDyn'

103+-- and combines them monoidally to provide a 'Dynamic' result.

104+class (Monad m, Monoid w) => MonadDynamicWriter t w m | m -> t w where

105+ tellDyn :: Dynamic t w -> m ()

106+

107+instance (Monad m, Monoid w, Reflex t) => MonadDynamicWriter t w (DynamicWriterT t w m) where

108+ tellDyn w = DynamicWriterT $ modify (w :)

109+

110+instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where

111+ ask = lift ask

112+ local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a

113+ reader = lift . reader

114+

115+instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where

116+ type Performable (DynamicWriterT t w m) = Performable m

117+ performEvent_ = lift . performEvent_

118+ performEvent = lift . performEvent

119+

120+instance TriggerEvent t m => TriggerEvent t (DynamicWriterT t w m) where

121+ newTriggerEvent = lift newTriggerEvent

122+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

123+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

124+

125+instance PostBuild t m => PostBuild t (DynamicWriterT t w m) where

126+ getPostBuild = lift getPostBuild

127+

128+instance MonadDynamicWriter t w m => MonadDynamicWriter t w (ReaderT r m) where

129+ tellDyn = lift . tellDyn

130+

131+instance MonadState s m => MonadState s (DynamicWriterT t w m) where

132+ get = lift get

133+ put = lift . put

134+

135+newtype DynamicWriterTLoweredResult t w v a = DynamicWriterTLoweredResult (v a, Dynamic t w)

136+

137+-- | When the execution of a 'DynamicWriterT' action is adjusted using

138+-- 'MonadAdjust', the 'Dynamic' output of that action will also be updated to

139+-- match.

140+instance (MonadAdjust t m, MonadFix m, Monoid w, MonadHold t m, Reflex t) => MonadAdjust t (DynamicWriterT t w m) where

141+ runWithReplace a0 a' = do

142+ (result0, result') <- lift $ runWithReplace (runDynamicWriterT a0) $ runDynamicWriterT <$> a'

143+ tellDyn . join =<< holdDyn (snd result0) (snd <$> result')

144+ return (fst result0, fst <$> result')

145+ traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap weakenPatchDMapWith mergeDynIncremental

146+ traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove weakenPatchDMapWithMoveWith mergeDynIncrementalWithMove

147+

148+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)

149+ => ( (forall a. k a -> v a -> m (DynamicWriterTLoweredResult t w v' a))

150+ -> DMap k v

151+ -> Event t (p k v)

152+ -> m (DMap k (DynamicWriterTLoweredResult t w v'), Event t (p k (DynamicWriterTLoweredResult t w v')))

153+ )

154+ -> ((forall a. DynamicWriterTLoweredResult t w v' a -> v' a) -> p k (DynamicWriterTLoweredResult t w v') -> p k v')

155+ -> ((forall a. DynamicWriterTLoweredResult t w v' a -> Dynamic t w) -> p k (DynamicWriterTLoweredResult t w v') -> p' (Some k) (Dynamic t w))

156+ -> (Incremental t (p' (Some k) (Dynamic t w)) -> Incremental t (p' (Some k) w))

157+ -> (forall a. k a -> v a -> DynamicWriterT t w m (v' a))

158+ -> DMap k v

159+ -> Event t (p k v)

160+ -> DynamicWriterT t w m (DMap k v', Event t (p k v'))

161+traverseDMapWithKeyWithAdjustImpl base mapPatch weakenPatchWith mergeMyDynIncremental f (dm0 :: DMap k v) dm' = do

162+ (result0, result') <- lift $ base (\k v -> fmap DynamicWriterTLoweredResult $ runDynamicWriterT $ f k v) dm0 dm'

163+ let getValue (DynamicWriterTLoweredResult (v, _)) = v

164+ getWritten (DynamicWriterTLoweredResult (_, w)) = w

165+ liftedResult0 = DMap.map getValue result0

166+ liftedResult' = ffor result' $ mapPatch getValue

167+ liftedWritten0 :: Map (Some k) (Dynamic t w)

168+ liftedWritten0 = weakenDMapWith getWritten result0

169+ liftedWritten' = ffor result' $ weakenPatchWith getWritten

170+ --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics

171+ i <- holdIncremental liftedWritten0 liftedWritten'

172+ tellDyn $ fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeMyDynIncremental i

173+ return (liftedResult0, liftedResult')

174+

175+-- | Map a function over the output of a 'DynamicWriterT'.

176+withDynamicWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m, MonadFix m)

177+ => (w -> w')

178+ -> DynamicWriterT t w m a

179+ -> DynamicWriterT t w' m a

180+withDynamicWriterT f dw = do

181+ (r, d) <- lift $ do

182+ (r, d) <- runDynamicWriterT dw

183+ let d' = fmap f d

184+ return (r, d')

185+ tellDyn d

186+ return r

187+

188+instance Requester t m => Requester t (DynamicWriterT t w m) where

189+ type Request (DynamicWriterT t w m) = Request m

190+ type Response (DynamicWriterT t w m) = Response m

191+ 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+169−4

@@ -1,7 +1,172 @@

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 Data.List.NonEmpty (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, Semigroup 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, Semigroup 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, Semigroup 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, Semigroup 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 sconcat $ mergeList $ toList $ snd result0) $ fmapCheap (fmapCheap sconcat . 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, Semigroup 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 (|>) $ fforMaybeCheap (mergePatchIncremental childRequestMap) $ \m -> case toList m of

139+ [] -> Nothing

140+ h : t -> Just $ sconcat $ h :| t

141+ return (result0, result')

142+

143+instance PerformEvent t m => PerformEvent t (EventWriterT t w m) where

144+ type Performable (EventWriterT t w m) = Performable m

145+ performEvent_ = lift . performEvent_

146+ performEvent = lift . performEvent

147+

148+instance PostBuild t m => PostBuild t (EventWriterT t w m) where

149+ getPostBuild = lift getPostBuild

150+

151+instance TriggerEvent t m => TriggerEvent t (EventWriterT t w m) where

152+ newTriggerEvent = lift newTriggerEvent

153+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

154+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

155+

156+instance MonadReader r m => MonadReader r (EventWriterT t w m) where

157+ ask = lift ask

158+ local f (EventWriterT a) = EventWriterT $ mapStateT (local f) a

159+ reader = lift . reader

160+

161+instance MonadRef m => MonadRef (EventWriterT t w m) where

162+ type Ref (EventWriterT t w m) = Ref m

163+ newRef = lift . newRef

164+ readRef = lift . readRef

165+ writeRef r = lift . writeRef r

166+

167+instance MonadAtomicRef m => MonadAtomicRef (EventWriterT t w m) where

168+ atomicModifyRef r = lift . atomicModifyRef r

169+

170+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (EventWriterT t w m) where

171+ newEventWithTrigger = lift . newEventWithTrigger

172+ 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.hs+32−167

@@ -1,210 +1,75 @@

1{-# LANGUAGE CPP #-}

2−{-# LANGUAGE LambdaCase #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

4−#if GHCJS_FAST_WEAK

5{-# LANGUAGE ForeignFunctionInterface #-}

2{-# LANGUAGE ForeignFunctionInterface #-}

6{-# LANGUAGE JavaScriptFFI #-}

3{-# LANGUAGE JavaScriptFFI #-}

7−#endif

4+{-# LANGUAGE MagicHash #-}

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.

21module Reflex.FastWeak

5module Reflex.FastWeak

22 ( FastWeakTicket

6 ( FastWeakTicket

23 , FastWeak

7 , FastWeak

24− , mkFastWeakTicket

8+ , fastWeakTicket

25− , getFastWeakTicketValue

9+ , fastWeakTicketValue

26 , getFastWeakTicketWeak

10 , getFastWeakTicketWeak

27 , getFastWeakValue

11 , 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

12 ) where

38−import GHC.Exts (Any)

14+#ifdef ghcjs_HOST_OS

39−import Unsafe.Coerce

40−

41−#ifdef GHCJS_FAST_WEAK

42import GHCJS.Types

15import GHCJS.Types

16+import Unsafe.Coerce

43#else

17#else

44−import Control.Exception (evaluate)

45−import System.IO.Unsafe

46−import System.Mem.Weak

47#endif

18#endif

50−#ifdef GHCJS_FAST_WEAK

21+#ifdef ghcjs_HOST_OS

51−-- | A 'FastWeak' which has been promoted to a strong reference. 'getFastWeakTicketValue'

22+type Ref = JSVal

52−-- can be used to get the referred to value without fear of @Nothing,

23+#else

53−-- and 'getFastWeakTicketWeak' can be used to get the weak version.

24+type Ref = ()

54−--

25+#endif

55−-- Implemented by way of special support in the GHCJS RTS, @h$FastWeakTicket@.

26+

56−newtype FastWeakTicket a = FastWeakTicket JSVal

27+newtype FastWeakTicket a = FastWeakTicket Ref

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

29+newtype FastWeak a = FastWeak Ref

69-- Just designed to mirror JSVal, so that we can unsafeCoerce between the two

31-- Just designed to mirror JSVal, so that we can unsafeCoerce between the two

70data Val a = Val { unVal :: a }

32data Val a = Val { unVal :: a }

72−-- | Coerce a JSVal that represents the heap object of a value of type @a@ into a value of type @a@

34+-- Do we have a concern about accidentally retaining the ticket here?

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

35+fastWeakTicketValue :: FastWeakTicket a -> a

103−#ifdef GHCJS_FAST_WEAK

36+#ifdef ghcjs_HOST_OS

104−getFastWeakTicketValue t = do

105− v <- js_ticketVal t

37+fastWeakTicketValue t = unVal (unsafeCoerce (js_ticketVal t))

106− return $ unsafeFromRawJSVal v

107

108−foreign import javascript unsafe "$r = $1.val;" js_ticketVal :: FastWeakTicket a -> IO JSVal

39+foreign import javascript unsafe "$r = $1.val;" js_ticketVal :: FastWeakTicket a -> JSVal

109#else

40#else

110−getFastWeakTicketValue = return . _fastWeakTicket_val

41+fastWeakTicketValue = error "fastWeakTicketValue not implemented"

111#endif

42#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.

115getFastWeakValue :: FastWeak a -> IO (Maybe a)

44getFastWeakValue :: FastWeak a -> IO (Maybe a)

116−#ifdef GHCJS_FAST_WEAK

45+#ifdef ghcjs_HOST_OS

117getFastWeakValue w = do

46getFastWeakValue w = do

118 r <- js_weakVal w

47 r <- js_weakVal w

119 case js_isNull r of

48 case js_isNull r of

120 True -> return Nothing

49 True -> return Nothing

121− False -> return $ Just $ unsafeFromRawJSVal r

50+ False -> return (unsafeCoerce r)

122

123foreign import javascript unsafe "$1 === null" js_isNull :: JSVal -> Bool

52foreign import javascript unsafe "$1 === null" js_isNull :: JSVal -> Bool

124

125foreign import javascript unsafe "$r = ($1.ticket === null) ? null : $1.ticket.val;" js_weakVal :: FastWeak a -> IO JSVal

54foreign import javascript unsafe "$r = ($1.ticket === null) ? null : $1.ticket.val;" js_weakVal :: FastWeak a -> IO JSVal

126#else

55#else

127−getFastWeakValue = deRefWeak

56+getFastWeakValue = error "getFastWeakValue not implemented"

128#endif

57#endif

129

130−-- | Try to create a 'FastWeakTicket' for the given 'FastWeak' which will ensure the value referred

59+-- 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 associated FastWeak to actually be weak

131−-- remains alive. Returns @Just@ if the value hasn't been collected

60+fastWeakTicket :: a -> FastWeakTicket a

132−-- and a ticket can therefore be obtained, @Nothing@ if it's been collected.

61+#ifdef ghcjs_HOST_OS

133−getFastWeakTicket :: forall a. FastWeak a -> IO (Maybe (FastWeakTicket a))

62+fastWeakTicket v = js_fastWeakTicket (unsafeCoerce (Val v))

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

64+foreign import javascript unsafe "$r = new h$FastWeakTicket($1);" js_fastWeakTicket :: JSVal -> FastWeakTicket a

142#else

65#else

143−getFastWeakTicket w = do

66+fastWeakTicket = error "fastWeakTicket not implemented"

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

67#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

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

70+#ifdef ghcjs_HOST_OS

187−foreign import javascript unsafe "$r = $1.weak;" getFastWeakTicketWeak' :: FastWeakTicket a -> IO (FastWeak a)

71+foreign import javascript unsafe "$r = $1.weak;" getFastWeakTicketWeak :: FastWeakTicket a -> IO (FastWeak a)

188−{-# INLINE getFastWeakTicketWeak #-}

189−getFastWeakTicketWeak = getFastWeakTicketWeak'

190#else

72#else

191−getFastWeakTicketWeak = return . _fastWeakTicket_weak

73+getFastWeakTicketWeak :: FastWeakTicket a -> IO (FastWeak a)

192−#endif

74+getFastWeakTicketWeak = error "fastWeakTicketWeak not implemented"

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

75#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+33

@@ -0,0 +1,33 @@

1+-- | This module defines the 'Patch' class, which is used by Reflex to manage

2+-- changes to 'Reflex.Class.Incremental' values.

3+{-# LANGUAGE TypeFamilies #-}

4+module Reflex.Patch

5+ ( module Reflex.Patch

6+ , module X

7+ ) where

9+import Reflex.Patch.Class as X

10+import Reflex.Patch.DMap as X

11+import Reflex.Patch.DMapWithMove as X (PatchDMapWithMove, const2PatchDMapWithMoveWith, patchDMapWithMoveToPatchMapWithMoveWith, mapPatchDMapWithMove, weakenPatchDMapWithMoveWith, traversePatchDMapWithMoveWithKey, unsafePatchDMapWithMove, unPatchDMapWithMove)

12+import Reflex.Patch.Map as X

13+import Reflex.Patch.MapWithMove as X (PatchMapWithMove, patchMapWithMoveNewElements, unsafePatchMapWithMove, unPatchMapWithMove)

14+

15+import Data.Semigroup (Semigroup (..), (<>))

16+

17+---- Patches based on commutative groups

18+

19+-- | A 'Group' is a 'Monoid' where every element has an inverse.

20+class (Semigroup q, Monoid q) => Group q where

21+ negateG :: q -> q

22+ (~~) :: q -> q -> q

23+ r ~~ s = r <> negateG s

24+

25+-- | An 'Additive' 'Semigroup' is one where (<>) is commutative

26+class Semigroup q => Additive q where

27+

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

29+newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }

30+

31+instance Additive p => Patch (AdditivePatch p) where

32+ type PatchTarget (AdditivePatch p) = p

33+ apply (AdditivePatch p) q = Just $ p <> q

src/Reflex/Patch/Class.hsnew file+20

@@ -0,0 +1,20 @@

1+{-# LANGUAGE TypeFamilies #-}

2+module Reflex.Patch.Class where

4+import Control.Monad.Identity

5+import Data.Maybe

7+-- | A 'Patch' type represents a kind of change made to a datastructure.

8+class Patch p where

9+ type PatchTarget p :: *

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

11+ -- 'Nothing'.

12+ apply :: p -> PatchTarget p -> Maybe (PatchTarget p)

13+

14+applyAlways :: Patch p => p -> PatchTarget p -> PatchTarget p

15+applyAlways p t = fromMaybe t $ apply p t

16+

17+instance Patch (Identity a) where

18+ type PatchTarget (Identity a) = a

19+ apply (Identity a) _ = Just a

20+

src/Reflex/Patch/DMap.hsnew file+61

@@ -0,0 +1,61 @@

1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

2+{-# LANGUAGE LambdaCase #-}

3+{-# LANGUAGE PolyKinds #-}

4+{-# LANGUAGE Rank2Types #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

6+{-# LANGUAGE StandaloneDeriving #-}

7+{-# LANGUAGE TypeFamilies #-}

8+module Reflex.Patch.DMap where

10+import Reflex.Patch.Class

11+import Reflex.Patch.Map

12+

13+import Data.Dependent.Map (DMap, DSum (..), GCompare (..))

14+import qualified Data.Dependent.Map as DMap

15+import Data.Functor.Constant

16+import Data.Functor.Misc

17+import qualified Data.Map as Map

18+import Data.Semigroup (Semigroup (..))

19+import Data.Some (Some)

20+

21+-- | A set of changes to a 'DMap'. Any element may be inserted/updated or

22+-- deleted.

23+newtype PatchDMap k v = PatchDMap { unPatchDMap :: DMap k (ComposeMaybe v) }

24+

25+deriving instance GCompare k => Semigroup (PatchDMap k v)

26+

27+deriving instance GCompare k => Monoid (PatchDMap k v)

28+

29+instance GCompare k => Patch (PatchDMap k v) where

30+ type PatchTarget (PatchDMap k v) = DMap k v

31+ 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?

32+ where insertions = DMap.mapMaybeWithKey (const $ getComposeMaybe) diff

33+ deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getComposeMaybe) diff

34+ nothingToJust = \case

35+ Nothing -> Just $ Constant ()

36+ Just _ -> Nothing

37+

38+mapPatchDMap :: (forall a. v a -> v' a) -> PatchDMap k v -> PatchDMap k v'

39+mapPatchDMap f (PatchDMap p) = PatchDMap $ DMap.map (ComposeMaybe . fmap f . getComposeMaybe) p

40+

41+traversePatchDMap :: Applicative m => (forall a. v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v')

42+traversePatchDMap f = traversePatchDMapWithKey $ const f

43+

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

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

46+

47+weakenPatchDMapWith :: (forall a. v a -> v') -> PatchDMap k v -> PatchMap (Some k) v'

48+weakenPatchDMapWith f (PatchDMap p) = PatchMap $ weakenDMapWith (fmap f . getComposeMaybe) p

49+

50+patchDMapToPatchMapWith :: (f v -> v') -> PatchDMap (Const2 k v) f -> PatchMap k v'

51+patchDMapToPatchMapWith f (PatchDMap p) = PatchMap $ dmapToMapWith (fmap f . getComposeMaybe) p

52+

53+const2PatchDMapWith :: forall k v f a. (v -> f a) -> PatchMap k v -> PatchDMap (Const2 k a) f

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

55+ where g :: (k, Maybe v) -> DSum (Const2 k a) (ComposeMaybe f)

56+ g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)

57+

58+-- | Get the values that will be deleted if the given patch is applied to the

59+-- given 'DMap'. Includes values that will be replaced.

60+getDeletions :: GCompare k => PatchDMap k v -> DMap k v' -> DMap k v'

61+getDeletions (PatchDMap p) m = DMap.intersectionWithKey (\_ v _ -> v) m p

src/Reflex/Patch/DMapWithMove.hsnew file+281

@@ -0,0 +1,281 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE GADTs #-}

5+{-# LANGUAGE LambdaCase #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE PatternGuards #-}

8+{-# LANGUAGE PolyKinds #-}

9+{-# LANGUAGE Rank2Types #-}

10+{-# LANGUAGE ScopedTypeVariables #-}

11+{-# LANGUAGE TypeFamilies #-}

12+{-# LANGUAGE UndecidableInstances #-}

13+module Reflex.Patch.DMapWithMove where

14+

15+import Reflex.Patch.Class

16+import Reflex.Patch.MapWithMove (PatchMapWithMove (..))

17+import qualified Reflex.Patch.MapWithMove as MapWithMove

18+

19+import Data.Dependent.Map (DMap, DSum (..), GCompare (..))

20+import qualified Data.Dependent.Map as DMap

21+import Data.Dependent.Sum (EqTag (..))

22+import Data.Functor.Constant

23+import Data.Functor.Misc

24+import Data.Functor.Product

25+import Data.GADT.Compare (GEq (..))

26+import qualified Data.Map as Map

27+import Data.Maybe

28+import Data.Semigroup (Semigroup (..), (<>))

29+import Data.Some (Some)

30+import qualified Data.Some as Some

31+import Data.These

32+

33+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

34+import Data.Dependent.Sum (ShowTag (..))

35+import Data.GADT.Show (GShow (..))

36+import Data.Typeable (Proxy (..))

37+#endif

38+

39+-- | Like 'PatchMapWithMove', but for 'DMap'.

40+newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))

41+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

42+ deriving (Show)

43+#endif

44+

45+data NodeInfo k v a = NodeInfo

46+ { _nodeInfo_from :: !(From k v a)

47+ , _nodeInfo_to :: !(To k a)

48+ }

49+ deriving (Show)

50+

51+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

52+instance {-# INCOHERENT #-} (GShow k, ShowTag k v) => ShowTag k (NodeInfo k v) where

53+ showTagToShow k _ r = gshowToShow k $ showTagToShow k (Proxy :: Proxy v) r

54+

55+instance {-# INCOHERENT #-} (GEq k, EqTag k v) => EqTag k (From k v) where

56+ eqTagToEq k _ r = eqTagToEq k (Proxy :: Proxy v) (geqToEq k r)

57+#endif

58+

59+data From (k :: a -> *) (v :: a -> *) :: a -> * where

60+ From_Insert :: v a -> From k v a

61+ From_Delete :: From k v a

62+ From_Move :: !(k a) -> From k v a

63+ deriving (Show, Read, Eq, Ord)

64+

65+type To = ComposeMaybe

66+

67+validPatchDMapWithMove :: forall k v. (GCompare k, EqTag k (ComposeMaybe k)) => PatchDMapWithMove k v -> Bool

68+validPatchDMapWithMove (PatchDMapWithMove m) = src == srcFromDst

69+ where

70+ src = DMap.map _nodeInfo_to m

71+ dst = DMap.map _nodeInfo_from m

72+ srcFromDst :: DMap k (ComposeMaybe k)

73+ srcFromDst = DMap.fromList $ flip fmap (DMap.toList dst) $ \(to :=> edit) -> case edit of

74+ From_Move from -> from :=> ComposeMaybe (Just to)

75+ _ -> to :=> ComposeMaybe Nothing

76+

77+instance EqTag k (NodeInfo k v) => Eq (PatchDMapWithMove k v) where

78+ PatchDMapWithMove a == PatchDMapWithMove b = a == b

79+

80+data Pair1 f g a = Pair1 (f a) (g a)

81+

82+instance GCompare k => Semigroup (PatchDMapWithMove k v) where

83+ (<>) = mappend

84+

85+data Fixup k v a

86+ = Fixup_Delete

87+ | Fixup_Update (These (From k v a) (To k a))

88+

89+instance GCompare k => Monoid (PatchDMapWithMove k v) where

90+ mempty = PatchDMapWithMove mempty

91+ PatchDMapWithMove ma `mappend` PatchDMapWithMove mb = PatchDMapWithMove m

92+ where

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

94+ h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)]

95+ h (_ :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case (mToAfter, editBefore) of

96+ (Just toAfter, From_Move fromBefore)

97+ | isJust $ fromBefore `geq` toAfter

98+ -> [toAfter :=> Fixup_Delete]

99+ | otherwise

100+ -> [ toAfter :=> Fixup_Update (This editBefore)

101+ , fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))

102+ ]

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

104+ (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)]

105+ (Nothing, _) -> []

106+ mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete

107+ mergeFixups _ (Fixup_Update a) (Fixup_Update b)

108+ | This x <- a, That y <- b

109+ = Fixup_Update $ These x y

110+ | That y <- a, This x <- b

111+ = Fixup_Update $ These x y

112+ mergeFixups _ _ _ = error "PatchDMapWithMove: incompatible fixups"

113+ fixups = DMap.fromListWithKey mergeFixups $ concatMap h connections

114+ combineNodeInfos _ nia nib = NodeInfo

115+ { _nodeInfo_from = _nodeInfo_from nia

116+ , _nodeInfo_to = _nodeInfo_to nib

117+ }

118+ applyFixup _ ni = \case

119+ Fixup_Delete -> Nothing

120+ Fixup_Update u -> Just $ NodeInfo

121+ { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u

122+ , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u

123+ }

124+ m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups

125+

126+getHere :: These a b -> Maybe a

127+getHere = \case

128+ This a -> Just a

129+ These a _ -> Just a

130+ That _ -> Nothing

131+

132+getThere :: These a b -> Maybe b

133+getThere = \case

134+ This _ -> Nothing

135+ These _ b -> Just b

136+ That b -> Just b

137+

138+{-

139+mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v

140+PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src

141+ where

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

143+ removeRedundantDst toKey (From_Move fromKey) | isJust (toKey `geq` fromKey) = Nothing

144+ removeRedundantDst _ a = Just a

145+ f :: forall a. k a -> From k v a -> Maybe (From k v a)

146+ f toKey _ = removeRedundantDst toKey $ case getDstAction toKey dstAfter of

147+ From_Move fromKey -> getDstAction fromKey dstBefore

148+ nonMove -> nonMove

149+ dst = DMap.mapMaybeWithKey f $ DMap.union dstAfter dstBefore

150+ getSrcAction k m = fromMaybe (ComposeMaybe $ Just k) $ DMap.lookup k m

151+ removeRedundantSrc fromKey (ComposeMaybe (Just toKey)) | isJust (fromKey `geq` toKey) = Nothing

152+ removeRedundantSrc _ a = Just a

153+ g :: forall a. k a -> ComposeMaybe k a -> Maybe (ComposeMaybe k a)

154+ g fromKey _ = removeRedundantSrc fromKey $ case getSrcAction fromKey srcBefore of

155+ ComposeMaybe Nothing -> ComposeMaybe Nothing

156+ ComposeMaybe (Just toKeyBefore) -> getSrcAction toKeyBefore srcAfter

157+ src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore

158+-}

159+

160+moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v

161+moveDMapKey src dst = case src `geq` dst of

162+ Nothing -> PatchDMapWithMove $ DMap.fromList

163+ [ dst :=> NodeInfo (From_Move src) (ComposeMaybe Nothing)

164+ , src :=> NodeInfo From_Delete (ComposeMaybe $ Just dst)

165+ ]

166+ Just _ -> mempty

167+

168+deleteDMapKey :: k a -> PatchDMapWithMove k v

169+deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete $ ComposeMaybe Nothing

170+

171+{-

172+k1, k2 :: Const2 Int () ()

173+k1 = Const2 1

174+k2 = Const2 2

175+p1, p2 :: PatchDMapWithMove (Const2 Int ()) Identity

176+p1 = moveDMapKey k1 k2

177+p2 = moveDMapKey k2 k1

178+p12 = p1 <> p2

179+p21 = p2 <> p1

180+p12Slow = p1 `mappendPatchDMapWithMoveSlow` p2

181+p21Slow = p2 `mappendPatchDMapWithMoveSlow` p1

182+

183+testPatchDMapWithMove = do

184+ print p1

185+ print p2

186+ print $ p12 == deleteDMapKey k1

187+ print $ p21 == deleteDMapKey k2

188+ print $ p12Slow == deleteDMapKey k1

189+ print $ p21Slow == deleteDMapKey k2

190+

191+dst (PatchDMapWithMove x _) = x

192+src (PatchDMapWithMove _ x) = x

193+-}

194+

195+unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)

196+unPatchDMapWithMove (PatchDMapWithMove p) = p

197+

198+-- | Warning: when using this function, you must ensure that the invariants of

199+-- 'PatchDMapWithMove' are preserved; they will not be checked.

200+unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v

201+unsafePatchDMapWithMove = PatchDMapWithMove

202+

203+mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'

204+mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $

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

206+ where g :: forall a. From k v a -> From k v' a

207+ g = \case

208+ From_Insert v -> From_Insert $ f v

209+ From_Delete -> From_Delete

210+ From_Move k -> From_Move k

211+

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

213+traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f

214+

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

216+traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p

217+ where g :: forall a. k a -> From k v a -> m (From k v' a)

218+ g k = \case

219+ From_Insert v -> From_Insert <$> f k v

220+ From_Delete -> pure From_Delete

221+ From_Move fromKey -> pure $ From_Move fromKey

222+

223+nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a

224+nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }

225+

226+nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a)

227+nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni

228+

229+weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'

230+weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p

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

232+ g ni = MapWithMove.NodeInfo

233+ { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of

234+ From_Insert v -> MapWithMove.From_Insert $ f v

235+ From_Delete -> MapWithMove.From_Delete

236+ From_Move k -> MapWithMove.From_Move $ Some.This k

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

238+ }

239+

240+patchDMapWithMoveToPatchMapWithMoveWith :: forall k f v v'. (f v -> v') -> PatchDMapWithMove (Const2 k v) f -> PatchMapWithMove k v'

241+patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p

242+ where g :: NodeInfo (Const2 k v) f v -> MapWithMove.NodeInfo k v'

243+ g ni = MapWithMove.NodeInfo

244+ { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of

245+ From_Insert v -> MapWithMove.From_Insert $ f v

246+ From_Delete -> MapWithMove.From_Delete

247+ From_Move (Const2 k) -> MapWithMove.From_Move k

248+ , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)

249+ }

250+

251+const2PatchDMapWithMoveWith :: forall k v f a. (v -> f a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) f

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

253+ where g :: (k, MapWithMove.NodeInfo k v) -> DSum (Const2 k a) (NodeInfo (Const2 k a) f)

254+ g (k, ni) = Const2 k :=> NodeInfo

255+ { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of

256+ MapWithMove.From_Insert v -> From_Insert $ f v

257+ MapWithMove.From_Delete -> From_Delete

258+ MapWithMove.From_Move fromKey -> From_Move $ Const2 fromKey

259+ , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni

260+ }

261+

262+instance GCompare k => Patch (PatchDMapWithMove k v) where

263+ type PatchTarget (PatchDMapWithMove k v) = DMap k v

264+ 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?

265+ where insertions = DMap.mapMaybeWithKey insertFunc p

266+ insertFunc :: forall a. k a -> NodeInfo k v a -> Maybe (v a)

267+ insertFunc _ ni = case _nodeInfo_from ni of

268+ From_Insert v -> Just v

269+ From_Move k -> DMap.lookup k old

270+ From_Delete -> Nothing

271+ deletions = DMap.mapMaybeWithKey deleteFunc p

272+ deleteFunc :: forall a. k a -> NodeInfo k v a -> Maybe (Constant () a)

273+ deleteFunc _ ni = case _nodeInfo_from ni of

274+ From_Delete -> Just $ Constant ()

275+ _ -> Nothing

276+

277+-- | Get the values that will be deleted or moved if the given patch is applied

278+-- to the given 'DMap'.

279+getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))

280+getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p

281+ where f _ v ni = Pair v $ _nodeInfo_to ni

src/Reflex/Patch/Map.hsnew file+48

@@ -0,0 +1,48 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE LambdaCase #-}

3+{-# LANGUAGE TypeFamilies #-}

4+module Reflex.Patch.Map where

6+import Reflex.Patch.Class

8+import Data.Semigroup

9+import Data.Map (Map)

10+import qualified Data.Map as Map

11+import Data.Maybe

12+

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

14+-- deleted.

15+newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }

16+

17+instance Ord k => Patch (PatchMap k v) where

18+ type PatchTarget (PatchMap k v) = Map k v

19+ 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?

20+ where insertions = Map.mapMaybeWithKey (const id) p

21+ deletions = Map.mapMaybeWithKey (const nothingToJust) p

22+ nothingToJust = \case

23+ Nothing -> Just ()

24+ Just _ -> Nothing

25+

26+instance Ord k => Semigroup (PatchMap k v) where

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

28+ -- PatchMap is idempotent, so stimes n is id for every n

29+#if MIN_VERSION_semigroups(0,17,0)

30+ stimes = stimesIdempotentMonoid

31+#else

32+ times1p n x = case compare n 0 of

33+ LT -> error "stimesIdempotentMonoid: negative multiplier"

34+ EQ -> mempty

35+ GT -> x

36+#endif

37+

38+instance Ord k => Monoid (PatchMap k v) where

39+ mempty = PatchMap mempty

40+ mappend = (<>)

41+

42+instance Functor (PatchMap k) where

43+ fmap f = PatchMap . fmap (fmap f) . unPatchMap

44+

45+-- | Returns all the new elements that will be added to the 'Map'

46+patchMapNewElements :: PatchMap k v -> [v]

47+patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p

48+

src/Reflex/Patch/MapWithMove.hsnew file+156

@@ -0,0 +1,156 @@

1+{-# LANGUAGE DeriveFoldable #-}

2+{-# LANGUAGE DeriveFunctor #-}

3+{-# LANGUAGE DeriveTraversable #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE LambdaCase #-}

6+{-# LANGUAGE ScopedTypeVariables #-}

7+{-# LANGUAGE TypeFamilies #-}

8+module Reflex.Patch.MapWithMove where

10+import Reflex.Patch.Class

11+

12+import Control.Arrow

13+import Control.Monad.State

14+import Data.Foldable

15+import Data.Function

16+import Data.List

17+import Data.Map (Map)

18+import qualified Data.Map as Map

19+import Data.Maybe

20+import qualified Data.Set as Set

21+import Data.Tuple

22+

23+-- | Patch a DMap with additions, deletions, and moves.

24+-- Invariants:

25+-- * The same source key may not be moved to two destination keys.

26+-- * Any key that is the source of a Move must also be edited

27+-- (otherwise, the Move would duplicate it)

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

29+

30+data NodeInfo k v = NodeInfo

31+ { _nodeInfo_from :: !(From k v)

32+ , _nodeInfo_to :: !(To k)

33+ }

34+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)

35+

36+unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)

37+unPatchMapWithMove (PatchMapWithMove p) = p

38+

39+-- | Warning: when using this function, you must ensure that the invariants of

40+-- 'PatchMapWithMove' are preserved; they will not be checked.

41+unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v

42+unsafePatchMapWithMove = PatchMapWithMove

43+

44+data From k v

45+ = From_Insert v -- ^ Insert the given value here

46+ | From_Delete -- ^ Delete the existing value, if any, from here

47+ | From_Move !k -- ^ Move the value here from the given key

48+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)

49+

50+type To = Maybe

51+

52+instance Ord k => Patch (PatchMapWithMove k v) where

53+ type PatchTarget (PatchMapWithMove k v) = Map k v

54+ 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?

55+ where insertions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of

56+ From_Insert v -> Just v

57+ From_Move k -> Map.lookup k old

58+ From_Delete -> Nothing

59+ deletions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of

60+ From_Delete -> Just ()

61+ _ -> Nothing

62+

63+-- | Returns all the new elements that will be added to the 'Map'

64+patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]

65+patchMapWithMoveNewElements (PatchMapWithMove p) = catMaybes $ f <$> Map.elems p

66+ where f ni = case _nodeInfo_from ni of

67+ From_Insert v -> Just v

68+ From_Move _ -> Nothing

69+ From_Delete -> Nothing

70+

71+validPatchMapWithMove :: Ord k => PatchMapWithMove k v -> Bool

72+validPatchMapWithMove (PatchMapWithMove p) =

73+ let f ni = case _nodeInfo_from ni of

74+ From_Move k -> Just k

75+ _ -> Nothing

76+ moveSources = catMaybes $ f <$> Map.elems p

77+ in and

78+ [ -- All Moves must have unique source keys - a single source key can't be moved to two destinations

79+ all (==1) $ Map.fromListWith (+) $ fmap (\k -> (k, 1 :: Integer )) moveSources

80+ , -- 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)

81+ all (isJust . flip Map.lookup p) moveSources

82+ ]

83+

84+knownValidPatchMapWithMove :: [PatchMapWithMove Int Int]

85+knownValidPatchMapWithMove =

86+ [ PatchMapWithMove mempty

87+ , PatchMapWithMove $ Map.fromList

88+ [ (1, NodeInfo (From_Move 2) $ Just 1)

89+ , (2, NodeInfo (From_Move 1) $ Just 2)

90+ ]

91+ ]

92+

93+knownInvalidPatchMapWithMove :: [PatchMapWithMove Int Int]

94+knownInvalidPatchMapWithMove =

95+ [ -- Invalid because we move 2 to 1, but don't specify what to do with 2

96+ PatchMapWithMove $ Map.singleton 1 $ NodeInfo (From_Move 2) Nothing

97+ , -- Invalid because we have multiple moves from 3

98+ PatchMapWithMove $ Map.fromList

99+ [ (1, NodeInfo (From_Move 3) Nothing)

100+ , (2, NodeInfo (From_Move 3) Nothing)

101+ , (3, NodeInfo From_Delete (Just 1))

102+ ]

103+ ]

104+

105+patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v

106+patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted

107+ where unsorted = Map.toList m

108+ sorted = sortBy (cmp `on` snd) unsorted

109+ f (to, _) (from, _) = if to == from then Nothing else

110+ Just (from, to)

111+ reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted

112+ g (to, _) (from, _) = if to == from then Nothing else

113+ let Just movingTo = Map.lookup from reverseMapping

114+ in Just (to, NodeInfo (From_Move from) $ Just movingTo)

115+

116+patchThatChangesAndSortsMapWith :: forall k v. (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v

117+patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patch

118+ where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex

119+ newList = Map.toList newByIndexUnsorted

120+ newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList

121+ insertsAndMoves :: Map k (NodeInfo k v)

122+ (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do

123+ let f k v = do

124+ remainingValues <- get

125+ let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys

126+ then Map.delete v remainingValues

127+ else Map.insert v remainingKeys remainingValues

128+ case Map.lookup v remainingValues of

129+ Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take

130+ Just fromKs ->

131+ if k `Set.member` fromKs

132+ then do

133+ putRemainingKeys $ Set.delete k fromKs

134+ return $ NodeInfo (From_Move k) $ Just undefined -- There's an existing value, and it's here, so no patch necessary

135+ else do

136+ Just (fromK, remainingKeys) <- return $ Set.minView fromKs -- There's an existing value, but it's not here; move it here

137+ putRemainingKeys remainingKeys

138+ return $ NodeInfo (From_Move fromK) $ Just undefined

139+ Map.traverseWithKey f newByIndex

140+ unusedOldKeys = fold unusedValuesByValue

141+ pointlessMove k = \case

142+ From_Move k' | k == k' -> True

143+ _ -> False

144+ keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)

145+ then Just undefined

146+ else Nothing

147+ patch = unsafePatchMapWithMove $ Map.filterWithKey (\k -> not . pointlessMove k . _nodeInfo_from) $ Map.mergeWithKey (\k a _ -> Just $ nodeInfoSetTo (keyWasMoved k) a) (Map.mapWithKey $ \k -> nodeInfoSetTo $ keyWasMoved k) (Map.mapWithKey $ \k _ -> NodeInfo From_Delete $ keyWasMoved k) insertsAndMoves oldByIndex

148+

149+nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v

150+nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }

151+

152+nodeInfoMapMFrom :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)

153+nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni

154+

155+nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v

156+nodeInfoSetTo to ni = ni { _nodeInfo_to = to }

src/Reflex/PerformEvent/Base.hs+5−27

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

@@ -162,10 +144,6 @@ instance (ReflexHost t, MonadHold t m) => MonadHold t (PerformEventT t m) where

162 holdIncremental v0 v' = PerformEventT $ lift $ holdIncremental v0 v'

144 holdIncremental v0 v' = PerformEventT $ lift $ holdIncremental v0 v'

163 {-# INLINABLE buildDynamic #-}

145 {-# INLINABLE buildDynamic #-}

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

146 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

147

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

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

171 type Ref (PerformEventT t m) = Ref (HostFrame t)

149 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+27−53

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

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

136−

137− mergeIntIncremental = mergeIntIncrementalImpl

138

127

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)

@@ -209,9 +189,3 @@ instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where

209 in case unEvent e lastTime of

189 in case unEvent e lastTime of

210 Nothing -> lastValue

190 Nothing -> lastValue

211 Just x -> fromMaybe lastValue $ apply x lastValue

191 Just x -> fromMaybe lastValue $ apply x lastValue

212−

213− headE = slowHeadE

214− now t = Event $ guard . (t ==)

215−

216−

217−

src/Reflex/Query/Base.hs+49−134

@@ -1,14 +1,12 @@

1{-# LANGUAGE FlexibleInstances #-}

2{-# LANGUAGE GeneralizedNewtypeDeriving #-}

3{-# LANGUAGE InstanceSigs #-}

4−{-# LANGUAGE LambdaCase #-}

4+{-# LANGUAGE KindSignatures #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE RankNTypes #-}

7{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE TypeFamilies #-}

9{-# LANGUAGE UndecidableInstances #-}

10−{-# LANGUAGE StandaloneDeriving #-}

11−

12module Reflex.Query.Base

10module Reflex.Query.Base

13 ( QueryT (..)

11 ( QueryT (..)

14 , runQueryT

12 , runQueryT

@@ -16,52 +14,38 @@ module Reflex.Query.Base

16 , mapQueryResult

14 , mapQueryResult

17 , dynWithQueryT

15 , dynWithQueryT

18 , withQueryT

16 , withQueryT

19− , mapQueryT

20 ) where

17 ) where

22−import Control.Applicative (liftA2)

23import Control.Monad.Exception

19import Control.Monad.Exception

24import Control.Monad.Fix

20import Control.Monad.Fix

25−import Control.Monad.Morph

26−import Control.Monad.Primitive

27import Control.Monad.Reader

21import Control.Monad.Reader

28import Control.Monad.Ref

22import Control.Monad.Ref

29import Control.Monad.State.Strict

23import Control.Monad.State.Strict

30import Data.Align

24import Data.Align

31−import Data.Dependent.Map (DMap)

25+import Data.Dependent.Map (DMap, DSum (..))

32import qualified Data.Dependent.Map as DMap

26import qualified Data.Dependent.Map as DMap

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

34import Data.Foldable

27import Data.Foldable

35import Data.Functor.Compose

28import Data.Functor.Compose

36import Data.Functor.Misc

29import Data.Functor.Misc

37−import Data.GADT.Compare (GCompare)

38−import Data.IntMap (IntMap)

39−import qualified Data.IntMap as IntMap

40import Data.Map (Map)

30import Data.Map (Map)

41import qualified Data.Map as Map

31import qualified Data.Map as Map

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

32+import Data.Monoid

33+import Data.Some (Some)

43−import qualified Data.Semigroup as S

34+import qualified Data.Some as Some

44−import Data.Some (Some(Some))

45import Data.These

35import Data.These

47import Reflex.Class

37import Reflex.Class

48−import Reflex.Adjustable.Class

38+import Reflex.EventWriter

49−import Reflex.DynamicWriter.Class

50−import Reflex.EventWriter.Base

51−import Reflex.EventWriter.Class

52import Reflex.Host.Class

39import Reflex.Host.Class

53−import qualified Data.Patch.MapWithMove as MapWithMove

54import Reflex.PerformEvent.Class

40import Reflex.PerformEvent.Class

55import Reflex.PostBuild.Class

41import Reflex.PostBuild.Class

56import Reflex.Query.Class

42import Reflex.Query.Class

57import Reflex.Requester.Class

43import Reflex.Requester.Class

58import Reflex.TriggerEvent.Class

44import Reflex.TriggerEvent.Class

45+import qualified Reflex.Patch.MapWithMove as MapWithMove

60newtype QueryT t q m a = QueryT { unQueryT :: StateT [Behavior t q] (EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m)) a }

47newtype 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)

48+ deriving (Functor, Applicative, Monad, MonadException, MonadFix, MonadIO, MonadHold t, MonadSample t, 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)

66runQueryT :: (MonadFix m, Additive q, Group q, Reflex t) => QueryT t q m a -> Dynamic t (QueryResult q) -> m (a, Incremental t (AdditivePatch q))

50runQueryT :: (MonadFix m, Additive q, Group q, Reflex t) => QueryT t q m a -> Dynamic t (QueryResult q) -> m (a, Incremental t (AdditivePatch q))

67runQueryT (QueryT a) qr = do

51runQueryT (QueryT a) qr = do

@@ -76,69 +60,20 @@ getQueryTLoweredResultValue (QueryTLoweredResult (v, _)) = v

76getQueryTLoweredResultWritten :: QueryTLoweredResult t q v -> [Behavior t q]

60getQueryTLoweredResultWritten :: QueryTLoweredResult t q v -> [Behavior t q]

77getQueryTLoweredResultWritten (QueryTLoweredResult (_, w)) = w

61getQueryTLoweredResultWritten (QueryTLoweredResult (_, w)) = w

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

63+instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, MonadAdjust t m) => MonadAdjust t (QueryT t q m) where

83 runWithReplace (QueryT a0) a' = do

64 runWithReplace (QueryT a0) a' = do

84 ((r0, bs0), r') <- QueryT $ lift $ runWithReplace (runStateT a0 []) $ fmapCheap (flip runStateT [] . unQueryT) a'

65 ((r0, bs0), r') <- QueryT $ lift $ runWithReplace (runStateT a0 []) $ fmapCheap (flip runStateT [] . unQueryT) a'

66+ tellQueryIncremental $

85− let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q

67+ let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q

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

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

87− bs' = fmapCheap snd $ r'

69+ bs' = fmapCheap snd $ r'

88− bbs <- hold bs0 bs'

70+ patches = unsafeBuildIncremental (sampleBs bs0) $

89− let patches = flip pushCheap bs' $ \newBs -> do

71+ flip pushCheap bs' $ \bs -> do

90− oldBs <- sample bbs

72+ p <- (~~) <$> sampleBs bs <*> sample (currentIncremental patches)

91− maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)

73+ return (Just (AdditivePatch p))

92− QueryT $ modify $ (:) $ pull $ sampleBs =<< sample bbs

93− QueryT $ lift $ tellEvent patches

74+ in patches

94 return (r0, fmapCheap fst r')

75 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'))

76+ traverseDMapWithKeyWithAdjust :: forall (k :: * -> *) v v'. (DMap.GCompare k) => (forall a. k a -> v a -> QueryT t q m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> QueryT t q m (DMap k v', Event t (PatchDMap k v'))

142 traverseDMapWithKeyWithAdjust f dm0 dm' = do

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

78 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

79 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

@@ -166,24 +101,23 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t

166 let p k bs = case Map.lookup k bs0 of

101 let p k bs = case Map.lookup k bs0 of

167 Nothing -> case bs of

102 Nothing -> case bs of

168 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.

103 -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.

169− Nothing -> return Nothing

104+ Nothing -> return mempty

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.

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

106+ Just newBs -> sampleBs newBs

172 Just oldBs -> case bs of

107 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

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

109+ Nothing -> 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

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

111 -- composed with the sampling the child's new state.

177− Just newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)

112+ Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs

178 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the

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

114 -- child patches and wrap them in AdditivePatch.

180− patch <- fold <$> Map.traverseWithKey p bs'

115+ patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'

181− return (apply pbs bs0, AdditivePatch <$> patch)

116+ return (apply pbs bs0, Just patch)

182 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'

117 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'

183 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch

118 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch

184 return (liftedResult0, liftedResult')

119 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'))

120+ traverseDMapWithKeyWithAdjustWithMove :: forall (k :: * -> *) v v'. (DMap.GCompare k) => (forall a. k a -> v a -> QueryT t q m (v' a)) -> DMap k v -> Event t (PatchDMapWithMove k v) -> QueryT t q m (DMap k v', Event t (PatchDMapWithMove k v'))

187 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do

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

122 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

123 f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

211 p k bs = case Map.lookup k bs0 of

145 p k bs = case Map.lookup k bs0 of

212 Nothing -> case MapWithMove._nodeInfo_from bs of

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

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

148+ MapWithMove.From_Delete -> return mempty

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.

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

150+ MapWithMove.From_Insert newBs -> sampleBs newBs

217 MapWithMove.From_Move k' -> case Map.lookup k' bs0 of

151 MapWithMove.From_Move k' -> case Map.lookup k' bs0 of

218− Nothing -> return Nothing

152+ Nothing -> return mempty

219− Just newBs -> maskMempty <$> sampleBs newBs

153+ Just newBs -> sampleBs newBs

220 Just oldBs -> case MapWithMove._nodeInfo_from bs of

154 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

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

156+ MapWithMove.From_Delete -> 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

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

158 -- composed with the sampling the child's new state.

225− MapWithMove.From_Insert newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)

159+ MapWithMove.From_Insert newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs

226 MapWithMove.From_Move k'

160 MapWithMove.From_Move k'

227− | k' == k -> return Nothing

161+ | k' == k -> return mempty

228 | otherwise -> case Map.lookup k' bs0 of

162 | otherwise -> case Map.lookup k' bs0 of

229 -- If we are moving from a non-existent key, that is a delete

163 -- If we are moving from a non-existent key, that is a delete

230− Nothing -> maskMempty . negateG <$> sampleBs oldBs

164+ Nothing -> negateG <$> sampleBs oldBs

231− Just newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs)

165+ Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs

232 -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the

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

167 -- child patches and wrap them in AdditivePatch.

234− patch <- fold <$> Map.traverseWithKey p bs'

168+ patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'

235− return (apply pbs bs0, AdditivePatch <$> patch)

169+ return (apply pbs bs0, Just patch)

236 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors' liftedBs0 liftedBs'

170 (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors' liftedBs0 liftedBs'

237 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch

171 tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch

238 return (liftedResult0, liftedResult')

172 return (liftedResult0, liftedResult')

@@ -240,13 +174,6 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t

240instance MonadTrans (QueryT t q) where

174instance MonadTrans (QueryT t q) where

241 lift = QueryT . lift . lift . lift

175 lift = QueryT . lift . lift . lift

242

176

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−

250instance PostBuild t m => PostBuild t (QueryT t q m) where

177instance PostBuild t m => PostBuild t (QueryT t q m) where

251 getPostBuild = lift getPostBuild

178 getPostBuild = lift getPostBuild

252

179

@@ -273,13 +200,11 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (QueryT t q

273 newEventWithTrigger = QueryT . newEventWithTrigger

200 newEventWithTrigger = QueryT . newEventWithTrigger

274 newFanEventWithTrigger a = QueryT . lift $ newFanEventWithTrigger a

201 newFanEventWithTrigger a = QueryT . lift $ newFanEventWithTrigger a

275

202

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

203+mapQuery :: QueryMorphism q q' -> q -> q'

277−instance (Monoid a, Monad m) => Monoid (QueryT t q m a) where

204+mapQuery = _queryMorphism_mapQuery

278− mempty = pure mempty

279− mappend = (<>)

280

205

281−instance (S.Semigroup a, Monad m) => S.Semigroup (QueryT t q m a) where

206+mapQueryResult :: QueryMorphism q q' -> QueryResult q' -> QueryResult q

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

207+mapQueryResult = _queryMorphism_mapQueryResult

283

208

284-- | withQueryT's QueryMorphism argument needs to be a group homomorphism in order to behave correctly

209-- | withQueryT's QueryMorphism argument needs to be a group homomorphism in order to behave correctly

285withQueryT :: (MonadFix m, PostBuild t m, Group q, Group q', Additive q, Additive q', Query q')

210withQueryT :: (MonadFix m, PostBuild t m, Group q, Group q', Additive q, Additive q', Query q')

@@ -294,10 +219,6 @@ withQueryT f a = do

294 (fmapCheap (AdditivePatch . mapQuery f . unAdditivePatch) $ updatedIncremental q)

219 (fmapCheap (AdditivePatch . mapQuery f . unAdditivePatch) $ updatedIncremental q)

295 return result

220 return result

296

221

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

222-- | dynWithQueryT's (Dynamic t QueryMorphism) argument needs to be a group homomorphism at all times in order to behave correctly

302dynWithQueryT :: (MonadFix m, PostBuild t m, Group q, Additive q, Group q', Additive q', Query q')

223dynWithQueryT :: (MonadFix m, PostBuild t m, Group q, Additive q, Group q', Additive q', Query q')

303 => Dynamic t (QueryMorphism q q')

224 => Dynamic t (QueryMorphism q q')

@@ -310,7 +231,7 @@ dynWithQueryT f q = do

310 return result

231 return result

311 where zipDynIncrementalWith g da ib =

232 where zipDynIncrementalWith g da ib =

312 let eab = align (updated da) (updatedIncremental ib)

233 let eab = align (updated da) (updatedIncremental ib)

313− ec = flip push eab $ \case

234+ ec = flip push eab $ \o -> case o of

314 This a -> do

235 This a -> do

315 aOld <- sample $ current da

236 aOld <- sample $ current da

316 b <- sample $ currentIncremental ib

237 b <- sample $ currentIncremental ib

@@ -331,16 +252,10 @@ instance (Monad m, Group q, Additive q, Query q, Reflex t) => MonadQuery t q (Qu

331 askQueryResult = QueryT ask

252 askQueryResult = QueryT ask

332 queryIncremental q = do

253 queryIncremental q = do

333 tellQueryIncremental q

254 tellQueryIncremental q

255+ r <- askQueryResult

334− zipDynWith crop (incrementalToDynamic q) <$> askQueryResult

256+ return $ zipDynWith crop (incrementalToDynamic q) r

335

257

336instance Requester t m => Requester t (QueryT t q m) where

258instance Requester t m => Requester t (QueryT t q m) where

337 type Request (QueryT t q m) = Request m

259 type Request (QueryT t q m) = Request m

338 type Response (QueryT t q m) = Response m

260 type Response (QueryT t q m) = Response m

339− requesting = lift . requesting

261+ withRequesting f = QueryT $ withRequesting $ unQueryT . f

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

@@ -1,18 +1,11 @@

1−{-# LANGUAGE CPP #-}

2{-# LANGUAGE DeriveDataTypeable #-}

1{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleInstances #-}

3{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FunctionalDependencies #-}

4{-# LANGUAGE FunctionalDependencies #-}

6{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

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.

16module Reflex.Query.Class

9module Reflex.Query.Class

17 ( Query (..)

10 ( Query (..)

18 , QueryMorphism (..)

11 , QueryMorphism (..)

@@ -22,94 +15,29 @@ module Reflex.Query.Class

22 , MonadQuery (..)

15 , MonadQuery (..)

23 , tellQueryDyn

16 , tellQueryDyn

24 , queryDyn

17 , queryDyn

25− , subQuery

26− , mapQuery

27− , mapQueryResult

28 ) where

18 ) where

30−import Control.Category (Category)

31−import qualified Control.Category as Cat

32import Control.Monad.Reader

20import Control.Monad.Reader

33import Data.Bits

21import Data.Bits

34import Data.Data

22import Data.Data

35import Data.Ix

23import Data.Ix

36−import Data.Map.Monoidal (MonoidalMap)

24+import Data.Semigroup

37−import qualified Data.Map.Monoidal as MonoidalMap

38−import Data.Semigroup (Semigroup(..))

39import Foreign.Storable

25import Foreign.Storable

40−import Data.Void

41−import Data.Monoid hiding ((<>))

42−import Control.Applicative

44import Reflex.Class

27import Reflex.Class

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

50class (Monoid (QueryResult a), Semigroup (QueryResult a)) => Query a where

29class (Monoid (QueryResult a), Semigroup (QueryResult a)) => Query a where

51 type QueryResult a :: *

30 type QueryResult a :: *

52 crop :: a -> QueryResult a -> QueryResult a

31 crop :: a -> QueryResult a -> QueryResult a

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

33+-- | NB: 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.

34+-- and compatible with the query relationship when acting on the query result

91data QueryMorphism q q' = QueryMorphism

35data QueryMorphism q q' = QueryMorphism

92 { _queryMorphism_mapQuery :: q -> q'

36 { _queryMorphism_mapQuery :: q -> q'

93 , _queryMorphism_mapQueryResult :: QueryResult q' -> QueryResult q

37 , _queryMorphism_mapQueryResult :: QueryResult q' -> QueryResult q

94 }

38 }

96−instance Category QueryMorphism where

40+-- | This type keeps track of the multiplicity of elements of the view selector that are being used by the app

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'

113newtype SelectedCount = SelectedCount { unSelectedCount :: Int }

41newtype SelectedCount = SelectedCount { unSelectedCount :: Int }

114 deriving (Eq, Ord, Show, Read, Integral, Num, Bounded, Enum, Real, Ix, Bits, FiniteBits, Storable, Data)

42 deriving (Eq, Ord, Show, Read, Integral, Num, Bounded, Enum, Real, Ix, Bits, FiniteBits, Storable, Data)

115

@@ -125,34 +53,25 @@ instance Group SelectedCount where

125

126instance Additive SelectedCount

54instance 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

56+-- | The Semigroup/Monoid/Group instances for a ViewSelector should use this function which returns Nothing if the result is 0. This allows the pruning of leaves that are no longer wanted.

130−-- of the 'Query' that are no longer wanted.

131combineSelectedCounts :: SelectedCount -> SelectedCount -> Maybe SelectedCount

57combineSelectedCounts :: SelectedCount -> SelectedCount -> Maybe SelectedCount

132combineSelectedCounts (SelectedCount i) (SelectedCount j) = if i == negate j then Nothing else Just $ SelectedCount (i + j)

58combineSelectedCounts (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

60+class (Group q, Additive q, Query q) => MonadQuery t q m | m -> q t where

137 tellQueryIncremental :: Incremental t (AdditivePatch q) -> m ()

61 tellQueryIncremental :: Incremental t (AdditivePatch q) -> m ()

138 askQueryResult :: m (Dynamic t (QueryResult q))

62 askQueryResult :: m (Dynamic t (QueryResult q))

139 queryIncremental :: Incremental t (AdditivePatch q) -> m (Dynamic t (QueryResult q))

63 queryIncremental :: Incremental t (AdditivePatch q) -> m (Dynamic t (QueryResult q))

140

141−instance MonadQuery t q m => MonadQuery t q (ReaderT r m) where

65+instance (Monad m, MonadQuery t q m) => MonadQuery t q (ReaderT r m) where

142 tellQueryIncremental = lift . tellQueryIncremental

66 tellQueryIncremental = lift . tellQueryIncremental

143 askQueryResult = lift askQueryResult

67 askQueryResult = lift askQueryResult

144 queryIncremental = lift . queryIncremental

68 queryIncremental = lift . queryIncremental

145

146−-- | Produce and send an 'Incremental' 'Query' from a 'Dynamic' 'Query'.

147tellQueryDyn :: (Reflex t, MonadQuery t q m) => Dynamic t q -> m ()

70tellQueryDyn :: (Reflex t, MonadQuery t q m) => Dynamic t q -> m ()

148tellQueryDyn d = tellQueryIncremental $ unsafeBuildIncremental (sample (current d)) $ attachWith (\old new -> AdditivePatch $ new ~~ old) (current d) (updated d)

71tellQueryDyn 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))

73+queryDyn :: (Reflex t, Monad m, MonadQuery t q m) => Dynamic t q -> m (Dynamic t (QueryResult q))

152queryDyn q = do

74queryDyn q = do

153 tellQueryDyn q

75 tellQueryDyn q

76+ r <- askQueryResult

154− zipDynWith crop q <$> askQueryResult

77+ return $ zipDynWith crop q r

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+50−501

@@ -1,291 +1,50 @@

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

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

50#if MIN_VERSION_base(4,9,1)

@@ -298,76 +57,33 @@ deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)

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

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

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

58deriving 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

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

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

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

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

317-- requests were issued.

63-- requests were issued.

64+

318runRequesterT :: (Reflex t, Monad m)

65runRequesterT :: (Reflex t, Monad m)

319 => RequesterT t request response m a

66 => 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

67+ -> 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

68+ -> m (a, Event t (DMap (Tag (PrimState m)) request))

322runRequesterT (RequesterT a) responses = do

69runRequesterT (RequesterT a) responses = do

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

70+ (result, requests) <- runReaderT (runEventWriterT a) $ fan $

324− coerceEvent responses

71+ mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e) <$> responses

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

72+ 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

74+instance (Reflex t, PrimMonad m) => Requester t (RequesterT t request response m) where

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

75 type Request (RequesterT t request response m) = request

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

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

77+ withRequesting a = do

345− requesting_ = void . tagRequest . fmapCheap singleEntry

78+ !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

79+ s <- RequesterT ask

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

80+ (req, result) <- a $ select s $ WrapArg t

81+ RequesterT $ tellEvent $ fmapCheap (DMap.singleton t) req

82+ return result

364

365instance MonadTrans (RequesterT t request response) where

84instance MonadTrans (RequesterT t request response) where

366 lift = RequesterT . lift . lift

85 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

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

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

88 type Performable (RequesterT t request response m) = Performable m

373 performEvent_ = lift . performEvent_

89 performEvent_ = lift . performEvent_

@@ -385,88 +101,34 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT

385

101

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

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

387 ask = lift ask

103 ask = lift ask

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

104+ local f (RequesterT (EventWriterT a)) = RequesterT $ EventWriterT $ mapStateT (mapReaderT $ local f) a

389 reader = lift . reader

105 reader = lift . reader

390

106

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

107+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'

108+ runWithReplace (RequesterT a) em = RequesterT $ runWithReplace a (coerceEvent em)

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

109+ 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

110+ 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

111

401−{-# INLINABLE runWithReplaceRequesterTWith #-}

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

112+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'))

113 => (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

114 -> RequesterT t request response m a

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

115 -> Event t (RequesterT t request response m b)

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

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

409−runWithReplaceRequesterTWith f a0 a' = do

117+runWithReplaceRequesterTWith f a0 a' =

410− rec na' <- numberOccurrencesFrom 1 a'

118+ 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

119+ -> Event t (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m b')

412− let responses' = fanInt responses

120+ -> 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'

121+ f' x y = do

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

122+ r <- EventWriterT $ ask

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

123+ unRequesterT (f (runReaderT x r) (fmapCheap (`runReaderT` r) y))

416−

124+ in RequesterT $ runWithReplaceEventWriterTWith f' (coerce a0) (coerceEvent a')

417−{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}

125+

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

419− ( Reflex t

420− , MonadHold t m

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

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

423− , Functor p

424− , MonadFix m

425− )

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

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

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

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

430− )

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

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

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

434− -> IntMap v

435− -> Event t (p v)

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

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

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

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

440− responses = fanInt $ fmapCheap unpack response

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

442− unpack = unEntry

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

444− pack = Entry

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

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

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

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

449− ndm' <- numberOccurrencesFrom 1 dm'

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

451− let result0 = fmap snd children0

452− result' = fforCheap children' $ fmap snd

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

454− requests0 = fmap fst children0

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

456− requests' = fforCheap children' $ fmap fst

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

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

459− requests <- holdIncremental requests0 requests'

460− return (result0, result')

461−

462−{-# INLINE traverseDMapWithKeyWithAdjustRequesterTWith #-}

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

126+sequenceDMapWithAdjustRequesterTWith :: forall k t request response m v v' p p'.

464 ( GCompare k

127 ( GCompare k

465 , Reflex t

128 , Reflex t

466 , MonadHold t m

129 , MonadHold t m

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

130+ , 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))))

131+ , Patch (p' (Some k) (Event t (DMap (Tag (PrimState m)) request)))

469− , MonadFix m

470 )

132 )

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

133 => (forall k' v1 v2. GCompare k'

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

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

@@ -474,134 +136,21 @@ traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v

474 -> Event t (p k' v1)

136 -> Event t (p k' v1)

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

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

476 )

138 )

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

139+ -> (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)

140 -> (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)

141+ -> (forall v2. p' (Some k) v2 -> [v2])

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

142 -> (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))

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

482 -> DMap k v

144 -> DMap k v

483 -> Event t (p k v)

145 -> Event t (p k v)

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

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

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

147+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

148+ let base' :: forall v1 v2.

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

149+ (forall a. k a -> v1 a -> ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m (v2 a))

488− responses = fanMap $ fmapCheap unpack response

150+ -> DMap k v1

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

151+ -> Event t (p k v1)

490− unpack = _multi2Contents_values . unEntry

152+ -> 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)

153+ base' f' x y = do

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

154+ r <- EventWriterT ask

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

155+ unRequesterT $ base (\k v -> runReaderT (f' k v) r) x y

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

156+ 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−-- |

3−-- Module:

4−-- Reflex.Spider

5−-- Description:

6−-- This module exports all of the user-facing functionality of the 'Spider' 'Reflex' engine

2+-- | This module exports all of the user-facing functionality of the 'Spider'

3+-- '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+520−1221

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

24+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

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

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)

33−import Control.Applicative (liftA2)

31+import Control.Applicative

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,60 @@ 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)

70−import GHC.Exts hiding (toList)

60+import GHC.Exts

71import GHC.IORef (IORef (..))

61import GHC.IORef (IORef (..))

72import GHC.Stack

62import GHC.Stack

73import Reflex.FastWeak

63import Reflex.FastWeak

64+import Reflex.FunctorMaybe

74import System.IO.Unsafe

65import System.IO.Unsafe

75import System.Mem.Weak

66import System.Mem.Weak

76import Unsafe.Coerce

67import 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

69#ifdef DEBUG_CYCLES

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

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

89−#endif

90−

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

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

92import qualified Data.List.NonEmpty as NonEmpty

72import qualified Data.List.NonEmpty as NonEmpty

73+import Data.Monoid (mempty)

93import Data.Tree (Forest, Tree (..), drawForest)

74import Data.Tree (Forest, Tree (..), drawForest)

94−import Data.List (isPrefixOf)

75+#endif

96−import Data.FastWeakBag (FastWeakBag, FastWeakBagTicket)

77+import Data.FastWeakBag (FastWeakBag)

97import qualified Data.FastWeakBag as FastWeakBag

78import qualified Data.FastWeakBag as FastWeakBag

98−

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)

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

104import qualified Data.WeakBag as WeakBag

80import qualified Data.WeakBag as WeakBag

81+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

82+import Data.Reflection

83+import Data.Some (Some)

84+import qualified Data.Some as Some

85+import Data.Type.Coercion

105import qualified Reflex.Class

86import qualified Reflex.Class

106import qualified Reflex.Class as R

87import qualified Reflex.Class as R

107import qualified Reflex.Host.Class

88import qualified Reflex.Host.Class

108−import Reflex.NotReady.Class

89+#endif

109−import Data.Patch

90+import Reflex.Patch

110−import qualified Data.Patch.DMapWithMove as PatchDMapWithMove

91+import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove

111−import Reflex.PerformEvent.Base (PerformEventT)

92+

93+-- Note: must come last to silence warnings due to AMP on GHC < 7.10

94+import Prelude hiding (any, concat, mapM, mapM_, sequence)

112

113#ifdef DEBUG_TRACE_EVENTS

96#ifdef DEBUG_TRACE_EVENTS

114−import qualified Data.ByteString.Char8 as BS8

115import System.IO (stderr)

97import System.IO (stderr)

116−import Data.List (isPrefixOf)

98+import qualified Data.ByteString.Char8 as BS8

117#endif

99#endif

118

100

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

101#ifdef DEBUG_TRACE_EVENTS

102+

124withStackOneLine :: (BS8.ByteString -> a) -> a

103withStackOneLine :: (BS8.ByteString -> a) -> a

125withStackOneLine expr = unsafePerformIO $ do

104withStackOneLine expr = unsafePerformIO $ do

126 stack <- currentCallStack

105 stack <- currentCallStack

127− return (expr . BS8.pack . unwords . dropInternal . reverse $ stack)

106+ return (expr (BS8.pack (unwords (reverse stack))))

128− where dropInternal = filterStack "Reflex.Spider.Internal"

129

107

130#endif

108#endif

131

109

@@ -136,42 +114,28 @@ debugInvalidateHeight :: Bool

136debugInvalidate :: Bool

114debugInvalidate :: Bool

137

115

138#ifdef DEBUG

116#ifdef DEBUG

117+

139#define DEBUG_NODEIDS

118#define DEBUG_NODEIDS

140

119

141−#ifdef DEBUG_TRACE_PROPAGATION

142debugPropagate = True

120debugPropagate = True

143−#else

144−debugPropagate = False

145−#endif

146

121

147−#ifdef DEBUG_TRACE_HEIGHT

148−debugInvalidateHeight = True

149−#else

150debugInvalidateHeight = False

122debugInvalidateHeight = False

151−#endif

152

123

153−#ifdef DEBUG_TRACE_INVALIDATION

154debugInvalidate = True

124debugInvalidate = True

155−#else

156−debugInvalidate = False

157−#endif

158

125

159class HasNodeId a where

126class HasNodeId a where

160 getNodeId :: a -> Int

127 getNodeId :: a -> Int

161

128

162−instance HasNodeId (CacheSubscribed x a) where

129+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

130 getNodeId = holdNodeId

170

131

132+instance HasNodeId (PushSubscribed x a b) where

133+ getNodeId = pushSubscribedNodeId

134+

171instance HasNodeId (SwitchSubscribed x a) where

135instance HasNodeId (SwitchSubscribed x a) where

172 getNodeId = switchSubscribedNodeId

136 getNodeId = switchSubscribedNodeId

173

137

174−instance HasNodeId (FanSubscribed x v a) where

138+instance HasNodeId (FanSubscribed x a) where

175 getNodeId = fanSubscribedNodeId

139 getNodeId = fanSubscribedNodeId

176

140

177instance HasNodeId (CoincidenceSubscribed x a) where

141instance HasNodeId (CoincidenceSubscribed x a) where

@@ -185,16 +149,41 @@ instance HasNodeId (Pull x a) where

185

149

186{-# INLINE showNodeId #-}

150{-# INLINE showNodeId #-}

187showNodeId :: HasNodeId a => a -> String

151showNodeId :: HasNodeId a => a -> String

188−showNodeId = showNodeId' . getNodeId

152+showNodeId = ("#"<>) . show . getNodeId

189−

153+

190−showNodeId' :: Int -> String

154+showSubscriberType :: Subscriber x a -> String

191−showNodeId' = ("#"<>) . show

155+showSubscriberType = \case

192−

156+ SubscriberPush _ _ -> "SubscriberPush"

157+ SubscriberMerge _ _ -> "SubscriberMerge"

158+ SubscriberFan _ -> "SubscriberFan"

159+ SubscriberMergeChange _ -> "SubscriberMergeChange"

160+ SubscriberHold _ -> "SubscriberHold"

161+ SubscriberHoldIdentity _ -> "SubscriberHoldIdentity"

162+ SubscriberSwitch _ -> "SubscriberSwitch"

163+ SubscriberCoincidenceOuter _ -> "SubscriberCoincidenceOuter"

164+ SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"

165+ SubscriberHandle -> "SubscriberHandle"

166+

167+showEventType :: Event x a -> String

168+showEventType = \case

169+ EventRoot _ _ -> "EventRoot"

170+ EventNever -> "EventNever"

171+ EventPush _ -> "EventPush"

172+ EventMerge _ -> "EventMerge"

173+ EventFan _ _ -> "EventFan"

174+ EventSwitch _ -> "EventSwitch"

175+ EventCoincidence _ -> "EventCoincidence"

176+ EventHold _ -> "EventHold"

177+ EventDyn _ -> "EventDyn"

178+ EventHoldIdentity _ -> "EventHoldIdentity"

179+ EventDynIdentity _ -> "EventDynIdentity"

193

180

194#else

181#else

195

182

196debugPropagate = False

183debugPropagate = False

184+

197debugInvalidateHeight = False

185debugInvalidateHeight = False

186+

198debugInvalidate = False

187debugInvalidate = False

199

188

200-- This must be inline, or error messages will cause memory leaks due to retaining the node in question

189-- This must be inline, or error messages will cause memory leaks due to retaining the node in question

@@ -202,10 +191,6 @@ debugInvalidate = False

202showNodeId :: a -> String

191showNodeId :: a -> String

203showNodeId _ = ""

192showNodeId _ = ""

204

193

205−{-# INLINE showNodeId' #-}

206−showNodeId' :: Int -> String

207−showNodeId' _ = ""

208−

209#endif

194#endif

210

195

211#ifdef DEBUG_NODEIDS

196#ifdef DEBUG_NODEIDS

@@ -215,6 +200,12 @@ nextNodeIdRef = unsafePerformIO $ newIORef 1

215

200

216newNodeId :: IO Int

201newNodeId :: IO Int

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

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

203+

204+{-# NOINLINE unsafeNodeId #-}

205+unsafeNodeId :: a -> Int

206+unsafeNodeId a = unsafePerformIO $ do

207+ touch a

208+ newNodeId

218#endif

209#endif

219

210

220--------------------------------------------------------------------------------

211--------------------------------------------------------------------------------

@@ -250,85 +241,31 @@ subscribeAndRead = unEvent

250-- | Construct an 'Event' equivalent to that constructed by 'push', but with no

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

242-- caching; if the computation function is very cheap, this is (much) more

252-- efficient than 'push'

243-- efficient than 'push'

253−{-# INLINE [1] pushCheap #-}

244+{-# NOINLINE pushCheap #-}

254pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b

245pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b

255−pushCheap !f e = Event $ \sub -> do

246+pushCheap f e = Event $ \sub -> do

256− (subscription, occ) <- subscribeAndRead e $ debugSubscriber' "push" $ sub

247+ (subscription, occ) <- subscribeAndRead e $ sub

257 { subscriberPropagate = \a -> do

248 { subscriberPropagate = \a -> do

258− mb <- f a

249+ mb <- runComputeM $ f a

259 mapM_ (subscriberPropagate sub) mb

250 mapM_ (subscriberPropagate sub) mb

260 }

251 }

261− occ' <- join <$> mapM f occ

252+ occ' <- join <$> mapM (runComputeM . f) occ

262 return (subscription, occ')

253 return (subscription, occ')

263

254

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

255data CacheSubscribed x a

302 = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(FastWeakBag (Subscriber x a))

256 = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(FastWeakBag (Subscriber x a))

303 , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)

257 , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)

258+ , _cacheSubscribed_cached :: {-# UNPACK #-} !(IORef (Maybe (FastWeakTicket (CacheSubscribed x a))))

304 , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))

259 , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))

305−#ifdef DEBUG_NODEIDS

306− , _cacheSubscribed_nodeId :: {-# UNPACK #-} !Int

307−#endif

308 }

260 }

309

261

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

262-- | Construct an 'Event' whose value is guaranteed not to be recomputed

326-- repeatedly

263-- repeatedly

327--

264--

328--TODO: Try a caching strategy where we subscribe directly to the parent when

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

266--there's only one subscriber, and then build our own FastWeakBag only when a second

330--subscriber joins

267--subscriber joins

331−{-# NOINLINE [0] cacheEvent #-}

268+{-# NOINLINE cacheEvent #-}

332cacheEvent :: forall x a. HasSpiderTimeline x => Event x a -> Event x a

269cacheEvent :: forall x a. HasSpiderTimeline x => Event x a -> Event x a

333cacheEvent e =

270cacheEvent e =

334#ifdef DEBUG_TRACE_EVENTS

271#ifdef DEBUG_TRACE_EVENTS

@@ -336,79 +273,54 @@ cacheEvent e =

336#else

273#else

337 Event $

274 Event $

338#endif

275#endif

339− unsafePerformIO $ do

340− mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))

276+ let mSubscribedRef :: IORef (Maybe (FastWeakTicket (CacheSubscribed x a)))

341− <- newIORef emptyFastWeak

277+ !mSubscribedRef = unsafeNewIORef e Nothing

342− pure $ \sub -> {-# SCC "cacheEvent" #-} do

278+ in \sub -> {-# SCC "cacheEvent" #-} do

343#ifdef DEBUG_TRACE_EVENTS

279#ifdef DEBUG_TRACE_EVENTS

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

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

345#endif

281#endif

346− subscribedTicket <- liftIO (readIORef mSubscribedRef >>= getFastWeakTicket) >>= \case

282+ subscribedTicket <- liftIO (readIORef mSubscribedRef) >>= \case

347 Just subscribedTicket -> return subscribedTicket

283 Just subscribedTicket -> return subscribedTicket

348 Nothing -> do

284 Nothing -> do

349−#ifdef DEBUG_NODEIDS

350− nodeId <- liftIO newNodeId

351−#endif

352 subscribers <- liftIO FastWeakBag.empty

285 subscribers <- liftIO FastWeakBag.empty

353 occRef <- liftIO $ newIORef Nothing -- This should never be read prior to being set below

286 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

287 (parentSub, occ) <- subscribeAndRead e $ Subscriber

358−#endif

359− { subscriberPropagate = \a -> do

288+ { subscriberPropagate = \a -> do

360− liftIO $ writeIORef occRef (Just a)

289+ liftIO $ writeIORef occRef $ Just a

361− scheduleClear occRef

290+ scheduleClear occRef

362− propagateFast a subscribers

291+ propagateFast a subscribers

292+ , subscriberInvalidateHeight = \old -> do

363− , subscriberInvalidateHeight = FastWeakBag.traverse_ subscribers . invalidateSubscriberHeight

293+ FastWeakBag.traverse subscribers $ invalidateSubscriberHeight old

294+ , subscriberRecalculateHeight = \new -> do

364− , subscriberRecalculateHeight = FastWeakBag.traverse_ subscribers . recalculateSubscriberHeight

295+ FastWeakBag.traverse subscribers $ recalculateSubscriberHeight new

365− }

296+ }

366 when (isJust occ) $ do

297 when (isJust occ) $ do

367 liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing

298 liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing

368 scheduleClear occRef

299 scheduleClear occRef

369 let !subscribed = CacheSubscribed

300 let !subscribed = CacheSubscribed

370 { _cacheSubscribed_subscribers = subscribers

301 { _cacheSubscribed_subscribers = subscribers

371 , _cacheSubscribed_parent = parentSub

302 , _cacheSubscribed_parent = parentSub

303+ , _cacheSubscribed_cached = mSubscribedRef

372 , _cacheSubscribed_occurrence = occRef

304 , _cacheSubscribed_occurrence = occRef

373−#ifdef DEBUG_NODEIDS

374− , _cacheSubscribed_nodeId = nodeId

375−#endif

376 }

305 }

377− subscribedTicket <- liftIO $ mkFastWeakTicket subscribed

306+ !subscribedTicket = fastWeakTicket subscribed

378− liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket

307+ liftIO $ writeIORef mSubscribedRef $ Just subscribedTicket

379 return subscribedTicket

308 return subscribedTicket

380− liftIO $ cacheSubscription sub mSubscribedRef subscribedTicket

309+ liftIO $ do

381−

310+ let subscribed = fastWeakTicketValue subscribedTicket

382−cacheSubscription :: Subscriber x a -> IORef (FastWeak (CacheSubscribed x a))

311+ subscribedWeak <- getFastWeakTicketWeak subscribedTicket

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

312+ ticket <- FastWeakBag.insert sub (_cacheSubscribed_subscribers subscribed) subscribedWeak cleanupCacheSubscribed

387− occ <- readIORef $ _cacheSubscribed_occurrence subscribed

313+ occ <- readIORef $ _cacheSubscribed_occurrence subscribed

388−

314+ let es = EventSubscribed

389− let parentSub = _cacheSubscribed_parent subscribed

315+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _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

316+ , eventSubscribedRetained = toAny subscribed

403−#ifdef DEBUG_CYCLES

317+ }

404− , eventSubscribedGetParents = return [_eventSubscription_subscribed parentSub]

318+ return (EventSubscription (FastWeakBag.remove ticket >> touch ticket) es, occ)

405− , eventSubscribedHasOwnHeightRef = False

406− , eventSubscribedWhoCreated = whoCreatedIORef mSubscribedRef

407−#endif

408− }

409− }

410− return (es, occ)

411

319

320+cleanupCacheSubscribed :: CacheSubscribed x a -> IO ()

321+cleanupCacheSubscribed self = do

322+ unsubscribe $ _cacheSubscribed_parent self

323+ writeIORef (_cacheSubscribed_cached self) Nothing

412

324

413subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)

325subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)

414subscribe e s = fst <$> subscribeAndRead e s

326subscribe e s = fst <$> subscribeAndRead e s

@@ -420,16 +332,13 @@ wrap tag getSpecificSubscribed sub = do

420 let es = tag subd

332 let es = tag subd

421 return (EventSubscription (WeakBag.remove sln >> touch sln) es, occ)

333 return (EventSubscription (WeakBag.remove sln >> touch sln) es, occ)

422

334

423−eventRoot :: (GCompare k, HasSpiderTimeline x) => k a -> Root x k -> Event x a

335+eventRoot :: GCompare k => k a -> Root x k -> Event x a

424eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r

336eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r

425

337

426−subscribeAndReadNever :: EventM x (EventSubscription x, Maybe a)

427−subscribeAndReadNever = return (EventSubscription (return ()) eventSubscribedNever, Nothing)

428−

429eventNever :: Event x a

338eventNever :: Event x a

430−eventNever = Event $ const subscribeAndReadNever

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

431

340

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

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

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

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

434

343

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

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

@@ -438,14 +347,14 @@ eventSwitch !s = Event $ wrap eventSubscribedSwitch $ getSwitchSubscribed s

438eventCoincidence :: HasSpiderTimeline x => Coincidence x a -> Event x a

347eventCoincidence :: HasSpiderTimeline x => Coincidence x a -> Event x a

439eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSubscribed c

348eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSubscribed c

440

349

441−eventHold :: Hold x p -> Event x p

350+eventHold :: HasSpiderTimeline x => Hold x p -> Event x p

442eventHold !h = Event $ subscribeHoldEvent h

351eventHold !h = Event $ subscribeHoldEvent h

443

352

444eventDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Event x p

353eventDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Event x p

445eventDyn !j = Event $ \sub -> getDynHold j >>= \h -> subscribeHoldEvent h sub

354eventDyn !j = Event $ \sub -> getDynHold j >>= \h -> subscribeHoldEvent h sub

446

355

447{-# INLINE subscribeCoincidenceInner #-}

356{-# INLINE subscribeCoincidenceInner #-}

448−subscribeCoincidenceInner :: HasSpiderTimeline x => Event x a -> Height -> CoincidenceSubscribed x a -> EventM x (Maybe a, Height, EventSubscribed x)

357+subscribeCoincidenceInner :: CanSubscribe x m => Event x a -> Height -> CoincidenceSubscribed x a -> m (Maybe a, Height, EventSubscribed x)

449subscribeCoincidenceInner inner outerHeight subscribedUnsafe = do

358subscribeCoincidenceInner inner outerHeight subscribedUnsafe = do

450 subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe

359 subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe

451 (subscription@(EventSubscription _ innerSubd), innerOcc) <- subscribeAndRead inner subInner

360 (subscription@(EventSubscription _ innerSubd), innerOcc) <- subscribeAndRead inner subInner

@@ -464,6 +373,16 @@ data Subscriber x a = Subscriber

464 , subscriberRecalculateHeight :: !(Height -> IO ())

373 , subscriberRecalculateHeight :: !(Height -> IO ())

465 }

374 }

466

375

376+--TODO: Move this comment to WeakBag

377+-- These function are constructor functions that are marked NOINLINE so they are

378+-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away

379+-- so any weak references that are attached to the constructors will have their

380+-- finalizer run. Using the opaque constructor, does not see the

381+-- constructor application, so it behaves like an IORef and cannot be fused away.

382+--

383+-- The result is also evaluated to WHNF, since forcing a thunk invalidates

384+-- the weak pointer to it in some cases.

385+

467newSubscriberHold :: (HasSpiderTimeline x, Patch p) => Hold x p -> IO (Subscriber x p)

386newSubscriberHold :: (HasSpiderTimeline x, Patch p) => Hold x p -> IO (Subscriber x p)

468newSubscriberHold h = return $ Subscriber

387newSubscriberHold h = return $ Subscriber

469 { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h

388 { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h

@@ -471,68 +390,85 @@ newSubscriberHold h = return $ Subscriber

471 , subscriberRecalculateHeight = \_ -> return ()

390 , subscriberRecalculateHeight = \_ -> return ()

472 }

391 }

473

392

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

393+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

394+newSubscriberFan subscribed = return $ Subscriber

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

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

477 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed

396 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed

478− tracePropagate (Proxy :: Proxy x) $ show (DMap.size subs) <> " keys subscribed, " <> show (DMap.size a) <> " keys firing"

397+ 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

398 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a

480 scheduleClear $ fanSubscribedOccurrence subscribed

399 scheduleClear $ fanSubscribedOccurrence subscribed

481− let f _ (Pair v subsubs) = do

400+ let f _ (Pair (Identity v) subsubs) = do

482 propagate v $ _fanSubscribedChildren_list subsubs

401 propagate v $ _fanSubscribedChildren_list subsubs

483 return $ Constant ()

402 return $ Constant ()

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

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

485 return ()

404 return ()

486 , subscriberInvalidateHeight = \old -> do

405 , subscriberInvalidateHeight = \old -> do

406+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed

487 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

407 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

488− forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old

408+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old

409+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"

489 , subscriberRecalculateHeight = \new -> do

410 , subscriberRecalculateHeight = \new -> do

411+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed

490 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

412 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

491− forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new

413+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new

414+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"

492 }

415 }

493

416

494newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)

417newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)

495−newSubscriberSwitch subscribed = debugSubscriber ("SubscriberCoincidenceOuter" <> showNodeId subscribed) $ Subscriber

418+newSubscriberSwitch subscribed = return $ Subscriber

496 { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do

419 { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do

420+ tracePropagate (Proxy :: Proxy x) $ "SubscriberSwitch" <> showNodeId subscribed

497 liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a

421 liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a

498 scheduleClear $ switchSubscribedOccurrence subscribed

422 scheduleClear $ switchSubscribedOccurrence subscribed

499 propagate a $ switchSubscribedSubscribers subscribed

423 propagate a $ switchSubscribedSubscribers subscribed

500 , subscriberInvalidateHeight = \_ -> do

424 , subscriberInvalidateHeight = \_ -> do

425+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed

501 oldHeight <- readIORef $ switchSubscribedHeight subscribed

426 oldHeight <- readIORef $ switchSubscribedHeight subscribed

502 when (oldHeight /= invalidHeight) $ do

427 when (oldHeight /= invalidHeight) $ do

503 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight

428 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight

504− WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

429+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

430+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"

431+ , subscriberRecalculateHeight = \new -> do

432+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed

505− , subscriberRecalculateHeight = (`updateSwitchHeight` subscribed)

433+ updateSwitchHeight new subscribed

434+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"

506− }

435+ }

507

436

508newSubscriberCoincidenceOuter :: forall x b. HasSpiderTimeline x => CoincidenceSubscribed x b -> IO (Subscriber x (Event x b))

437newSubscriberCoincidenceOuter :: forall x b. HasSpiderTimeline x => CoincidenceSubscribed x b -> IO (Subscriber x (Event x b))

509−newSubscriberCoincidenceOuter subscribed = debugSubscriber ("SubscriberCoincidenceOuter" <> showNodeId subscribed) $ Subscriber

438+newSubscriberCoincidenceOuter subscribed = return $ Subscriber

510 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do

439 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do

440+ tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceOuter" <> showNodeId subscribed

511 outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed

441 outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed

512 tracePropagate (Proxy :: Proxy x) $ " outerHeight = " <> show outerHeight

442 tracePropagate (Proxy :: Proxy x) $ " outerHeight = " <> show outerHeight

513 (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed

443 (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed

514 tracePropagate (Proxy :: Proxy x) $ " isJust occ = " <> show (isJust occ)

444 tracePropagate (Proxy :: Proxy x) $ " isJust occ = " <> show (isJust occ)

515 tracePropagate (Proxy :: Proxy x) $ " innerHeight = " <> show innerHeight

445 tracePropagate (Proxy :: Proxy x) $ " innerHeight = " <> show innerHeight

516−

517 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd

446 liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd

518 scheduleClear $ coincidenceSubscribedInnerParent subscribed

447 scheduleClear $ coincidenceSubscribedInnerParent subscribed

519 case occ of

448 case occ of

520− Nothing ->

449+ Nothing -> do

521 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height

450 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height

522 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight

451 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight

523− WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight

452+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight

524− WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight

453+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight

525 Just o -> do -- Since it's already firing, no need to adjust height

454 Just o -> do -- Since it's already firing, no need to adjust height

526 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ

455 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ

527 scheduleClear $ coincidenceSubscribedOccurrence subscribed

456 scheduleClear $ coincidenceSubscribedOccurrence subscribed

528 propagate o $ coincidenceSubscribedSubscribers subscribed

457 propagate o $ coincidenceSubscribedSubscribers subscribed

458+ , subscriberInvalidateHeight = \_ -> do

459+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed

529− , subscriberInvalidateHeight = \_ -> invalidateCoincidenceHeight subscribed

460+ invalidateCoincidenceHeight subscribed

461+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"

462+ , subscriberRecalculateHeight = \_ -> do

463+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed

530− , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed

464+ recalculateCoincidenceHeight subscribed

465+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"

531 }

466 }

532

467

533newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)

468newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)

534−newSubscriberCoincidenceInner subscribed = debugSubscriber ("SubscriberCoincidenceInner" <> showNodeId subscribed) $ Subscriber

469+newSubscriberCoincidenceInner subscribed = return $ Subscriber

535 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do

470 { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do

471+ tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceInner" <> showNodeId subscribed

536 occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed

472 occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed

537 case occ of

473 case occ of

538 Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event

474 Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event

@@ -540,8 +476,14 @@ newSubscriberCoincidenceInner subscribed = debugSubscriber ("SubscriberCoinciden

540 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a

476 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a

541 scheduleClear $ coincidenceSubscribedOccurrence subscribed

477 scheduleClear $ coincidenceSubscribedOccurrence subscribed

542 propagate a $ coincidenceSubscribedSubscribers subscribed

478 propagate a $ coincidenceSubscribedSubscribers subscribed

479+ , subscriberInvalidateHeight = \_ -> do

480+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed

543− , subscriberInvalidateHeight = \_ -> invalidateCoincidenceHeight subscribed

481+ invalidateCoincidenceHeight subscribed

482+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"

483+ , subscriberRecalculateHeight = \_ -> do

484+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed

544− , subscriberRecalculateHeight = \_ -> recalculateCoincidenceHeight subscribed

485+ recalculateCoincidenceHeight subscribed

486+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"

545 }

487 }

546

488

547invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()

489invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()

@@ -551,18 +493,18 @@ recalculateSubscriberHeight :: Height -> Subscriber x a -> IO ()

551recalculateSubscriberHeight = flip subscriberRecalculateHeight

493recalculateSubscriberHeight = flip subscriberRecalculateHeight

552

494

553-- | Propagate everything at the current height

495-- | Propagate everything at the current height

554−propagate :: forall x a. HasSpiderTimeline x => a -> WeakBag (Subscriber x a) -> EventM x ()

496+propagate :: a -> WeakBag (Subscriber x a) -> EventM x ()

555−propagate a subscribers = withIncreasedDepth (Proxy::Proxy x) $

497+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

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

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

500+ WeakBag.traverse subscribers $ \s -> subscriberPropagate s a

559

501

560-- | Propagate everything at the current height

502-- | Propagate everything at the current height

561−propagateFast :: forall x a. HasSpiderTimeline x => a -> FastWeakBag (Subscriber x a) -> EventM x ()

503+propagateFast :: a -> FastWeakBag (Subscriber x a) -> EventM x ()

562−propagateFast a subscribers = withIncreasedDepth (Proxy::Proxy x) $

504+propagateFast a subscribers = withIncreasedDepth $ do

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

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

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

507+ FastWeakBag.traverse subscribers $ \s -> subscriberPropagate s a

566

508

567--------------------------------------------------------------------------------

509--------------------------------------------------------------------------------

568-- EventSubscribed

510-- EventSubscribed

@@ -571,16 +513,11 @@ propagateFast a subscribers = withIncreasedDepth (Proxy::Proxy x) $

571toAny :: a -> Any

513toAny :: a -> Any

572toAny = unsafeCoerce

514toAny = unsafeCoerce

573

515

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

516data EventSubscribed x = EventSubscribed

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

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

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

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

582#ifdef DEBUG_CYCLES

519#ifdef DEBUG_CYCLES

583− , eventSubscribedGetParents :: !(IO [EventSubscribed x]) -- For debugging loops

520+ , eventSubscribedGetParents :: !(IO [Some (EventSubscribed x)]) -- For debugging loops

584 , eventSubscribedHasOwnHeightRef :: !Bool

521 , eventSubscribedHasOwnHeightRef :: !Bool

585 , eventSubscribedWhoCreated :: !(IO [String])

522 , eventSubscribedWhoCreated :: !(IO [String])

586#endif

523#endif

@@ -607,23 +544,13 @@ eventSubscribedNever = EventSubscribed

607 , eventSubscribedWhoCreated = return ["never"]

544 , eventSubscribedWhoCreated = return ["never"]

608#endif

545#endif

609 }

546 }

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

547

621−eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x

548+eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x

622eventSubscribedFan !subscribed = EventSubscribed

549eventSubscribedFan !subscribed = EventSubscribed

623 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed

550 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed

624 , eventSubscribedRetained = toAny subscribed

551 , eventSubscribedRetained = toAny subscribed

625#ifdef DEBUG_CYCLES

552#ifdef DEBUG_CYCLES

626− , eventSubscribedGetParents = return [_eventSubscription_subscribed $ fanSubscribedParent subscribed]

553+ , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]

627 , eventSubscribedHasOwnHeightRef = False

554 , eventSubscribedHasOwnHeightRef = False

628 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed

555 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed

629#endif

556#endif

@@ -636,7 +563,7 @@ eventSubscribedSwitch !subscribed = EventSubscribed

636#ifdef DEBUG_CYCLES

563#ifdef DEBUG_CYCLES

637 , eventSubscribedGetParents = do

564 , eventSubscribedGetParents = do

638 s <- readIORef $ switchSubscribedCurrentParent subscribed

565 s <- readIORef $ switchSubscribedCurrentParent subscribed

639− return [_eventSubscription_subscribed s]

566+ return [Some.This $ _eventSubscription_subscribed s]

640 , eventSubscribedHasOwnHeightRef = True

567 , eventSubscribedHasOwnHeightRef = True

641 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed

568 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed

642#endif

569#endif

@@ -649,8 +576,8 @@ eventSubscribedCoincidence !subscribed = EventSubscribed

649#ifdef DEBUG_CYCLES

576#ifdef DEBUG_CYCLES

650 , eventSubscribedGetParents = do

577 , eventSubscribedGetParents = do

651 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed

578 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed

652− let outerParent = _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed

579+ let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed

653− innerParents = maybeToList $ innerSubscription

580+ innerParents = maybeToList $ fmap Some.This innerSubscription

654 return $ outerParent : innerParents

581 return $ outerParent : innerParents

655 , eventSubscribedHasOwnHeightRef = True

582 , eventSubscribedHasOwnHeightRef = True

656 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed

583 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed

@@ -664,20 +591,20 @@ getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es

664whoCreatedEventSubscribed :: EventSubscribed x -> IO [String]

591whoCreatedEventSubscribed :: EventSubscribed x -> IO [String]

665whoCreatedEventSubscribed = eventSubscribedWhoCreated

592whoCreatedEventSubscribed = eventSubscribedWhoCreated

666

593

667−walkInvalidHeightParents :: EventSubscribed x -> IO [EventSubscribed x]

594+walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)]

668walkInvalidHeightParents s0 = do

595walkInvalidHeightParents s0 = do

669− subscribers <- flip execStateT mempty $ ($ s0) $ fix $ \loop s -> do

596+ subscribers <- flip execStateT mempty $ ($ Some.This s0) $ fix $ \loop (Some.This s) -> do

670 h <- liftIO $ readIORef $ eventSubscribedHeightRef s

597 h <- liftIO $ readIORef $ eventSubscribedHeightRef s

671 when (h == invalidHeight) $ do

598 when (h == invalidHeight) $ do

672 when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed

599 when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed

673− modify (s :)

600+ modify (Some.This s :)

674 mapM_ loop =<< liftIO (eventSubscribedGetParents s)

601 mapM_ loop =<< liftIO (eventSubscribedGetParents s)

675− forM_ subscribers $ \s -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight

602+ forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight

676 return subscribers

603 return subscribers

677#endif

604#endif

678

605

679{-# INLINE subscribeHoldEvent #-}

606{-# INLINE subscribeHoldEvent #-}

680−subscribeHoldEvent :: Hold x p -> Subscriber x p -> EventM x (EventSubscription x, Maybe p)

607+subscribeHoldEvent :: CanSubscribe x m => Hold x p -> Subscriber x p -> m (EventSubscription x, Maybe p)

681subscribeHoldEvent = subscribeAndRead . holdEvent

608subscribeHoldEvent = subscribeAndRead . holdEvent

682

609

683--------------------------------------------------------------------------------

610--------------------------------------------------------------------------------

@@ -700,7 +627,7 @@ behaviorPull !p = Behavior $ do

700 val <- liftIO $ readIORef $ pullValue p

627 val <- liftIO $ readIORef $ pullValue p

701 case val of

628 case val of

702 Just subscribed -> do

629 Just subscribed -> do

703− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedPull subscribed)) :))

630+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))

704 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))

631 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))

705 liftIO $ touch $ pullSubscribedOwnInvalidator subscribed

632 liftIO $ touch $ pullSubscribedOwnInvalidator subscribed

706 return $ pullSubscribedValue subscribed

633 return $ pullSubscribedValue subscribed

@@ -709,7 +636,7 @@ behaviorPull !p = Behavior $ do

709 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"

636 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"

710 parentsRef <- liftIO $ newIORef []

637 parentsRef <- liftIO $ newIORef []

711 holdInits <- askBehaviorHoldInits

638 holdInits <- askBehaviorHoldInits

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

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

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

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

714 parents <- liftIO $ readIORef parentsRef

641 parents <- liftIO $ readIORef parentsRef

715 let subscribed = PullSubscribed

642 let subscribed = PullSubscribed

@@ -719,7 +646,7 @@ behaviorPull !p = Behavior $ do

719 , pullSubscribedParents = parents

646 , pullSubscribedParents = parents

720 }

647 }

721 liftIO $ writeIORef (pullValue p) $ Just subscribed

648 liftIO $ writeIORef (pullValue p) $ Just subscribed

722− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedPull subscribed)) :))

649+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))

723 return a

650 return a

724

651

725behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p)

652behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p)

@@ -730,8 +657,7 @@ readHoldTracked :: Hold x p -> BehaviorM x (PatchTarget p)

730readHoldTracked h = do

657readHoldTracked h = do

731 result <- liftIO $ readIORef $ holdValue h

658 result <- liftIO $ readIORef $ holdValue h

732 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))

659 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))

733− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedHold h)) :))

660+ 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

661 return result

736

662

737{-# INLINABLE readBehaviorUntracked #-}

663{-# INLINABLE readBehaviorUntracked #-}

@@ -744,46 +670,42 @@ readBehaviorUntracked b = do

744-- Dynamic

670-- Dynamic

745--------------------------------------------------------------------------------

671--------------------------------------------------------------------------------

746

672

747−type DynamicS x p = Dynamic x (PatchTarget p) p

748−

749−data Dynamic x target p = Dynamic

673+data Dynamic x p = Dynamic

750− { dynamicCurrent :: !(Behavior x target)

674+ { dynamicCurrent :: !(Behavior x (PatchTarget p))

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

675+ , dynamicUpdated :: !(Event x p)

752 }

676 }

753

677

754−deriving instance (HasSpiderTimeline x) => Functor (Dynamic x target)

755−

756−

757−

758−

759−dynamicHold :: Hold x p -> DynamicS x p

678+dynamicHold :: HasSpiderTimeline x => Hold x p -> Dynamic x p

760dynamicHold !h = Dynamic

679dynamicHold !h = Dynamic

761 { dynamicCurrent = behaviorHold h

680 { dynamicCurrent = behaviorHold h

762 , dynamicUpdated = eventHold h

681 , dynamicUpdated = eventHold h

763 }

682 }

764

683

765−dynamicHoldIdentity :: Hold x (Identity a) -> DynamicS x (Identity a)

684+dynamicHoldIdentity :: HasSpiderTimeline x => Hold x (Identity a) -> Dynamic x (Identity a)

766dynamicHoldIdentity = dynamicHold

685dynamicHoldIdentity = dynamicHold

767

686

768−dynamicConst :: PatchTarget p -> DynamicS x p

687+dynamicConst :: PatchTarget p -> Dynamic x p

769dynamicConst !a = Dynamic

688dynamicConst !a = Dynamic

770 { dynamicCurrent = behaviorConst a

689 { dynamicCurrent = behaviorConst a

771 , dynamicUpdated = eventNever

690 , dynamicUpdated = eventNever

772 }

691 }

773

692

774−dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> DynamicS x p

693+dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p

775dynamicDyn !d = Dynamic

694dynamicDyn !d = Dynamic

776 { dynamicCurrent = behaviorDyn d

695 { dynamicCurrent = behaviorDyn d

777 , dynamicUpdated = eventDyn d

696 , dynamicUpdated = eventDyn d

778 }

697 }

779

698

780−dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> DynamicS x (Identity a)

699+dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a)

781dynamicDynIdentity = dynamicDyn

700dynamicDynIdentity = dynamicDyn

782

701

783--------------------------------------------------------------------------------

702--------------------------------------------------------------------------------

784-- Combinators

703-- Combinators

785--------------------------------------------------------------------------------

704--------------------------------------------------------------------------------

786

705

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

707+--representational so we can use coerce

708+

787--type role Hold representational

709--type role Hold representational

788data Hold x p

710data Hold x p

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

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

@@ -795,7 +717,9 @@ data Hold x p

795#endif

717#endif

796 }

718 }

797

719

798−-- | A statically allocated 'SpiderTimeline'

720+-- | A statically allocated 'SpiderTimeline'; this is the only instance of

721+-- 'SpiderTimeline' that can used when using

722+-- -fspecialize-to-spidertimeline-global.

799data Global

723data Global

800

724

801{-# NOINLINE globalSpiderTimelineEnv #-}

725{-# NOINLINE globalSpiderTimelineEnv #-}

@@ -804,27 +728,30 @@ globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv

804

728

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

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

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

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

807−newtype SpiderTimelineEnv x = STE {unSTE :: SpiderTimelineEnv' x}

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

731+data SpiderTimelineEnv x = SpiderTimelineEnv

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

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

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

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

815#ifdef DEBUG

734#ifdef DEBUG

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

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

817#endif

736#endif

818 }

737 }

819−type role SpiderTimelineEnv' phantom

738+type role SpiderTimelineEnv nominal

820

739

821instance Eq (SpiderTimelineEnv x) where

740instance Eq (SpiderTimelineEnv x) where

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

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

823

742

824instance GEq SpiderTimelineEnv where

743instance GEq SpiderTimelineEnv where

744+#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES

745+ geqToEq _ = id

746+ geqUnify (a :: SpiderTimelineEnv a) (b :: SpiderTimelineEnv b) different same = if _spiderTimeline_lock a == _spiderTimeline_lock b

747+ then case unsafeCoerce Refl :: a :~: b of

748+ Refl -> same -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments

749+ else different

750+#else

825− a `geq` b = if _spiderTimeline_lock (unSTE a) == _spiderTimeline_lock (unSTE b)

751+ 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

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

827 else Nothing

753 else Nothing

754+#endif

828

755

829data EventEnv x

756data EventEnv x

830 = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe

757 = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe

@@ -832,9 +759,8 @@ data EventEnv x

832 , eventEnvDynInits :: !(IORef [SomeDynInit x])

759 , eventEnvDynInits :: !(IORef [SomeDynInit x])

833 , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])

760 , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])

834 , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe

761 , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe

835− , eventEnvClears :: !(IORef [Some Clear]) -- Needed for Subscribe

762+ , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe

836− , eventEnvIntClears :: !(IORef [Some IntClear])

837− , eventEnvRootClears :: !(IORef [Some RootClear])

763+ , eventEnvRootClears :: !(IORef [SomeRootClear])

838 , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe

764 , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe

839 , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe

765 , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe

840 , eventEnvDelayedMerges :: !(IORef (IntMap [EventM x ()]))

766 , eventEnvDelayedMerges :: !(IORef (IntMap [EventM x ()]))

@@ -845,7 +771,7 @@ runEventM :: EventM x a -> IO a

845runEventM = unEventM

771runEventM = unEventM

846

772

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

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

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

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

849

775

850class MonadIO m => Defer a m where

776class MonadIO m => Defer a m where

851 getDeferralQueue :: m (IORef [a])

777 getDeferralQueue :: m (IORef [a])

@@ -894,7 +820,11 @@ instance HasSpiderTimeline x => HasCurrentHeight x (EventM x) where

894 delayedRef <- asksEventEnv eventEnvDelayedMerges

820 delayedRef <- asksEventEnv eventEnvDelayedMerges

895 liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [subscribed]

821 liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [subscribed]

896

822

823+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

824+class x ~ Global => HasSpiderTimeline x where

825+#else

897class HasSpiderTimeline x where

826class HasSpiderTimeline x where

827+#endif

898 -- | Retrieve the current SpiderTimelineEnv

828 -- | Retrieve the current SpiderTimelineEnv

899 spiderTimeline :: SpiderTimelineEnv x

829 spiderTimeline :: SpiderTimelineEnv x

900

830

@@ -906,29 +836,21 @@ putCurrentHeight h = do

906 heightRef <- asksEventEnv eventEnvCurrentHeight

836 heightRef <- asksEventEnv eventEnvCurrentHeight

907 liftIO $ writeIORef heightRef $! h

837 liftIO $ writeIORef heightRef $! h

908

838

909−instance HasSpiderTimeline x => Defer (Some Clear) (EventM x) where

839+instance HasSpiderTimeline x => Defer SomeClear (EventM x) where

910 {-# INLINE getDeferralQueue #-}

840 {-# INLINE getDeferralQueue #-}

911 getDeferralQueue = asksEventEnv eventEnvClears

841 getDeferralQueue = asksEventEnv eventEnvClears

912

842

913{-# INLINE scheduleClear #-}

843{-# INLINE scheduleClear #-}

914−scheduleClear :: Defer (Some Clear) m => IORef (Maybe a) -> m ()

844+scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()

915−scheduleClear r = defer $ Some $ Clear r

845+scheduleClear r = defer $ SomeClear r

916

846

917−instance HasSpiderTimeline x => Defer (Some IntClear) (EventM x) where

847+instance HasSpiderTimeline x => Defer SomeRootClear (EventM x) where

918− {-# INLINE getDeferralQueue #-}

919− getDeferralQueue = asksEventEnv eventEnvIntClears

920−

921−{-# INLINE scheduleIntClear #-}

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 #-}

848 {-# INLINE getDeferralQueue #-}

927 getDeferralQueue = asksEventEnv eventEnvRootClears

849 getDeferralQueue = asksEventEnv eventEnvRootClears

928

850

929{-# INLINE scheduleRootClear #-}

851{-# INLINE scheduleRootClear #-}

930−scheduleRootClear :: Defer (Some RootClear) m => IORef (DMap k Identity) -> m ()

852+scheduleRootClear :: Defer SomeRootClear m => IORef (DMap k Identity) -> m ()

931−scheduleRootClear r = defer $ Some $ RootClear r

853+scheduleRootClear r = defer $ SomeRootClear r

932

854

933instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where

855instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where

934 {-# INLINE getDeferralQueue #-}

856 {-# INLINE getDeferralQueue #-}

@@ -957,7 +879,7 @@ hold v0 e = do

957 return h

879 return h

958

880

959{-# INLINE getHoldEventSubscription #-}

881{-# INLINE getHoldEventSubscription #-}

960−getHoldEventSubscription :: forall p x. (HasSpiderTimeline x, Patch p) => Hold x p -> EventM x (EventSubscription x)

882+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

883getHoldEventSubscription h = do

962 ep <- liftIO $ readIORef $ holdParent h

884 ep <- liftIO $ readIORef $ holdParent h

963 case ep of

885 case ep of

@@ -983,9 +905,9 @@ getHoldEventSubscription h = do

983

905

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

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

985

907

908+--type role BehaviorM representational

986-- BehaviorM can sample behaviors

909-- BehaviorM can sample behaviors

987−newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderIO (BehaviorEnv x) a }

910+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

911

990instance Monad (BehaviorM x) where

912instance Monad (BehaviorM x) where

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

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

@@ -994,16 +916,14 @@ instance Monad (BehaviorM x) where

994 BehaviorM x >> BehaviorM y = BehaviorM $ x >> y

916 BehaviorM x >> BehaviorM y = BehaviorM $ x >> y

995 {-# INLINE return #-}

917 {-# INLINE return #-}

996 return x = BehaviorM $ return x

918 return x = BehaviorM $ return x

997−#if !MIN_VERSION_base(4,13,0)

998 {-# INLINE fail #-}

919 {-# INLINE fail #-}

999 fail s = BehaviorM $ fail s

920 fail s = BehaviorM $ fail s

1000−#endif

1001

921

1002data BehaviorSubscribed x a

922data BehaviorSubscribed x a

1003 = forall p. BehaviorSubscribedHold (Hold x p)

923 = forall p. BehaviorSubscribedHold (Hold x p)

1004 | BehaviorSubscribedPull (PullSubscribed x a)

924 | BehaviorSubscribedPull (PullSubscribed x a)

1005

925

1006−newtype SomeBehaviorSubscribed x = SomeBehaviorSubscribed (Some (BehaviorSubscribed x))

926+data SomeBehaviorSubscribed x = forall a. SomeBehaviorSubscribed (BehaviorSubscribed x a)

1007

927

1008--type role PullSubscribed representational

928--type role PullSubscribed representational

1009data PullSubscribed x a

929data PullSubscribed x a

@@ -1038,7 +958,7 @@ data RootSubscribed x a = forall k. GCompare k => RootSubscribed

1038#endif

958#endif

1039 }

959 }

1040

960

1041−data Root x k

961+data Root x (k :: * -> *)

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

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

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

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

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

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

@@ -1057,7 +977,22 @@ data SomeMergeUpdate x = SomeMergeUpdate

1057newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }

977newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }

1058

978

1059-- EventM can do everything BehaviorM can, plus create holds

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

980+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

981+

982+newtype ComputeM x a = ComputeM (ReaderT (IORef [SomeHoldInit x], IORef [SomeDynInit x]) IO a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

983+

984+instance Defer (SomeHoldInit x) (ComputeM x) where

985+ getDeferralQueue = ComputeM $ asks fst

986+

987+instance Defer (SomeDynInit x) (ComputeM x) where

988+ getDeferralQueue = ComputeM $ asks snd

989+

990+{-# INLINABLE runComputeM #-}

991+runComputeM :: (Defer (SomeHoldInit x) m, Defer (SomeDynInit x) m) => ComputeM x a -> m a

992+runComputeM (ComputeM a) = do

993+ holds <- getDeferralQueue

994+ dyns <- getDeferralQueue

995+ liftIO $ runReaderT a (holds, dyns)

1061

996

1062newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }

997newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }

1063

998

@@ -1082,8 +1017,7 @@ heightBagFromList :: [Height] -> HeightBag

1082heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights

1017heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights

1083

1018

1084heightBagAdd :: Height -> HeightBag -> HeightBag

1019heightBagAdd :: Height -> HeightBag -> HeightBag

1085−heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $

1020+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

1021

1088heightBagRemove :: Height -> HeightBag -> HeightBag

1022heightBagRemove :: Height -> HeightBag -> HeightBag

1089heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of

1023heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of

@@ -1092,13 +1026,6 @@ heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.loo

1092 0 -> IntMap.delete h c

1026 0 -> IntMap.delete h c

1093 _ -> IntMap.insert h (pred old) c

1027 _ -> IntMap.insert h (pred old) c

1094

1028

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

1029heightBagMax :: HeightBag -> Height

1103heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of

1030heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of

1104 Just ((h, _), _) -> Height h

1031 Just ((h, _), _) -> Height h

@@ -1116,25 +1043,25 @@ heightBagVerify b@(HeightBag s c) = if

1116heightBagVerify = id

1043heightBagVerify = id

1117#endif

1044#endif

1118

1045

1119−data FanSubscribedChildren x k v a = FanSubscribedChildren

1046+data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren

1120− { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x (v a)))

1047+ { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a))

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

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

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

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

1123 }

1050 }

1124

1051

1125−data FanSubscribed x k v

1052+data FanSubscribed (x :: *) k

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

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

1127− , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k v)))

1054+ , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))

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

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

1129 , fanSubscribedParent :: !(EventSubscription x)

1056 , fanSubscribedParent :: !(EventSubscription x)

1130#ifdef DEBUG_NODEIDS

1057#ifdef DEBUG_NODEIDS

1131 , fanSubscribedNodeId :: Int

1058 , fanSubscribedNodeId :: Int

1132#endif

1059#endif

1133 }

1060 }

1134

1061

1135−data Fan x k v

1062+data Fan x k

1136− = Fan { fanParent :: !(Event x (DMap k v))

1063+ = Fan { fanParent :: !(Event x (DMap k Identity))

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

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

1138 }

1065 }

1139

1066

1140data SwitchSubscribed x a

1067data SwitchSubscribed x a

@@ -1188,35 +1115,20 @@ newInvalidatorSwitch subd = return $! InvalidatorSwitch subd

1188newInvalidatorPull :: Pull x a -> IO (Invalidator x)

1115newInvalidatorPull :: Pull x a -> IO (Invalidator x)

1189newInvalidatorPull p = return $! InvalidatorPull p

1116newInvalidatorPull p = return $! InvalidatorPull p

1190

1117

1191−instance HasSpiderTimeline x => Filterable (Event x) where

1118+instance HasSpiderTimeline x => FunctorMaybe (Event x) where

1192− mapMaybe f = push $ return . f

1119+ fmapMaybe f = push $ return . f

1193

1120

1194instance HasSpiderTimeline x => Align (Event x) where

1121instance HasSpiderTimeline x => Align (Event x) where

1195 nil = eventNever

1122 nil = eventNever

1196−#if MIN_VERSION_these(0, 8, 0)

1197−instance HasSpiderTimeline x => Semialign (Event x) where

1198−#endif

1199− align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $

1123+ align ea eb = fmapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]

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−

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

1210− | BuildDyn !(EventM x (PatchTarget p), Event x p)

1211− | HoldDyn !(Hold x p)

1212

1124

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

1125+newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (PatchTarget p), Event x p) (Hold x p)) }

1214

1126

1215−newMapDyn :: HasSpiderTimeline x => (a -> b) -> DynamicS x (Identity a) -> DynamicS x (Identity b)

1127+newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)

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

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

1217

1129

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

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

1131+zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c)

1220zipDynWith f da db =

1132zipDynWith f da db =

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

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

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

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

@@ -1231,20 +1143,24 @@ zipDynWith f da db =

1231 return $ Just $ Identity $ f a b

1143 return $ Just $ Identity $ f a b

1232 in dynamicDynIdentity $ unsafeBuildDynamic (f <$> readBehaviorUntracked (dynamicCurrent da) <*> readBehaviorUntracked (dynamicCurrent db)) ec

1144 in dynamicDynIdentity $ unsafeBuildDynamic (f <$> readBehaviorUntracked (dynamicCurrent da) <*> readBehaviorUntracked (dynamicCurrent db)) ec

1233

1145

1234−buildDynamic :: (Defer (SomeDynInit x) m, Patch p) => EventM x (PatchTarget p) -> Event x p -> m (Dyn x p)

1146+buildDynamic :: (Defer (SomeDynInit x) m, Patch p) => BehaviorM x (PatchTarget p) -> Event x p -> m (Dyn x p)

1235buildDynamic readV0 v' = do

1147buildDynamic readV0 v' = do

1236− result <- liftIO $ newIORef $ BuildDyn (readV0, v')

1148+ result <- liftIO $ newIORef $ Left (readV0, v')

1237 let !d = Dyn result

1149 let !d = Dyn result

1238 defer $ SomeDynInit d

1150 defer $ SomeDynInit d

1239 return d

1151 return d

1240

1152

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

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

1242−unsafeBuildDynamic readV0 v' =

1154+unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ Left x

1243− Dyn $ unsafePerformIO $ newIORef $ UnsafeDyn (readV0, v')

1155+ where x = (readV0, v')

1244

1156

1245-- ResultM can read behaviors and events

1157-- ResultM can read behaviors and events

1246type ResultM = EventM

1158type ResultM = EventM

1247

1159

1160+{-# NOINLINE unsafeNewIORef #-}

1161+unsafeNewIORef :: a -> b -> IORef b

1162+unsafeNewIORef _ b = unsafePerformIO $ newIORef b

1163+

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

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

1249 fmap f = push $ return . Just . f

1165 fmap f = push $ return . Just . f

1250

1166

@@ -1257,42 +1173,33 @@ push f e = cacheEvent (pushCheap f e)

1257

1173

1258{-# INLINABLE pull #-}

1174{-# INLINABLE pull #-}

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

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

1260−pull a = unsafePerformIO $ do

1261− ref <- newIORef Nothing

1262−#ifdef DEBUG_NODEIDS

1263− nid <- newNodeId

1264−#endif

1265− pure $ behaviorPull $ Pull

1176+pull a = behaviorPull $ Pull

1266− { pullCompute = a

1177+ { pullCompute = a

1267− , pullValue = ref

1178+ , pullValue = unsafeNewIORef a Nothing

1268#ifdef DEBUG_NODEIDS

1179#ifdef DEBUG_NODEIDS

1269− , pullNodeId = nid

1180+ , pullNodeId = unsafeNodeId a

1270#endif

1181#endif

1271− }

1182+ }

1272

1183

1273{-# INLINABLE switch #-}

1184{-# INLINABLE switch #-}

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

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

1275−switch a = unsafePerformIO $ do

1276− ref <- newIORef Nothing

1277− pure $ eventSwitch $ Switch

1186+switch a = eventSwitch $ Switch

1278− { switchParent = a

1187+ { switchParent = a

1279− , switchSubscribed = ref

1188+ , switchSubscribed = unsafeNewIORef a Nothing

1280− }

1189+ }

1281

1190

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

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

1283−coincidence a = unsafePerformIO $ do

1284− ref <- newIORef Nothing

1285− pure $ eventCoincidence $ Coincidence

1192+coincidence a = eventCoincidence $ Coincidence

1286− { coincidenceParent = a

1193+ { coincidenceParent = a

1287− , coincidenceSubscribed = ref

1194+ , coincidenceSubscribed = unsafeNewIORef a Nothing

1288− }

1195+ }

1289

1196

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

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

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

1292run roots after = do

1199run roots after = do

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

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

1294− let t = spiderTimeline :: SpiderTimelineEnv x

1201+ t <- SpiderHost ask

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

1202+ result <- SpiderHost $ lift $ withMVar (_spiderTimeline_lock t) $ \_ -> flip runReaderT t $ unSpiderHost $ runFrame $ do

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

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

1297 occBefore <- liftIO $ do

1204 occBefore <- liftIO $ do

1298 occBefore <- readIORef occRef

1205 occBefore <- readIORef occRef

@@ -1330,11 +1237,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?)

1237 GT -> scheduleMerge' height heightRef a -- The height has been increased (by a coincidence event; TODO: is this the only way?)

1331 EQ -> a

1238 EQ -> a

1332

1239

1333−newtype Clear a = Clear (IORef (Maybe a))

1240+data SomeClear = forall a. SomeClear (IORef (Maybe a))

1334

1241

1335−newtype IntClear a = IntClear (IORef (IntMap a))

1242+data SomeRootClear = forall k. SomeRootClear (IORef (DMap k Identity))

1336−

1337−newtype RootClear k = RootClear (IORef (DMap k Identity))

1338

1243

1339data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a

1244data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a

1340

1245

@@ -1346,110 +1251,55 @@ mkWeakPtrWithDebug x debugNote = do

1346 x' <- evaluate x

1251 x' <- evaluate x

1347 mkWeakPtr x' $

1252 mkWeakPtr x' $

1348 if debugFinalize

1253 if debugFinalize

1349− then Just $ debugStrLn $ "finalizing: " ++ debugNote

1254+ then Just $ putStrLn $ "finalizing: " ++ debugNote

1350 else Nothing

1255 else Nothing

1351

1256

1352type WeakList a = [Weak a]

1257type WeakList a = [Weak a]

1353

1258

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 #-}

1259{-# INLINE withIncreasedDepth #-}

1260+#ifdef DEBUG

1382−withIncreasedDepth :: forall proxy x m a. CanTrace x m => proxy x -> m a -> m a

1261+withIncreasedDepth :: CanTrace x m => m a -> m a

1383−withIncreasedDepth _ a = do

1262+withIncreasedDepth a = do

1263+ spiderTimeline <- askSpiderTimelineEnv

1384− liftIO $ modifyIORef' (_spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)) succ

1264+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ

1385 result <- a

1265 result <- a

1386− liftIO $ modifyIORef' (_spiderTimeline_depth $ unSTE (spiderTimeline :: SpiderTimelineEnv x)) pred

1266+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred

1387 return result

1267 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

1268#else

1269+withIncreasedDepth :: m a -> m a

1270+withIncreasedDepth = id

1271+#endif

1413

1272

1414−{-# INLINE withIncreasedDepth #-}

1273+type CanTrace x m = (HasSpiderTimeline x, MonadIO m)

1415−withIncreasedDepth :: proxy x -> m a -> m a

1416−withIncreasedDepth _ = id

1417

1274

1418{-# INLINE tracePropagate #-}

1275{-# INLINE tracePropagate #-}

1419tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()

1276tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()

1420−tracePropagate _ _ = return ()

1277+tracePropagate p = traceWhen p debugPropagate

1421

1278

1422{-# INLINE traceInvalidate #-}

1279{-# INLINE traceInvalidate #-}

1423traceInvalidate :: String -> IO ()

1280traceInvalidate :: String -> IO ()

1424−traceInvalidate _ = return ()

1281+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−

1434−{-# INLINE debugSubscriber' #-}

1435−debugSubscriber' :: String -> Subscriber x a -> Subscriber x a

1436−debugSubscriber' _ = id

1437

1282

1283+{-# INLINE traceWhen #-}

1284+traceWhen :: (CanTrace x m) => proxy x -> Bool -> String -> m ()

1285+traceWhen p b message = traceMWhen p b $ return message

1438

1286

1439−

1440−{-# INLINE trace #-}

1287+{-# INLINE traceMWhen #-}

1441−trace :: (CanTrace x m) => proxy x -> String -> m ()

1288+traceMWhen :: (CanTrace x m) => proxy x -> Bool -> m String -> m ()

1442−trace _ _ = return ()

1289+traceMWhen _ b getMessage = when b $ do

1443−

1290+ message <- getMessage

1444−{-# INLINE traceM #-}

1291+#ifdef DEBUG

1445−traceM :: (CanTrace x m) => proxy x -> m String -> m ()

1292+ spiderTimeline <- askSpiderTimelineEnv

1446−traceM _ _ = return ()

1293+ d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline

1447−

1294+#else

1295+ let d = 0

1448#endif

1296#endif

1297+ liftIO $ putStrLn $ replicate d ' ' <> message

1449

1298

1450whoCreatedIORef :: IORef a -> IO [String]

1299whoCreatedIORef :: IORef a -> IO [String]

1451whoCreatedIORef (IORef a) = whoCreated $! a

1300whoCreatedIORef (IORef a) = whoCreated $! a

1452

1301

1302+#ifdef DEBUG_CYCLES

1453groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]

1303groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]

1454groupByHead = \case

1304groupByHead = \case

1455 [] -> []

1305 [] -> []

@@ -1460,54 +1310,20 @@ groupByHead = \case

1460 | otherwise -> (x, xs :| []) : l

1310 | otherwise -> (x, xs :| []) : l

1461

1311

1462listsToForest :: Eq a => [[a]] -> Forest a

1312listsToForest :: Eq a => [[a]] -> Forest a

1463−listsToForest lists = buildForest <$> groupByHead (mapMaybe nonEmpty lists)

1313+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

1314#endif

1475

1315

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

1496−

1497−

1498{-# INLINE propagateSubscriberHold #-}

1316{-# INLINE propagateSubscriberHold #-}

1499propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()

1317propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()

1500propagateSubscriberHold h a = do

1318propagateSubscriberHold h a = do

1501− {-# SCC "trace" #-} when debugPropagate $ traceM (Proxy :: Proxy x) $ liftIO $ do

1319+ {-# SCC "trace" #-} traceMWhen (Proxy :: Proxy x) debugPropagate $ liftIO $ do

1502 invalidators <- liftIO $ readIORef $ holdInvalidators h

1320 invalidators <- liftIO $ readIORef $ holdInvalidators h

1503 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)

1321 return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)

1504−

1505 v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h

1322 v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h

1506 case {-# SCC "apply" #-} apply a v of

1323 case {-# SCC "apply" #-} apply a v of

1507 Nothing -> return ()

1324 Nothing -> return ()

1508 Just v' -> do

1325 Just v' -> do

1509− {-# SCC "trace2" #-} withIncreasedDepth (Proxy :: Proxy x) $

1510− tracePropagate (Proxy :: Proxy x) ("propagateSubscriberHold: assigning Hold" <> showNodeId h)

1326+ {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate (Proxy :: Proxy x) $ "propagateSubscriberHold: assigning Hold" <> showNodeId h

1511 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h

1327 vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h

1512 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h

1328 iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h

1513 defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'

1329 defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'

@@ -1515,25 +1331,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

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

1516

1332

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

1333runBehaviorM :: 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)

1334+runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)

1519

1335

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

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

1521askInvalidator = do

1337askInvalidator = do

1522− (!m, _) <- ask

1338+ (!m, _) <- BehaviorM ask

1523 case m of

1339 case m of

1524 Nothing -> return Nothing

1340 Nothing -> return Nothing

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

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

1526

1342

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

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

1528askParentsRef = do

1344askParentsRef = do

1529− (!m, _) <- ask

1345+ (!m, _) <- BehaviorM ask

1530 case m of

1346 case m of

1531 Nothing -> return Nothing

1347 Nothing -> return Nothing

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

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

1533

1349

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

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

1535askBehaviorHoldInits = do

1351askBehaviorHoldInits = do

1536− (_, !his) <- ask

1352+ (_, !his) <- BehaviorM ask

1537 return his

1353 return his

1538

1354

1539{-# INLINE getDynHold #-}

1355{-# INLINE getDynHold #-}

@@ -1541,27 +1357,30 @@ getDynHold :: (Defer (SomeHoldInit x) m, Patch p) => Dyn x p -> m (Hold x p)

1541getDynHold d = do

1357getDynHold d = do

1542 mh <- liftIO $ readIORef $ unDyn d

1358 mh <- liftIO $ readIORef $ unDyn d

1543 case mh of

1359 case mh of

1544− HoldDyn h -> return h

1360+ Right h -> return h

1545− UnsafeDyn (readV0, v') -> do

1361+ Left (readV0, v') -> do

1546 holdInits <- getDeferralQueue

1362 holdInits <- getDeferralQueue

1547 v0 <- liftIO $ runBehaviorM readV0 Nothing holdInits

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

1364 h <- hold v0 v'

1555− liftIO $ writeIORef (unDyn d) $ HoldDyn h

1365+ liftIO $ writeIORef (unDyn d) $ Right h

1556 return h

1366 return h

1557

1367

1558−

1559-- Always refers to 0

1368-- Always refers to 0

1560{-# NOINLINE zeroRef #-}

1369{-# NOINLINE zeroRef #-}

1561zeroRef :: IORef Height

1370zeroRef :: IORef Height

1562zeroRef = unsafePerformIO $ newIORef zeroHeight

1371zeroRef = unsafePerformIO $ newIORef zeroHeight

1563

1372

1373+type CanSubscribe x m =

1374+ ( HasSpiderTimeline x

1375+ , HasCurrentHeight x m

1376+ , Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m -- The things we need to lazily initialize state

1377+ , Defer SomeClear m -- Wiping out event firings

1378+ , Defer (SomeAssignment x) m -- Updating state

1379+ , Defer (SomeResetCoincidence x) m

1380+ , m ~ EventM x

1381+ )

1382+

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)

1383+getRootSubscribed :: GCompare k => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)

1565getRootSubscribed k r sub = do

1384getRootSubscribed k r sub = do

1566 mSubscribed <- readIORef $ rootSubscribed r

1385 mSubscribed <- readIORef $ rootSubscribed r

1567 let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r

1386 let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r

@@ -1575,14 +1394,9 @@ getRootSubscribed k r sub = do

1575 let !cached = rootSubscribed r

1394 let !cached = rootSubscribed r

1576 uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"

1395 uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"

1577 (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed

1396 (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed

1578−

1579− tracePropagate (Proxy::Proxy x) $ "getRootSubscribed: calling rootInit"

1397+ when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"

1580−

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

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

1582 writeIORef uninitRef $! uninit

1399 writeIORef uninitRef $! uninit

1583−#ifdef DEBUG_NODEIDS

1584− nid <- newNodeId

1585−#endif

1586 let !subscribed = RootSubscribed

1400 let !subscribed = RootSubscribed

1587 { rootSubscribedKey = k

1401 { rootSubscribedKey = k

1588 , rootSubscribedCachedSubscribed = cached

1402 , rootSubscribedCachedSubscribed = cached

@@ -1591,7 +1405,7 @@ getRootSubscribed k r sub = do

1591 , rootSubscribedUninit = uninit

1405 , rootSubscribedUninit = uninit

1592 , rootSubscribedWeakSelf = weakSelf

1406 , rootSubscribedWeakSelf = weakSelf

1593#ifdef DEBUG_NODEIDS

1407#ifdef DEBUG_NODEIDS

1594− , rootSubscribedNodeId = nid

1408+ , rootSubscribedNodeId = unsafeNodeId (k, r, subs)

1595#endif

1409#endif

1596 }

1410 }

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

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

@@ -1621,90 +1435,8 @@ cleanupRootSubscribed self@RootSubscribed { rootSubscribedKey = k, rootSubscribe

1621subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO WeakBagTicket

1435subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO WeakBagTicket

1622subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed

1436subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed

1623

1437

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 #-}

1438{-# 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))

1439+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

1440getFanSubscribed k f sub = do

1709 mSubscribed <- liftIO $ readIORef $ fanSubscribed f

1441 mSubscribed <- liftIO $ readIORef $ fanSubscribed f

1710 case mSubscribed of

1442 case mSubscribed of

@@ -1722,16 +1454,13 @@ getFanSubscribed k f sub = do

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

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

1723 occRef <- liftIO $ newIORef parentOcc

1455 occRef <- liftIO $ newIORef parentOcc

1724 when (isJust parentOcc) $ scheduleClear occRef

1456 when (isJust parentOcc) $ scheduleClear occRef

1725−#ifdef DEBUG_NODEIDS

1726− nid <- liftIO newNodeId

1727−#endif

1728 let subscribed = FanSubscribed

1457 let subscribed = FanSubscribed

1729 { fanSubscribedCachedSubscribed = fanSubscribed f

1458 { fanSubscribedCachedSubscribed = fanSubscribed f

1730 , fanSubscribedOccurrence = occRef

1459 , fanSubscribedOccurrence = occRef

1731 , fanSubscribedParent = subscription

1460 , fanSubscribedParent = subscription

1732 , fanSubscribedSubscribers = subscribersRef

1461 , fanSubscribedSubscribers = subscribersRef

1733#ifdef DEBUG_NODEIDS

1462#ifdef DEBUG_NODEIDS

1734− , fanSubscribedNodeId = nid

1463+ , fanSubscribedNodeId = unsafeNodeId f

1735#endif

1464#endif

1736 }

1465 }

1737 let !self = (k, subscribed)

1466 let !self = (k, subscribed)

@@ -1741,7 +1470,7 @@ getFanSubscribed k f sub = do

1741 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed

1470 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed

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

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

1743

1472

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

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

1745cleanupFanSubscribed (k, subscribed) = do

1474cleanupFanSubscribed (k, subscribed) = do

1746 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

1475 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

1747 let reducedSubscribers = DMap.delete k subscribers

1476 let reducedSubscribers = DMap.delete k subscribers

@@ -1753,7 +1482,7 @@ cleanupFanSubscribed (k, subscribed) = do

1753 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers

1482 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers

1754

1483

1755{-# INLINE subscribeFanSubscribed #-}

1484{-# INLINE subscribeFanSubscribed #-}

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

1485+subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO WeakBagTicket

1757subscribeFanSubscribed k subscribed sub = do

1486subscribeFanSubscribed k subscribed sub = do

1758 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

1487 subscribers <- readIORef $ fanSubscribedSubscribers subscribed

1759 case DMap.lookup k subscribers of

1488 case DMap.lookup k subscribers of

@@ -1766,7 +1495,7 @@ subscribeFanSubscribed k subscribed sub = do

1766 Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed

1495 Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed

1767

1496

1768{-# INLINABLE getSwitchSubscribed #-}

1497{-# INLINABLE getSwitchSubscribed #-}

1769−getSwitchSubscribed :: HasSpiderTimeline x => Switch x a -> Subscriber x a -> EventM x (WeakBagTicket, SwitchSubscribed x a, Maybe a)

1498+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

1499getSwitchSubscribed s sub = do

1771 mSubscribed <- liftIO $ readIORef $ switchSubscribed s

1500 mSubscribed <- liftIO $ readIORef $ switchSubscribed s

1772 case mSubscribed of

1501 case mSubscribed of

@@ -1791,9 +1520,6 @@ getSwitchSubscribed s sub = do

1791 when (isJust parentOcc) $ scheduleClear occRef

1520 when (isJust parentOcc) $ scheduleClear occRef

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

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

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

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

1794−#ifdef DEBUG_NODEIDS

1795− nid <- liftIO newNodeId

1796−#endif

1797 let !subscribed = SwitchSubscribed

1523 let !subscribed = SwitchSubscribed

1798 { switchSubscribedCachedSubscribed = switchSubscribed s

1524 { switchSubscribedCachedSubscribed = switchSubscribed s

1799 , switchSubscribedOccurrence = occRef

1525 , switchSubscribedOccurrence = occRef

@@ -1806,7 +1532,7 @@ getSwitchSubscribed s sub = do

1806 , switchSubscribedCurrentParent = subscriptionRef

1532 , switchSubscribedCurrentParent = subscriptionRef

1807 , switchSubscribedWeakSelf = weakSelf

1533 , switchSubscribedWeakSelf = weakSelf

1808#ifdef DEBUG_NODEIDS

1534#ifdef DEBUG_NODEIDS

1809− , switchSubscribedNodeId = nid

1535+ , switchSubscribedNodeId = unsafeNodeId s

1810#endif

1536#endif

1811 }

1537 }

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

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

@@ -1825,7 +1551,7 @@ subscribeSwitchSubscribed :: SwitchSubscribed x a -> Subscriber x a -> IO WeakBa

1825subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed

1551subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed

1826

1552

1827{-# INLINABLE getCoincidenceSubscribed #-}

1553{-# INLINABLE getCoincidenceSubscribed #-}

1828−getCoincidenceSubscribed :: forall x a. HasSpiderTimeline x => Coincidence x a -> Subscriber x a -> EventM x (WeakBagTicket, CoincidenceSubscribed x a, Maybe a)

1554+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

1555getCoincidenceSubscribed c sub = do

1830 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c

1556 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c

1831 case mSubscribed of

1557 case mSubscribed of

@@ -1851,9 +1577,6 @@ getCoincidenceSubscribed c sub = do

1851 scheduleClear innerSubdRef

1577 scheduleClear innerSubdRef

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

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

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

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

1854−#ifdef DEBUG_NODEIDS

1855− nid <- liftIO newNodeId

1856−#endif

1857 let subscribed = CoincidenceSubscribed

1580 let subscribed = CoincidenceSubscribed

1858 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c

1581 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c

1859 , coincidenceSubscribedOccurrence = occRef

1582 , coincidenceSubscribedOccurrence = occRef

@@ -1864,7 +1587,7 @@ getCoincidenceSubscribed c sub = do

1864 , coincidenceSubscribedInnerParent = innerSubdRef

1587 , coincidenceSubscribedInnerParent = innerSubdRef

1865 , coincidenceSubscribedWeakSelf = weakSelf

1588 , coincidenceSubscribedWeakSelf = weakSelf

1866#ifdef DEBUG_NODEIDS

1589#ifdef DEBUG_NODEIDS

1867− , coincidenceSubscribedNodeId = nid

1590+ , coincidenceSubscribedNodeId = unsafeNodeId c

1868#endif

1591#endif

1869 }

1592 }

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

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

@@ -1881,72 +1604,57 @@ cleanupCoincidenceSubscribed subscribed = do

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

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

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

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

1883

1606

1884−{-# INLINE mergeG #-}

1607+{-# INLINE merge #-}

1885−mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k)

1608+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))

1887− -> DynamicS x (PatchDMap k q) -> Event x (DMap k v)

1888−mergeG nt d = cacheEvent (mergeCheap nt d)

1609+merge d = cacheEvent (mergeCheap d)

1889

1610

1890{-# INLINE mergeWithMove #-}

1611{-# INLINE mergeWithMove #-}

1891−mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k)

1612+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))

1893− -> DynamicS x (PatchDMapWithMove k q) -> Event x (DMap k v)

1894−mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)

1613+mergeWithMove d = cacheEvent (mergeCheapWithMove d)

1895

1614

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

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

1897−mergeCheap

1898− :: forall k x q v. (HasSpiderTimeline x, GCompare k)

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

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

1617+mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy DMap.size

1903 where

1618 where

1904− updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)

1619+ updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)

1905 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do

1620 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do

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

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

1907 (mOldSubd, newPs) <- case me of

1622 (mOldSubd, newPs) <- case me of

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

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

1909 Just e -> do

1624 Just e -> do

1910 let s = subscriber $ return k

1625 let s = subscriber $ return k

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

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

1912 newParentHeight <- liftIO $ getEventSubscribedHeight subd

1627 newParentHeight <- liftIO $ getEventSubscribedHeight subd

1913 let newParent = MergeSubscribedParent subscription

1628 let newParent = MergeSubscribedParent subscription

1914 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight

1629 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight

1915 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps

1630 return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps

1916 forM_ mOldSubd $ \oldSubd -> do

1631 forM_ mOldSubd $ \oldSubd -> do

1917− oldHeight <- liftIO $ getEventSubscribedHeight $

1918− _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd

1632+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd

1919−

1920 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

1633 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

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

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

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

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

1923−

1924− getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParent x)

1636+ getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParent x)

1925 getInitialSubscribers initialParents subscriber = do

1637 getInitialSubscribers initialParents subscriber = do

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

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

1927 let s = subscriber $ return k

1639 let s = subscriber $ return k

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

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

1929 height <- liftIO $ getEventSubscribedHeight parentSubd

1641 height <- liftIO $ getEventSubscribedHeight parentSubd

1930− return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParent subscription)

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

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

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

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

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

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

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

1934 )

1646 )

1935−

1936 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)

1647 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)

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

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

1938

1649

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

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

1940−mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)

1651+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))

1942− -> DynamicS x (PatchDMapWithMove k q)

1943− -> Event x (DMap k v)

1944−mergeCheapWithMove nt = mergeGCheap' _mergeSubscribedParentWithMove_subscription getInitialSubscribers updateMe destroy

1652+mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy DMap.size

1945 where

1653 where

1946− updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)

1654+ updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)

1947 updateMe subscriber heightBagRef oldParents p = do

1655 updateMe subscriber heightBagRef oldParents p = do

1948 -- Prepare new parents for insertion

1656 -- Prepare new parents for insertion

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

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

1950 subscribeParent k e = do

1658 subscribeParent k e = do

1951 keyRef <- liftIO $ newIORef k

1659 keyRef <- liftIO $ newIORef k

1952 let s = subscriber $ liftIO $ readIORef keyRef

1660 let s = subscriber $ liftIO $ readIORef keyRef

@@ -1955,185 +1663,122 @@ mergeCheapWithMove nt = mergeGCheap' _mergeSubscribedParentWithMove_subscription

1955 newParentHeight <- getEventSubscribedHeight subd

1663 newParentHeight <- getEventSubscribedHeight subd

1956 modifyIORef' heightBagRef $ heightBagAdd newParentHeight

1664 modifyIORef' heightBagRef $ heightBagAdd newParentHeight

1957 return $ MergeSubscribedParentWithMove subscription keyRef

1665 return $ MergeSubscribedParentWithMove subscription keyRef

1958− p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey (\k q -> subscribeParent k (nt q)) p

1666+ p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey subscribeParent p

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

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

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

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

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

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

1962 Nothing -> do

1670 Nothing -> do

1963− oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $

1671+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent

1964− _mergeSubscribedParentWithMove_subscription parent

1965−

1966 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

1672 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight

1967 return $ Just $ _mergeSubscribedParentWithMove_subscription parent

1673 return $ Just $ _mergeSubscribedParentWithMove_subscription parent

1968 Just toKey -> do

1674 Just toKey -> do

1969 liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey

1675 liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey

1970 return Nothing

1676 return Nothing

1971− toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $

1972− DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents

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

1973−

1974 return (toDelete, applyAlways p' oldParents)

1678 return (toDelete, applyAlways p' oldParents)

1975− getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)

1679+ getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k)

1976 getInitialSubscribers initialParents subscriber = do

1680 getInitialSubscribers initialParents subscriber = do

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

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

1978 keyRef <- liftIO $ newIORef k

1682 keyRef <- liftIO $ newIORef k

1979 let s = subscriber $ liftIO $ readIORef keyRef

1683 let s = subscriber $ liftIO $ readIORef keyRef

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

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

1981 height <- liftIO $ getEventSubscribedHeight parentSubd

1685 height <- liftIO $ getEventSubscribedHeight parentSubd

1982− return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)

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

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

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

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

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

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

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

1986 )

1690 )

1987−

1988 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)

1691 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)

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

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

1990

1693

1991−type MergeUpdateFunc k v x p s

1694+type MergeUpdateFunc k x p s

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

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

1993 -> IORef HeightBag

1696 -> IORef HeightBag

1994 -> DMap k s

1697 -> DMap k s

1995 -> p

1698 -> p

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

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

1997

1700

1998−type MergeGetSubscription x s = forall a. s a -> EventSubscription x

1999−

2000−type MergeInitFunc k v q x s

1701+type MergeInitFunc k x s

2001− = DMap k q

1702+ = DMap k (Event x)

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

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

2003− -> EventM x (DMap k v, [Height], DMap k s)

1704+ -> EventM x (DMap k Identity, [Height], DMap k s)

2004

1705

2005type MergeDestroyFunc k s

1706type MergeDestroyFunc k s

2006 = DMap k s

1707 = DMap k s

2007 -> IO ()

1708 -> IO ()

2008

1709

2009−data Merge x k v s = Merge

1710+{-# INLINE mergeCheap' #-}

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

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

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)

1711+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)

2109−mergeGCheap' getParent getInitialSubscribers updateFunc destroy d = Event $ \sub -> do

1712+mergeCheap' getInitialSubscribers updateFunc destroy numParents d = Event $ \sub -> do

2110 initialParents <- readBehaviorUntracked $ dynamicCurrent d

1713 initialParents <- readBehaviorUntracked $ dynamicCurrent d

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

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

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

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

2113 heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"

1716 heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"

2114 parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"

1717 parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"

2115− changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"

1718+ let scheduleSelf height = scheduleMerge' height heightRef $ do

2116−

1719+ m <- liftIO $ readIORef accumRef

2117− let subscribed = EventSubscribed

1720+ liftIO $ writeIORef accumRef $! DMap.empty

2118− { eventSubscribedHeightRef = heightRef

1721+ --TODO: Assert that m is not empty

2119− , eventSubscribedRetained = toAny (parentsRef, changeSubdRef)

1722+ subscriberPropagate sub m

1723+ invalidateMyHeight = do

1724+ oldHeight <- readIORef heightRef

1725+ 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

1726+ writeIORef heightRef $! invalidHeight

1727+ subscriberInvalidateHeight sub oldHeight

1728+ revalidateMyHeight = do

1729+ currentHeight <- readIORef heightRef

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

1731+ heights <- readIORef heightBagRef

1732+ parents <- readIORef parentsRef

1733+ -- When the number of heights in the bag reaches the number of parents, we should have a valid height

1734+ case heightBagSize heights `compare` numParents parents of

1735+ LT -> return ()

1736+ EQ -> do

1737+ let height = succHeight $ heightBagMax heights

1738+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height

1739+ writeIORef heightRef $! height

1740+ subscriberRecalculateHeight sub height

1741+ GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (numParents parents) <> ") for Merge"

1742+ subscriber :: forall a. EventM x (k a) -> Subscriber x a

1743+ subscriber getKey = Subscriber

1744+ { subscriberPropagate = \a -> do

1745+ oldM <- liftIO $ readIORef accumRef

1746+ k <- getKey

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

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

1749+ liftIO $ writeIORef accumRef $! newM

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

1751+ height <- liftIO $ readIORef heightRef

1752+ --TODO: assertions about height

1753+ currentHeight <- getCurrentHeight

1754+ when (height <= currentHeight) $ do

1755+ if height /= invalidHeight

1756+ then do

1757+ myStack <- liftIO $ whoCreatedIORef undefined --TODO

1758+ error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)

1759+ else liftIO $ do

2120#ifdef DEBUG_CYCLES

1760#ifdef DEBUG_CYCLES

2121− , eventSubscribedGetParents = do

1761+ nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed

2122− let getParent' (_ :=> v) = _eventSubscription_subscribed (getParent v)

1762+ stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es

2123− fmap getParent' . DMap.toList <$> readIORef parentsRef

1763+ let cycleInfo = ":\n" <> drawForest (listsToForest stacks)

2124− , eventSubscribedHasOwnHeightRef = False

1764+#else

2125− , eventSubscribedWhoCreated = whoCreatedIORef heightRef

1765+ let cycleInfo = ""

2126#endif

1766#endif

2127− }

1767+ error $ "Causality loop found" <> cycleInfo

2128−

1768+ scheduleSelf height

2129− m = Merge

1769+ , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating

2130− { _merge_parentsRef = parentsRef

1770+ modifyIORef' heightBagRef $ heightBagRemove old

2131− , _merge_heightBagRef = heightBagRef

1771+ invalidateMyHeight

2132− , _merge_heightRef = heightRef

1772+ , subscriberRecalculateHeight = \new -> do

2133− , _merge_sub = sub

1773+ modifyIORef' heightBagRef $ heightBagAdd new

2134− , _merge_accumRef = accumRef

1774+ revalidateMyHeight

2135 }

1775 }

1776+ let updateMe x = do

1777+ oldParents <- liftIO $ readIORef parentsRef

1778+ (subscriptionsToKill, newParents) <- updateFunc subscriber heightBagRef oldParents x

1779+ liftIO $ writeIORef parentsRef $! newParents

1780+ return subscriptionsToKill

2136− (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber subscribed m

1781+ (dm, heights, initialParentState) <- getInitialSubscribers initialParents subscriber

2137 let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights

1782 let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights

2138 myHeight = if invalidHeight `elem` heights

1783 myHeight = if invalidHeight `elem` heights

2139 then invalidHeight

1784 then invalidHeight

@@ -2142,153 +1787,43 @@ mergeGCheap' getParent getInitialSubscribers updateFunc destroy d = Event $ \sub

2142 let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now

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

1788 then (if DMap.null dm then Nothing else Just dm, DMap.empty)

2144 else (Nothing, dm)

1789 else (Nothing, dm)

2145− unless (DMap.null accum) $ scheduleMergeSelf m myHeight

1790+ unless (DMap.null accum) $ do

1791+ scheduleSelf myHeight

1792+ occRef <- liftIO $ newIORef occ

1793+ when (isJust occ) $ scheduleClear occRef

2146 liftIO $ writeIORef accumRef $! accum

1794 liftIO $ writeIORef accumRef $! accum

2147 liftIO $ writeIORef heightRef $! myHeight

1795 liftIO $ writeIORef heightRef $! myHeight

2148 liftIO $ writeIORef heightBagRef $! myHeightBag

1796 liftIO $ writeIORef heightBagRef $! myHeightBag

1797+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"

2149 liftIO $ writeIORef parentsRef $! initialParentState

1798 liftIO $ writeIORef parentsRef $! initialParentState

2150 defer $ SomeMergeInit $ do

1799 defer $ SomeMergeInit $ do

2151− let changeSubscriber = Subscriber

1800+ let s = Subscriber

2152 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

1801 { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do

2153− tracePropagate (Proxy :: Proxy x) "SubscriberMerge/Change"

1802+ tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change"

2154− defer $ updateMerge subscribed m updateFunc a

1803+ defer $ SomeMergeUpdate (updateMe a) invalidateMyHeight revalidateMyHeight

2155 , subscriberInvalidateHeight = \_ -> return ()

1804 , subscriberInvalidateHeight = \_ -> return ()

2156 , subscriberRecalculateHeight = \_ -> return ()

1805 , subscriberRecalculateHeight = \_ -> return ()

2157 }

1806 }

2158− (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) changeSubscriber

1807+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s

2159− forM_ change $ \c -> defer $ updateMerge subscribed m updateFunc c

1808+ forM_ change $ \c -> defer $ SomeMergeUpdate (updateMe c) invalidateMyHeight revalidateMyHeight

2160 -- We explicitly hold on to the unsubscribe function from subscribing to the update event.

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

1810 -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain

2162 -- its subscription.

1811 -- its subscription.

2163− liftIO $ writeIORef changeSubdRef (changeSubscriber, changeSubscription)

1812+ liftIO $ writeIORef changeSubdRef (s, changeSubscription)

2164 let unsubscribeAll = destroy =<< readIORef parentsRef

1813 let unsubscribeAll = destroy =<< readIORef parentsRef

2165−

2166− return (EventSubscription unsubscribeAll subscribed, occ)

1814+ return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parentsRef, changeSubdRef)

2167−

1815+ , occ

2168−

1816+ )

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

1817

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

1818newtype 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

1819

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

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

2285−fanG e = unsafePerformIO $ do

1821+fan e =

2286− ref <- newIORef Nothing

2287 let f = Fan

1822 let f = Fan

2288 { fanParent = e

1823 { fanParent = e

2289− , fanSubscribed = ref

1824+ , fanSubscribed = unsafeNewIORef e Nothing

2290 }

1825 }

2291− pure $ EventSelectorG $ \k -> eventFan k f

1826+ in EventSelector $ \k -> eventFan k f

2292

1827

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

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

2294runHoldInits holdInitRef dynInitRef mergeInitRef = do

1829runHoldInits holdInitRef dynInitRef mergeInitRef = do

@@ -2319,14 +1854,13 @@ newEventEnv = do

2319 mergeInitRef <- newIORef []

1854 mergeInitRef <- newIORef []

2320 heightRef <- newIORef zeroHeight

1855 heightRef <- newIORef zeroHeight

2321 toClearRef <- newIORef []

1856 toClearRef <- newIORef []

2322− toClearIntRef <- newIORef []

2323 toClearRootRef <- newIORef []

1857 toClearRootRef <- newIORef []

2324 coincidenceInfosRef <- newIORef []

1858 coincidenceInfosRef <- newIORef []

2325 delayedRef <- newIORef IntMap.empty

1859 delayedRef <- newIORef IntMap.empty

2326− return $ EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef

1860+ return $ EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef

2327

1861

2328clearEventEnv :: EventEnv x -> IO ()

1862clearEventEnv :: EventEnv x -> IO ()

2329−clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef) = do

1863+clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef) = do

2330 writeIORef toAssignRef []

1864 writeIORef toAssignRef []

2331 writeIORef holdInitRef []

1865 writeIORef holdInitRef []

2332 writeIORef dynInitRef []

1866 writeIORef dynInitRef []

@@ -2334,44 +1868,41 @@ clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeI

2334 writeIORef mergeInitRef []

1868 writeIORef mergeInitRef []

2335 writeIORef heightRef zeroHeight

1869 writeIORef heightRef zeroHeight

2336 writeIORef toClearRef []

1870 writeIORef toClearRef []

2337− writeIORef toClearIntRef []

2338 writeIORef toClearRootRef []

1871 writeIORef toClearRootRef []

2339 writeIORef coincidenceInfosRef []

1872 writeIORef coincidenceInfosRef []

2340 writeIORef delayedRef IntMap.empty

1873 writeIORef delayedRef IntMap.empty

2341

1874

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

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

1876runFrame :: 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

1877+runFrame a = SpiderHost $ ask >>= \_ -> lift $ do

2345− let env = _spiderTimeline_eventEnv $ unSTE (spiderTimeline :: SpiderTimelineEnv x)

1878+ let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)

2346 let go = do

1879 let go = do

2347 result <- a

1880 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

1881 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

2349 return result

1882 return result

2350 result <- runEventM go

1883 result <- runEventM go

2351 toClear <- readIORef $ eventEnvClears env

1884 toClear <- readIORef $ eventEnvClears env

2352− forM_ toClear $ \(Some (Clear ref)) -> {-# SCC "clear" #-} writeIORef ref Nothing

1885+ 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

1886 toClearRoot <- readIORef $ eventEnvRootClears env

2356− forM_ toClearRoot $ \(Some (RootClear ref)) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty

1887+ forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty

2357 toAssign <- readIORef $ eventEnvAssignments env

1888 toAssign <- readIORef $ eventEnvAssignments env

2358 toReconnectRef <- newIORef []

1889 toReconnectRef <- newIORef []

2359 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env

1890 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env

2360 forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do

1891 forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do

2361 writeIORef vRef v

1892 writeIORef vRef v

2362− traceInvalidate $ "Invalidating Hold"

1893+ when debugInvalidate $ putStrLn $ "Invalidating Hold"

2363 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef

1894 writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef

2364 mergeUpdates <- readIORef $ eventEnvMergeUpdates env

1895 mergeUpdates <- readIORef $ eventEnvMergeUpdates env

2365 writeIORef (eventEnvMergeUpdates env) []

1896 writeIORef (eventEnvMergeUpdates env) []

2366− tracePropagate (Proxy::Proxy x) $ "Updating merges"

1897+ when debugPropagate $ putStrLn "Updating merges"

2367 mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates

1898 mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates

2368− tracePropagate (Proxy::Proxy x) $ "Updating merges done"

1899+ when debugPropagate $ putStrLn "Updating merges done"

2369 toReconnect <- readIORef toReconnectRef

1900 toReconnect <- readIORef toReconnectRef

2370 clearEventEnv env

1901 clearEventEnv env

2371 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do

1902 switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do

2372 oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed

1903 oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed

2373 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed

1904 wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed

2374− traceInvalidate $ "Finalizing invalidator for Switch" <> showNodeId subscribed

1905+ when debugInvalidate $ putStrLn $ "Finalizing invalidator for Switch" <> showNodeId subscribed

2375 finalize wi

1906 finalize wi

2376 i <- evaluate $ switchSubscribedOwnInvalidator subscribed

1907 i <- evaluate $ switchSubscribedOwnInvalidator subscribed

2377 wi' <- mkWeakPtrWithDebug i "wi'"

1908 wi' <- mkWeakPtrWithDebug i "wi'"

@@ -2382,10 +1913,10 @@ runFrame a = SpiderHost $ do

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

1913 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

2383 --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times

1914 --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times

2384 sub <- newSubscriberSwitch subscribed

1915 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

1916+ 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 {-

1917 {-

2387 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)

1918 stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)

2388− liftIO $ debugStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of

1919+ liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of

2389 EventRoot _ -> "EventRoot"

1920 EventRoot _ -> "EventRoot"

2390 EventNever -> "EventNever"

1921 EventNever -> "EventNever"

2391 _ -> "something else"

1922 _ -> "something else"

@@ -2400,7 +1931,7 @@ runFrame a = SpiderHost $ do

2400 myHeight <- readIORef $ switchSubscribedHeight subscribed

1931 myHeight <- readIORef $ switchSubscribedHeight subscribed

2401 when (parentHeight /= myHeight) $ do

1932 when (parentHeight /= myHeight) $ do

2402 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight

1933 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight

2403− WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight

1934+ 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

1935 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

1936 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do

2406 unsubscribe subscription

1937 unsubscribe subscription

@@ -2441,7 +1972,7 @@ invalidateCoincidenceHeight subscribed = do

2441 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed

1972 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed

2442 when (oldHeight /= invalidHeight) $ do

1973 when (oldHeight /= invalidHeight) $ do

2443 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight

1974 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight

2444− WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

1975+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight

2445

1976

2446updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()

1977updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()

2447updateSwitchHeight new subscribed = do

1978updateSwitchHeight new subscribed = do

@@ -2449,7 +1980,7 @@ updateSwitchHeight new subscribed = do

2449 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion

1980 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

1981 when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion

2451 writeIORef (switchSubscribedHeight subscribed) $! new

1982 writeIORef (switchSubscribedHeight subscribed) $! new

2452− WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new

1983+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new

2453

1984

2454recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()

1985recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()

2455recalculateCoincidenceHeight subscribed = do

1986recalculateCoincidenceHeight subscribed = do

@@ -2458,7 +1989,7 @@ recalculateCoincidenceHeight subscribed = do

2458 height <- calculateCoincidenceHeight subscribed

1989 height <- calculateCoincidenceHeight subscribed

2459 when (height /= invalidHeight) $ do

1990 when (height /= invalidHeight) $ do

2460 writeIORef (coincidenceSubscribedHeight subscribed) $! height

1991 writeIORef (coincidenceSubscribedHeight subscribed) $! height

2461− WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height

1992+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height

2462

1993

2463calculateSwitchHeight :: SwitchSubscribed x a -> IO Height

1994calculateSwitchHeight :: SwitchSubscribed x a -> IO Height

2464calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)

1995calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)

@@ -2497,218 +2028,13 @@ invalidate toReconnectRef wis = do

2497-- Reflex integration

2028-- Reflex integration

2498--------------------------------------------------------------------------------

2029--------------------------------------------------------------------------------

2499

2030

2500−-- | Designates the default, global Spider timeline

2031+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

2501−data SpiderTimeline x

2032+-- When we're specializing, we include this from Reflex.Class instead, because

2502−type role SpiderTimeline nominal

2033+-- it needs access to these types; when we're not, we want them here, so our

2503−

2034+-- instance isn't an orphan instance.

2504−-- | The default, global Spider environment

2035+#include "SpiderTimeline.include.hs"

2505−type Spider = SpiderTimeline Global

2036+#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

2037#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

2038

2713unsafeNewSpiderTimelineEnv :: forall x. IO (SpiderTimelineEnv x)

2039unsafeNewSpiderTimelineEnv :: forall x. IO (SpiderTimelineEnv x)

2714unsafeNewSpiderTimelineEnv = do

2040unsafeNewSpiderTimelineEnv = do

@@ -2717,7 +2043,7 @@ unsafeNewSpiderTimelineEnv = do

2717#ifdef DEBUG

2043#ifdef DEBUG

2718 depthRef <- newIORef 0

2044 depthRef <- newIORef 0

2719#endif

2045#endif

2720− return $ STE $ SpiderTimelineEnv

2046+ return $ SpiderTimelineEnv

2721 { _spiderTimeline_lock = lock

2047 { _spiderTimeline_lock = lock

2722 , _spiderTimeline_eventEnv = env

2048 , _spiderTimeline_eventEnv = env

2723#ifdef DEBUG

2049#ifdef DEBUG

@@ -2725,40 +2051,41 @@ unsafeNewSpiderTimelineEnv = do

2725#endif

2051#endif

2726 }

2052 }

2727

2053

2054+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

2728-- | Create a new SpiderTimelineEnv

2055-- | Create a new SpiderTimelineEnv

2729newSpiderTimeline :: IO (Some SpiderTimelineEnv)

2056newSpiderTimeline :: IO (Some SpiderTimelineEnv)

2730−newSpiderTimeline = withSpiderTimeline (pure . Some)

2057+newSpiderTimeline = withSpiderTimeline (pure . Some.This)

2731

2058

2732−data LocalSpiderTimeline (x :: Type) s

2059+data LocalSpiderTimeline x s

2733

2060

2734instance Reifies s (SpiderTimelineEnv x) =>

2061instance Reifies s (SpiderTimelineEnv x) =>

2735 HasSpiderTimeline (LocalSpiderTimeline x s) where

2062 HasSpiderTimeline (LocalSpiderTimeline x s) where

2736− spiderTimeline = localSpiderTimeline Proxy $ reflect (Proxy :: Proxy s)

2063+ spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s)

2737

2064

2738localSpiderTimeline

2065localSpiderTimeline

2739− :: proxy s

2066+ :: Proxy s

2740 -> SpiderTimelineEnv x

2067 -> SpiderTimelineEnv x

2741 -> SpiderTimelineEnv (LocalSpiderTimeline x s)

2068 -> SpiderTimelineEnv (LocalSpiderTimeline x s)

2742−localSpiderTimeline _ = coerce

2069+localSpiderTimeline _ = unsafeCoerce

2743

2070

2744-- | Pass a new timeline to the given function.

2071-- | Pass a new timeline to the given function.

2745withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r

2072withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r

2746withSpiderTimeline k = do

2073withSpiderTimeline k = do

2747 env <- unsafeNewSpiderTimelineEnv

2074 env <- unsafeNewSpiderTimelineEnv

2748 reify env $ \s -> k $ localSpiderTimeline s env

2075 reify env $ \s -> k $ localSpiderTimeline s env

2076+#endif

2749

2077

2750−newtype SpiderPullM (x :: Type) a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2078+newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2751−

2752−type ComputeM = EventM

2753

2079

2754−newtype SpiderPushM (x :: Type) a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2080+newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

2755

2081

2082+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

2756instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2083instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2757 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}

2084 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}

2758 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }

2085 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }

2759 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }

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

2087+ 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 }

2088+ newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }

2762 type PullM (SpiderTimeline x) = SpiderPullM x

2089 type PullM (SpiderTimeline x) = SpiderPullM x

2763 type PushM (SpiderTimeline x) = SpiderPushM x

2090 type PushM (SpiderTimeline x) = SpiderPushM x

2764 {-# INLINABLE never #-}

2091 {-# INLINABLE never #-}

@@ -2771,15 +2098,10 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2771 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent

2098 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent

2772 {-# INLINABLE pull #-}

2099 {-# INLINABLE pull #-}

2773 pull = SpiderBehavior . pull . coerce

2100 pull = SpiderBehavior . pull . coerce

2774− {-# INLINABLE fanG #-}

2101+ {-# INLINABLE merge #-}

2775− fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))

2102+ merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x))

2776− {-# INLINABLE mergeG #-}

2103+ {-# INLINABLE fan #-}

2777− mergeG

2104+ 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 #-}

2105 {-# INLINABLE switch #-}

2784 switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior

2106 switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior

2785 {-# INLINABLE coincidence #-}

2107 {-# INLINABLE coincidence #-}

@@ -2787,15 +2109,15 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2787 {-# INLINABLE current #-}

2109 {-# INLINABLE current #-}

2788 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic

2110 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic

2789 {-# INLINABLE updated #-}

2111 {-# INLINABLE updated #-}

2790− updated = SpiderEvent #. dynamicUpdated .# fmap coerce . unSpiderDynamic

2112+ updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic

2791 {-# INLINABLE unsafeBuildDynamic #-}

2113 {-# INLINABLE unsafeBuildDynamic #-}

2792 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'

2114 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'

2793 {-# INLINABLE unsafeBuildIncremental #-}

2115 {-# INLINABLE unsafeBuildIncremental #-}

2794 unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv

2116 unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv

2795− {-# INLINABLE mergeIncrementalG #-}

2117+ {-# INLINABLE mergeIncremental #-}

2796− mergeIncrementalG nt = SpiderEvent #. mergeG (coerce #. nt) .# unSpiderIncremental

2118+ mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental

2797− {-# INLINABLE mergeIncrementalWithMoveG #-}

2119+ {-# INLINABLE mergeIncrementalWithMove #-}

2798− mergeIncrementalWithMoveG nt = SpiderEvent #. mergeWithMove (coerce #. nt) .# unSpiderIncremental

2120+ mergeIncrementalWithMove = SpiderEvent . mergeWithMove . (unsafeCoerce :: Dynamic x (PatchDMapWithMove k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMapWithMove k (Event x))) . unSpiderIncremental

2799 {-# INLINABLE currentIncremental #-}

2121 {-# INLINABLE currentIncremental #-}

2800 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental

2122 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental

2801 {-# INLINABLE updatedIncremental #-}

2123 {-# INLINABLE updatedIncremental #-}

@@ -2806,12 +2128,8 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2806 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'

2128 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'

2807 eventCoercion Coercion = Coercion

2129 eventCoercion Coercion = Coercion

2808 behaviorCoercion Coercion = Coercion

2130 behaviorCoercion Coercion = Coercion

2809− dynamicCoercion Coercion = Coercion

2131+ 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

2132+#endif

2811− {-# INLINABLE mergeIntIncremental #-}

2812− mergeIntIncremental = SpiderEvent . mergeInt . coerce

2813− {-# INLINABLE fanInt #-}

2814− fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))

2815

2133

2816data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)

2134data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)

2817

2135

@@ -2834,7 +2152,7 @@ instance MonadAtomicRef (EventM x) where

2834 atomicModifyRef r f = liftIO $ atomicModifyRef r f

2152 atomicModifyRef r f = liftIO $ atomicModifyRef r f

2835

2153

2836-- | The monad for actions that manipulate a Spider timeline identified by @x@

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

2155+newtype SpiderHost x a = SpiderHost { unSpiderHost :: ReaderT (SpiderTimelineEnv x) IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

2838

2156

2839instance Monad (SpiderHost x) where

2157instance Monad (SpiderHost x) where

2840 {-# INLINABLE (>>=) #-}

2158 {-# INLINABLE (>>=) #-}

@@ -2843,27 +2161,22 @@ instance Monad (SpiderHost x) where

2843 SpiderHost x >> SpiderHost y = SpiderHost $ x >> y

2161 SpiderHost x >> SpiderHost y = SpiderHost $ x >> y

2844 {-# INLINABLE return #-}

2162 {-# INLINABLE return #-}

2845 return x = SpiderHost $ return x

2163 return x = SpiderHost $ return x

2846−#if !MIN_VERSION_base(4,13,0)

2847 {-# INLINABLE fail #-}

2164 {-# INLINABLE fail #-}

2848− fail = MonadFail.fail

2849−#endif

2850−

2851−instance MonadFail (SpiderHost x) where

2852− {-# INLINABLE fail #-}

2853− fail s = SpiderHost $ MonadFail.fail s

2165+ fail s = SpiderHost $ fail s

2854

2166

2855-- | Run an action affecting the global Spider timeline; this will be guarded by

2167-- | Run an action affecting the global Spider timeline; this will be guarded by

2856-- a mutex for that timeline

2168-- a mutex for that timeline

2857runSpiderHost :: SpiderHost Global a -> IO a

2169runSpiderHost :: SpiderHost Global a -> IO a

2858−runSpiderHost (SpiderHost a) = a

2170+runSpiderHost (SpiderHost a) = runReaderT a globalSpiderTimelineEnv

2859

2171

2172+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

2860-- | Run an action affecting a given Spider timeline; this will be guarded by a

2173-- | Run an action affecting a given Spider timeline; this will be guarded by a

2861-- mutex for that timeline

2174-- mutex for that timeline

2862runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a

2175runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a

2863−runSpiderHostForTimeline (SpiderHost a) _ = a

2176+runSpiderHostForTimeline (SpiderHost a) = runReaderT a

2177+#endif

2864

2178

2865−newtype SpiderHostFrame (x :: Type) a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }

2866− deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

2179+newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

2867

2180

2868instance Monad (SpiderHostFrame x) where

2181instance Monad (SpiderHostFrame x) where

2869 {-# INLINABLE (>>=) #-}

2182 {-# INLINABLE (>>=) #-}

@@ -2872,21 +2185,15 @@ instance Monad (SpiderHostFrame x) where

2872 SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y

2185 SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y

2873 {-# INLINABLE return #-}

2186 {-# INLINABLE return #-}

2874 return x = SpiderHostFrame $ return x

2187 return x = SpiderHostFrame $ return x

2875−#if !MIN_VERSION_base(4,13,0)

2876 {-# INLINABLE fail #-}

2188 {-# INLINABLE fail #-}

2877 fail s = SpiderHostFrame $ fail s

2189 fail s = SpiderHostFrame $ fail s

2878−#endif

2879−

2880−instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where

2881− notReadyUntil _ = pure ()

2882− notReady = pure ()

2883

2190

2884−newEventWithTriggerIO :: forall x a. HasSpiderTimeline x => (RootTrigger x a -> IO (IO ())) -> IO (Event x a)

2191+newEventWithTriggerIO :: (RootTrigger x a -> IO (IO ())) -> IO (Event x a)

2885newEventWithTriggerIO f = do

2192newEventWithTriggerIO f = do

2886 es <- newFanEventWithTriggerIO $ \Refl -> f

2193 es <- newFanEventWithTriggerIO $ \Refl -> f

2887 return $ select es Refl

2194 return $ select es Refl

2888

2195

2889−newFanEventWithTriggerIO :: (HasSpiderTimeline x, GCompare k) => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)

2196+newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)

2890newFanEventWithTriggerIO f = do

2197newFanEventWithTriggerIO f = do

2891 occRef <- newIORef DMap.empty

2198 occRef <- newIORef DMap.empty

2892 subscribedRef <- newIORef DMap.empty

2199 subscribedRef <- newIORef DMap.empty

@@ -2920,11 +2227,3 @@ instance MonadAtomicRef (SpiderHostFrame x) where

2920instance PrimMonad (SpiderHostFrame x) where

2227instance PrimMonad (SpiderHostFrame x) where

2921 type PrimState (SpiderHostFrame x) = PrimState IO

2228 type PrimState (SpiderHostFrame x) = PrimState IO

2922 primitive = SpiderHostFrame . EventM . primitive

2229 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+135

@@ -0,0 +1,135 @@

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+ {-# INLINABLE buildDynamic #-}

20+ buildDynamic = buildDynamicSpiderEventM

21+

22+instance (

23+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

24+ x ~ Global

25+#endif

26+ ) => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where

27+ {-# INLINABLE sample #-}

28+ sample = coerce . readBehaviorTracked . unSpiderBehavior

29+

30+instance (

31+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

32+ x ~ Global

33+#endif

34+ ) => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPushM x) where

35+ {-# INLINABLE sample #-}

36+ sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b

37+

38+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderPushM x) where

39+ {-# INLINABLE hold #-}

40+ hold v0 e = Reflex.Class.current <$> Reflex.Class.holdDyn v0 e

41+ {-# INLINABLE holdDyn #-}

42+ holdDyn v0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce e

43+ {-# INLINABLE holdIncremental #-}

44+ holdIncremental v0 (SpiderEvent e) = SpiderPushM $ SpiderIncremental . dynamicHold <$> Reflex.Spider.Internal.hold v0 e

45+ {-# INLINABLE buildDynamic #-}

46+ buildDynamic getV0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce e

47+

48+instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where

49+ {-# INLINE return #-}

50+ return = pure

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

52+ x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x

53+ {-# INLINE (>>) #-}

54+ _ >> y = y

55+ {-# INLINE fail #-}

56+ fail _ = error "Dynamic does not support 'fail'"

57+

58+newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)

59+newJoinDyn d =

60+ let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)

61+ eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d

62+ eInner = Reflex.Spider.Internal.switch $ dynamicUpdated <$> dynamicCurrent d

63+ eBoth = Reflex.Spider.Internal.coincidence $ dynamicUpdated . runIdentity <$> dynamicUpdated d

64+ v' = unSpiderEvent $ Reflex.Class.leftmost $ map SpiderEvent [eBoth, eOuter, eInner]

65+ in Reflex.Spider.Internal.unsafeBuildDynamic readV0 v'

66+

67+instance HasSpiderTimeline x => Functor (Reflex.Class.Dynamic (SpiderTimeline x)) where

68+ fmap f = SpiderDynamic . newMapDyn f . unSpiderDynamic

69+

70+instance HasSpiderTimeline x => Applicative (Reflex.Class.Dynamic (SpiderTimeline x)) where

71+ pure = SpiderDynamic . dynamicConst

72+ SpiderDynamic a <*> SpiderDynamic b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith ($) a b

73+ _ *> b = b

74+ a <* _ = a

75+

76+holdSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Behavior (SpiderTimeline x) a)

77+holdSpiderEventM v0 e = fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e

78+

79+holdDynSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)

80+holdDynSpiderEventM v0 e = fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e

81+

82+holdIncrementalSpiderEventM :: (HasSpiderTimeline x, Patch p) => PatchTarget p -> Reflex.Class.Event (SpiderTimeline x) p -> EventM x (Reflex.Class.Incremental (SpiderTimeline x) p)

83+holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e

84+

85+buildDynamicSpiderEventM :: HasSpiderTimeline x => SpiderPullM x a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)

86+buildDynamicSpiderEventM getV0 e = fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e

87+

88+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHost x) where

89+ {-# INLINABLE hold #-}

90+ hold v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.hold v0 e

91+ {-# INLINABLE holdDyn #-}

92+ holdDyn v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdDyn v0 e

93+ {-# INLINABLE holdIncremental #-}

94+ holdIncremental v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdIncremental v0 e

95+ {-# INLINABLE buildDynamic #-}

96+ buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e

97+

98+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where

99+ sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can

100+

101+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHostFrame x) where

102+ {-# INLINABLE hold #-}

103+ hold v0 e = SpiderHostFrame $ fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e

104+ {-# INLINABLE holdDyn #-}

105+ holdDyn v0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e

106+ {-# INLINABLE holdIncremental #-}

107+ holdIncremental v0 e = SpiderHostFrame $ fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e

108+ {-# INLINABLE buildDynamic #-}

109+ buildDynamic getV0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e

110+

111+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where

112+ {-# INLINABLE sample #-}

113+ sample = runFrame . readBehaviorUntracked . unSpiderBehavior

114+

115+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where

116+ {-# INLINABLE sample #-}

117+ sample = Reflex.Spider.Internal.ReadPhase . Reflex.Class.sample

118+

119+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where

120+ {-# INLINABLE hold #-}

121+ hold v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.hold v0 e

122+ {-# INLINABLE holdDyn #-}

123+ holdDyn v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdDyn v0 e

124+ {-# INLINABLE holdIncremental #-}

125+ holdIncremental v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdIncremental v0 e

126+ {-# INLINABLE buildDynamic #-}

127+ buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e

128+

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

130+-- Deprecated items

131+--------------------------------------------------------------------------------

132+

133+-- | 'SpiderEnv' is the old name for 'SpiderTimeline'

134+{-# DEPRECATED SpiderEnv "Use 'SpiderTimelineEnv' instead" #-}

135+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+2−23

@@ -13,7 +13,6 @@ 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

19import Control.Monad.Primitive

18import Control.Monad.Primitive

@@ -22,10 +21,7 @@ import Control.Monad.Ref

22import Data.Coerce

21import Data.Coerce

23import Data.Dependent.Sum

22import Data.Dependent.Sum

24import Data.IORef

23import Data.IORef

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

26−import qualified Data.Semigroup as S

27import Reflex.Class

24import Reflex.Class

28−import Reflex.Adjustable.Class

29import Reflex.Host.Class

25import Reflex.Host.Class

30import Reflex.PerformEvent.Class

26import Reflex.PerformEvent.Class

31import Reflex.PostBuild.Class

27import Reflex.PostBuild.Class

@@ -118,32 +114,15 @@ instance MonadHold t m => MonadHold t (TriggerEventT t m) where

118 holdDyn v0 v' = lift $ holdDyn v0 v'

114 holdDyn v0 v' = lift $ holdDyn v0 v'

119 {-# INLINABLE holdIncremental #-}

115 {-# INLINABLE holdIncremental #-}

120 holdIncremental v0 v' = lift $ holdIncremental v0 v'

116 holdIncremental v0 v' = lift $ holdIncremental v0 v'

121− {-# INLINABLE buildDynamic #-}

117+

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

118+instance MonadAdjust t m => MonadAdjust t (TriggerEventT t m) where

129 {-# INLINABLE runWithReplace #-}

119 {-# INLINABLE runWithReplace #-}

130 runWithReplace (TriggerEventT a0) a' = TriggerEventT $ runWithReplace a0 (coerceEvent a')

120 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 #-}

121 {-# INLINABLE traverseDMapWithKeyWithAdjust #-}

134 traverseDMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjust (coerce . f) dm0 dm'

122 traverseDMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjust (coerce . f) dm0 dm'

135 {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}

123 {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}

136 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjustWithMove (coerce . f) dm0 dm'

124 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjustWithMove (coerce . f) dm0 dm'

137

125

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−

147-- | Retrieve the current 'Chan'; event trigger invocations pushed into it will

126-- | Retrieve the current 'Chan'; event trigger invocations pushed into it will

148-- be fired.

127-- be fired.

149askEvents :: Monad m => TriggerEventT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])

128askEvents :: Monad m => TriggerEventT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])

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 #-}

2−{-# LANGUAGE BangPatterns #-}

3−{-# LANGUAGE FlexibleContexts #-}

1+{-# LANGUAGE FlexibleContexts, GADTs #-}

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

6+import Control.Monad.Ref

12−import qualified Data.Dependent.Map as DMap

7+import Data.Dependent.Sum

8+import Data.IORef

9+import Data.List

13−import Data.Functor.Misc

10+import Data.Functor.Identity

14−import qualified Data.Map as M

15−import Data.These

16−

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

29− ]

30− print os1

22+ print out1

31− os2@[[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]]

23+ (Just out2, Just (out3, out4)) <- runApp app2

32− <- runApp' (unwrapApp testSimultaneous) $ map Just $

24+ print out2

33− [ This ()

34− , That ()

35− , This ()

36− , These () ()

37− ]

38− print os2

25+ print out3

39− os3@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEvent) [Just ()]

26+ print out4

40− print os3

27+ when (sort out1 /= out1 || map (+1) out2 /= out3 || out3 /= out4) exitFailure

41− os4@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEventDMap) [Just ()]

28+

42− print os4

29+runApp :: (Show a, t ~ SpiderTimeline Global, m ~ SpiderHost Global)

43− os5@[[Nothing, Just [1, 2]]] <- runApp' (unwrapApp testLiveTellEventDMap) [Just ()]

30+ => (Event t () -> EventWriterT t [a] (PerformEventT t m) (Maybe (Ref m (Maybe (EventTrigger t ())))))

44− print os5

31+ -> IO (Maybe [a], Maybe ([a], [a]))

45− os6 <- runApp' (unwrapApp delayedPulse) [Just ()]

32+runApp x = runSpiderHost $ do

46− print os6

33+ (pulseE, pulseTriggerRef) <- newEventWithTriggerRef

47− let ![[Nothing, Nothing]] = os6

34+ ((mactuateRef, e), FireCommand fire) <- hostPerformEventT $ runEventWriterT (x pulseE)

48− return ()

35+ hnd <- subscribeEvent e

49−

36+ out1 <- fireEventRefAndRead pulseTriggerRef () hnd

50−unwrapApp :: (Reflex t, Monad m) => (a -> EventWriterT t [Int] m ()) -> a -> m (Event t [Int])

37+ out2 <- fmap join $ forM mactuateRef $ \actuateRef -> do

51−unwrapApp x appIn = do

38+ let readPhase = do

52− ((), e) <- runEventWriterT $ x appIn

39+ mGetValue <- readEvent hnd

40+ case mGetValue of

41+ Nothing -> return Nothing

42+ Just getValue -> fmap Just getValue

43+ mactuate <- readRef actuateRef

44+ mpulse <- readRef pulseTriggerRef

45+ forM ((,) <$> mactuate <*> mpulse) $ \(actuate, pulse) -> do

46+ _ <- fire [actuate :=> Identity ()] $ return ()

47+ [Just a] <- fire [pulse :=> Identity ()] $ readPhase

48+ [Just b, Nothing] <- fire [actuate :=> Identity (), pulse :=> Identity ()] $ readPhase

49+ return (a,b)

53− return e

50+ return (out1, out2)

54−

51+

55−testOrdering :: (Reflex t, Monad m) => Event t () -> EventWriterT t [Int] m ()

52+app1 :: (Reflex t, Ref m ~ IORef, EventWriter t [Int] m) => Event t () -> m (Maybe (Ref m (Maybe (EventTrigger t ()))))

53+app1 e = do

56−testOrdering pulse = forM_ [10,9..1] $ \i -> tellEvent ([i] <$ pulse)

54+ forM_ [1..10] $ \i -> tellEvent ([i] <$ e)

57−

55+ return Nothing

58−testSimultaneous :: (Reflex t, Adjustable t m, MonadHold t m) => Event t (These () ()) -> EventWriterT t [Int] m ()

56+

59−testSimultaneous pulse = do

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

60− let e0 = fmapMaybe (^? here) pulse

58+app2 e = do

61− e1 = fmapMaybe (^? there) pulse

59+ (pulse, pulseTriggerRef) <- newEventWithTriggerRef

62− forM_ [1,3..9] $ \i -> runWithReplace (tellEvent ([i] <$ e0)) $ ffor e1 $ \_ -> tellEvent ([i+1] <$ e0)

60+ forM_ [1,3..9] $ \i -> runWithReplace (tellEvent ([i] <$ e)) $ ffor pulse $ \_ -> tellEvent ([i+1] <$ e)

63−

61+ return (Just pulseTriggerRef)

64−-- | Test that a widget telling and event which fires at the same time it has been replaced

65−-- doesn't count along with the new widget.

66−testMoribundTellEvent

67− :: forall t m

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 #-}

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

@@ -1,31 +1,8 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE DeriveFunctor #-}

3−{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5−{-# LANGUAGE LambdaCase #-}

6−{-# LANGUAGE RankNTypes #-}

7−{-# LANGUAGE StandaloneDeriving #-}

8{-# LANGUAGE TypeFamilies #-}

1{-# LANGUAGE TypeFamilies #-}

9−{-# LANGUAGE UndecidableInstances #-}

2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

10−

11−import Control.Lens

12−import Control.Monad.Fix

13−import Data.Align

14−import qualified Data.AppendMap as AMap

3+import qualified Data.AppendMap as Map

15−import Data.Functor.Misc

16−import Data.Map (Map)

17−import qualified Data.Map as Map

18−import Data.Map.Monoidal (MonoidalMap)

19import Data.Semigroup

4import 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

5+import Reflex.Dom

27−import Data.Patch.MapWithMove

28−import Test.Run

30newtype MyQuery = MyQuery SelectedCount

7newtype MyQuery = MyQuery SelectedCount

31 deriving (Show, Read, Eq, Ord, Monoid, Semigroup, Additive, Group)

8 deriving (Show, Read, Eq, Ord, Monoid, Semigroup, Additive, Group)

@@ -34,109 +11,19 @@ instance Query MyQuery where

34 type QueryResult MyQuery = ()

11 type QueryResult MyQuery = ()

35 crop _ _ = ()

12 crop _ _ = ()

37−instance (Ord k, Query a, Eq (QueryResult a), Align (MonoidalMap k)) => Query (Selector k a) where

14+instance (Ord k, Query a) => Query (Map.AppendMap k a) where

38− type QueryResult (Selector k a) = Selector k (QueryResult a)

15+ type QueryResult (Map.AppendMap k a) = Map.AppendMap k (QueryResult a)

39 crop q r = undefined

16 crop q r = undefined

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−

67main :: IO ()

18main :: IO ()

68−main = do

19+main = mainWidget $ 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

20 let w = do

104− n <- count increment

21+ n <- count =<< button "Increment"

105− queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1

22+ display n

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

23+ queryDyn $ zipDynWith Map.singleton n $ pure $ MyQuery $ SelectedCount 1

135− return ()

24+ return ()

136−

25+ outer = do

137−-- scam it out to test traverseDMapWithAdjustWithMove

26+ replace <- button "Replace"

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

27+ widgetHold w $ w <$ replace

139−listHoldWithKeyWithMove m0 m' f = do

28+ (_, q) <- runQueryT outer $ pure mempty

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'

29+ display $ incrementalToDynamic q

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

@@ -40,8 +40,6 @@ instance MonadHold (Pure Int) PurePlan where

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

44instance MonadSample (Pure Int) PurePlan where

47 sample = liftPlan . sample

45 sample = liftPlan . sample

@@ -56,15 +54,15 @@ instance TestPlan (Pure Int) PurePlan where

56runPure :: PurePlan a -> (a, IntSet)

54runPure :: PurePlan a -> (a, IntSet)

57runPure (PurePlan p) = runStateT p mempty $ 0

55runPure (PurePlan p) = runStateT p mempty $ 0

59−relevantTimes :: IntSet -> IntSet

57+relavantTimes :: IntSet -> IntSet

60−relevantTimes occs = IntSet.fromList [0..l + 1]

58+relavantTimes occs = IntSet.fromList [0..l + 1]

61 where l = fromMaybe 0 (fst <$> IntSet.maxView occs)

59 where l = fromMaybe 0 (fst <$> IntSet.maxView occs)

63testBehavior :: (Behavior (Pure Int) a, IntSet) -> IntMap a

61testBehavior :: (Behavior (Pure Int) a, IntSet) -> IntMap a

64−testBehavior (b, occs) = IntMap.fromSet (sample b) (relevantTimes occs)

62+testBehavior (b, occs) = IntMap.fromSet (sample b) (relavantTimes occs)

66testEvent :: (Event (Pure Int) a, IntSet) -> IntMap (Maybe a)

64testEvent :: (Event (Pure Int) a, IntSet) -> IntMap (Maybe a)

67−testEvent (Event readEvent, occs) = IntMap.fromSet readEvent (relevantTimes occs)

65+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+28−37

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

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

@@ -19,23 +20,27 @@ import Control.Monad.Ref

19import Reflex.Class

20import Reflex.Class

20import Reflex.Dynamic

21import Reflex.Dynamic

21import Reflex.Host.Class

22import Reflex.Host.Class

23+import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove

22import qualified Reflex.Pure as P

24import qualified Reflex.Pure as P

23import qualified Reflex.Spider.Internal as S

25import qualified Reflex.Spider.Internal as S

24−import qualified Reflex.Profiled as Prof

26import Control.Arrow (second, (&&&))

27import Control.Arrow (second, (&&&))

27import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

28import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

28import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

29import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

30+import Control.Monad.Writer hiding (forM, forM_, mapM, mapM_, sequence, sequence_)

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

31+import Data.Dependent.Map (DMap, DSum (..))

32+import qualified Data.Dependent.Map as DMap

30import Data.Foldable

33import Data.Foldable

34+import Data.Functor.Misc

31import Data.Map.Strict (Map)

35import Data.Map.Strict (Map)

32import qualified Data.Map.Strict as Map

36import qualified Data.Map.Strict as Map

33import qualified Data.Set as Set

37import qualified Data.Set as Set

34−import Data.Monoid

35import Data.Traversable

38import Data.Traversable

36import System.Exit

39import System.Exit

37import System.Mem

40import System.Mem

42+import System.IO.Unsafe

43+

39mapToPureBehavior :: Map Int a -> Behavior PureReflexDomain a

44mapToPureBehavior :: Map Int a -> Behavior PureReflexDomain a

40mapToPureBehavior m = P.Behavior $ \t -> case Map.lookupLE t m of

45mapToPureBehavior m = P.Behavior $ \t -> case Map.lookupLE t m of

41 Nothing -> error $ "mapToPureBehavior: no value for time " <> show t

46 Nothing -> error $ "mapToPureBehavior: no value for time " <> show t

@@ -72,14 +77,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

77instance (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)

78 mapMSignals fb fe (a, b) = liftM2 (,) (mapMSignals fb fe a) (mapMSignals fb fe b)

75−testTimeline

76− :: (forall m t. TestCaseConstraint t m => (Behavior t a, Event t b) -> m (Behavior t c, Event t d))

80+testSpider :: (forall m t. TestCaseConstraint t m => (Behavior t a, Event t b) -> m (Behavior t c, Event t d)) -> (Map Int a, Map Int b) -> (Map Int c, Map Int d)

77− -> (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

81+testSpider builder (bMap, eMap) = unsafePerformIO $ S.runSpiderHost $ do

80 (re, reTrigger) <- newEventWithTriggerRef

82 (re, reTrigger) <- newEventWithTriggerRef

81 (rb, rbTrigger) <- newEventWithTriggerRef

83 (rb, rbTrigger) <- newEventWithTriggerRef

82− b <- runHostFrame $ hold (error "testTimeline: No value for input behavior yet") rb

84+ b <- runHostFrame $ hold (error "testSpider: No value for input behavior yet") rb

83 (b', e') <- runHostFrame $ builder (b, re)

85 (b', e') <- runHostFrame $ builder (b, re)

84 e'Handle <- subscribeEvent e' --TODO: This should be unnecessary

86 e'Handle <- subscribeEvent e' --TODO: This should be unnecessary

85 let times = relevantTestingTimes (bMap, eMap)

87 let times = relevantTestingTimes (bMap, eMap)

@@ -104,11 +106,9 @@ testAgreement :: (Eq c, Eq d, Show c, Show d) => (forall m t. TestCaseConstraint

104testAgreement builder inputs = do

106testAgreement builder inputs = do

105 let identityResult = testPure builder inputs

107 let identityResult = testPure builder inputs

106 tracePerf "---------" $ return ()

108 tracePerf "---------" $ return ()

107− spiderResult <- S.runSpiderHost $ testTimeline builder inputs

109+ let spiderResult = testSpider builder inputs

108− tracePerf "---------" $ return ()

109− profiledResult <- S.runSpiderHost $ Prof.runProfiledM $ testTimeline builder inputs

110 tracePerf "---------" $ return ()

111− let resultsAgree = identityResult == spiderResult && identityResult == profiledResult

111+ let resultsAgree = identityResult == spiderResult

112 if resultsAgree

113 then do --putStrLn "Success:"

114 --print identityResult

@@ -116,7 +116,6 @@ testAgreement builder inputs = do

116 else do putStrLn "Failure:"

117 putStrLn $ "Pure result: " <> show identityResult

118 putStrLn $ "Spider result: " <> show spiderResult

119− putStrLn $ "Profiled result: " <> show profiledResult

120 return resultsAgree

119 return resultsAgree

121

120

122type TestCaseConstraint t m = (Reflex t, MonadSample t m, MonadHold t m, MonadFix m, MonadFix (PushM t))

121type TestCaseConstraint t m = (Reflex t, MonadSample t m, MonadHold t m, MonadFix m, MonadFix (PushM t))

@@ -156,35 +155,35 @@ testCases =

156 let e' = leftmost [e, e]

155 let e' = leftmost [e, e]

157 e'' <- switch <$> hold e' (fmap (const e) e)

156 e'' <- switch <$> hold e' (fmap (const e) e)

158 return (b, e'')

157 return (b, e'')

159− , (,) "switchHoldPromptly-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

158+ , (,) "switchPromptly-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

160 let e' = fmap (const e) e

159 let e' = fmap (const e) e

161− e'' <- switchHoldPromptly never e'

160+ e'' <- switchPromptly never e'

162 return (b, e'')

161 return (b, e'')

163− , (,) "switchHoldPromptly-2" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

162+ , (,) "switchPromptly-2" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

164 let e' = fmap (const e) e

163 let e' = fmap (const e) e

165− e'' <- switchHoldPromptly never $ leftmost [e', e']

164+ e'' <- switchPromptly never $ leftmost [e', e']

166 return (b, e'')

165 return (b, e'')

167− , (,) "switchHoldPromptly-3" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

166+ , (,) "switchPromptly-3" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

168 let e' = leftmost [e, e]

167 let e' = leftmost [e, e]

169− e'' <- switchHoldPromptly never (fmap (const e) e')

168+ e'' <- switchPromptly never (fmap (const e) e')

170 return (b, e'')

169 return (b, e'')

171− , (,) "switchHoldPromptly-4" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do

170+ , (,) "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]

171 let e' = leftmost [e, e]

173− e'' <- switchHoldPromptly never (fmap (const e') e)

172+ e'' <- switchPromptly never (fmap (const e') e)

174 return (b, e'')

173 return (b, e'')

175 , (,) "switch-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

174 , (,) "switch-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

176 let e' = leftmost [e, e]

175 let e' = leftmost [e, e]

177 e'' <- switch <$> hold never (fmap (const e') e)

176 e'' <- switch <$> hold never (fmap (const e') e)

178 return (b, e'')

177 return (b, e'')

179− , (,) "switchHoldPromptly-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

178+ , (,) "switchPromptly-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

180 let e' = flip push e $ \_ -> do

179 let e' = flip push e $ \_ -> do

181 Just <$> headE e

180 Just <$> headE e

182− e'' <- switchHoldPromptly never e'

181+ e'' <- switchPromptly never e'

183 return (b, e'')

182 return (b, e'')

184− , (,) "switchHoldPromptly-6" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

183+ , (,) "switchPromptly-6" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

185 let e' = flip pushAlways e $ \_ -> do

184 let e' = flip pushAlways e $ \_ -> do

186− switchHoldPromptly e never

185+ switchPromptly e never

187− e'' <- switchHoldPromptly never e'

186+ e'' <- switchPromptly never e'

188 return (b, e'')

187 return (b, e'')

189 , (,) "coincidence-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

188 , (,) "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

189 let e' = flip pushAlways e $ \_ -> return e

@@ -223,11 +222,6 @@ testCases =

223 bb <- hold b $ pushAlways (const $ hold "asdf" eo) eo

222 bb <- hold b $ pushAlways (const $ hold "asdf" eo) eo

224 let b' = pull $ sample =<< sample bb

223 let b' = pull $ sample =<< sample bb

225 return (b', e)

224 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

225 , (,) "joinDyn" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do

232 bb <- hold "b" e

226 bb <- hold "b" e

233 bd <- hold never . fmap (const e) =<< headE e

227 bd <- hold never . fmap (const e) =<< headE e

@@ -239,9 +233,6 @@ testCases =

239 rec result <- holdUniqDyn d

233 rec result <- holdUniqDyn d

240 d <- holdDyn (0 :: Int) e

234 d <- holdDyn (0 :: Int) e

241 return (current result, updated result)

235 return (current result, updated result)

242−

243−

244−

245 {-

236 {-

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

237 , (,) "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

238 x <- holdIncremental (DMap.singleton LeftTag $ void e) $ PatchDMapWithMove.mapPatchDMapWithMove (\(Const2 _) -> void e) <$> e

@@ -257,8 +248,8 @@ splitRecombineEvent e =

257 in leftmost [ea, eb]

248 in leftmost [ea, eb]

258

249

259

250

260−main :: IO ()

251+test :: IO ()

261−main = do

252+test = do

262 results <- forM testCases $ \(name, TestCase inputs builder) -> do

253 results <- forM testCases $ \(name, TestCase inputs builder) -> do

263 putStrLn $ "Test: " <> name

254 putStrLn $ "Test: " <> name

264 testAgreement builder inputs

255 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 #-}

2−{-# LANGUAGE BangPatterns #-}

3−{-# LANGUAGE FlexibleContexts #-}

1+{-# LANGUAGE FlexibleContexts, GADTs #-}

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)

27−import qualified Data.Map as M

11+import Data.Functor.Identity

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

51− ]

52− print os1

27+ print out1

53− os2 <- runApp' (unwrapApp testSimultaneous) $ map Just $

28+ (Just out2, Just (out3, out4)) <- runApp app2

54− [ This ()

55− , That ()

56− , This ()

57− , These () ()

58− ]

59− print os2

29+ print out2

60− os3 <- runApp' (unwrapApp testMoribundRequest) [Just ()]

30+ print out3

61− print os3

31+ print out4

62− os4 <- runApp' (unwrapApp testMoribundRequestDMap) [Just ()]

32+ when (sort out1 /= out1 || map (+1) out2 /= out3 || out3 /= out4) exitFailure

63− print os4

33+

64− os5 <- runApp' (unwrapApp testLiveRequestDMap) [Just ()]

34+runApp :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global)

65− print os5

35+ => (Event t () -> RequesterT t RequestInt Identity (PerformEventT t m) (Maybe (Ref m (Maybe (EventTrigger t ())))))

66− os6 <- runApp' (unwrapApp delayedPulse) [Just ()]

36+ -> IO (Maybe [Int], Maybe ([Int], [Int]))

67− print os6

37+runApp x = runSpiderHost $ do

68− os7 <- runApp' testMatchRequestsWithResponses [ Just $ TestRequest_Increment 1 ]

38+ (pulseE, pulseTriggerRef) <- newEventWithTriggerRef

69− print os7

39+ ((mactuateRef, e), FireCommand fire) <- hostPerformEventT $ runRequesterT (x pulseE) never

70− os8 <- runApp' testMatchRequestsWithResponses [ Just $ TestRequest_Reverse "yoyo" ]

40+ hnd <- subscribeEvent (map unwrapRequest . DMap.toList <$> e)

71− print os8

41+ out1 <- fireEventRefAndRead pulseTriggerRef () hnd

72− let ![[Just [1,2,3,4,5,6,7,8,9,10]]] = os1 -- The order is reversed here: see the documentation for 'runRequesterT'

42+ out2 <- fmap join $ forM mactuateRef $ \actuateRef -> do

73− let ![[Just [9,7,5,3,1]],[Nothing,Nothing],[Just [10,8,6,4,2]],[Just [10,8,6,4,2],Nothing]] = os2

43+ let readPhase = do

74− let ![[Nothing, Just [2]]] = os3

44+ mGetValue <- readEvent hnd

75− let ![[Nothing, Just [2]]] = os4

45+ case mGetValue of

76− let ![[Nothing, Just [1, 2]]] = os5

46+ Nothing -> return Nothing

77− -- let ![[Nothing, Nothing]] = os6 -- TODO re-enable this test after issue #233 has been resolved

47+ Just getValue -> fmap Just getValue

78− let !(Just [(1,"2")]) = M.toList <$> head (head os7)

48+ mactuate <- readRef actuateRef

79− let !(Just [(1,"oyoy")]) = M.toList <$> head (head os8)

49+ mpulse <- readRef pulseTriggerRef

80−

50+ forM ((,) <$> mactuate <*> mpulse) $ \(actuate, pulse) -> do

51+ _ <- fire [actuate :=> Identity ()] $ return ()

52+ [Just a] <- fire [pulse :=> Identity ()] $ readPhase

53+ [Just b, Nothing] <- fire [actuate :=> Identity (), pulse :=> Identity ()] $ readPhase

54+ return (a,b)

81− return ()

55+ return (out1, out2)

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

89− -> m (Event t [Int])

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 $ \_ ->

62+ forM_ [1..10] $ \i -> requestingIdentity (RequestInt i <$ e)

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

63+ return Nothing

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

2−

3−import Control.Monad

4−import Language.Haskell.HLint (hlint)

1+import Language.Haskell.HLint3 (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"

24− , "--cpp-define=USE_TEMPLATE_HASKELL"

17+ , "--cpp-define=USE_TEMPLATE_HASKELL"

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

18+ ]

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+