git.iko.soy/patch
on bd3f014 help sign in
b6af869
swap
0 ahead, 571 behind
.github/workflows/haskell.ymldeleted−47
since splitsnapshots
unifiedsplit
@@ -1,47 +0,0 @@
1−name: github-action
2−
3−on: [push, pull_request]
4−
5−jobs:
6− build:
7− strategy:
8− matrix:
9− ghc: ['8.0.2', '8.2.2', '8.4.4', '8.6.5', '8.8.4', '8.10.2']
10− os: ['ubuntu-latest', 'macos-latest']
11− exclude:
12− # There are some linker warnings in 802 on darwin that
13− # cause compilation to fail
14− # See https://github.com/NixOS/nixpkgs/issues/25139
15− - ghc: '8.0.2'
16− os: 'macos-latest'
17− runs-on: ${{ matrix.os }}
18−
19− name: GHC ${{ matrix.ghc }} on ${{ matrix.os }}
20− steps:
21− - uses: actions/checkout@v2
22− - uses: actions/setup-haskell@v1
23− with:
24− ghc-version: ${{ matrix.ghc }}
25− - name: Cache
26− uses: actions/cache@v1
27− env:
28− cache-name: cache-cabal
29− with:
30− path: ~/.cabal
31− key: ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }}
32− restore-keys: |
33− ${{ runner.os }}-${{ matrix.ghc }}-build-${{ env.cache-name }}-
34− ${{ runner.os }}-${{ matrix.ghc }}-build-
35− ${{ runner.os }}-${{ matrix.ghc }}-
36− ${{ runner.os }}
37−
38− - name: Install dependencies
39− run: |
40− cabal update
41− cabal build --only-dependencies --enable-tests --enable-benchmarks
42− - name: Build
43− run: cabal build --enable-tests --enable-benchmarks all
44− - name: Run tests
45− run: cabal test --enable-tests all
46− - name: Build Docs
47− run: cabal haddock
.travis.ymlnew file+16
@@ -0,0 +1,16 @@
1+# Cache Buster: 0
2+language: nix
3+cache:
4+ directories:
5+ - /nix
6+matrix:
7+ include:
8+ - env: COMPILER=ghc7103
9+ - env: COMPILER=ghc821
10+ - env: COMPILER=ghc802
11+ - env: COMPILER=ghcjs
12+script:
13+ - set -e
14+ - nix-build -E "with (import <nixpkgs> {}); pkgs.haskell.packages.$COMPILER.callPackage ./default.nix { }"
15+ - nix-collect-garbage -d # This is important to do right before 'script' ends so the cache gets GCed
16+
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 patch you were using. If you're using a github checkout, provide the git hash.
19−* Describe how you're building patch (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 patch.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−61
@@ -1,61 +0,0 @@
1−# Revision history for patch
2−
3−## Unreleased
4−
5−* New dep of `data-orphans` for old GHC to get instances honestly instead of
6− via `monoidal-containers`.
7−
8−## 0.0.5.0 - 2021-12-17
9−
10−* `Additive` now lives in `Data.Semigroup.Additive`, but is still reexported
11− from `Data.Patch` for compatability.
12−
13−* Rewrite `PatchMapWithMove` in terms of `PatchMapWithPatchingMove`.
14− Care is taken to make this not a breaking change.
15− In particular, `PatchMapWithMove` is a newtype of `PatchMapWithPatchingMove`, as is the `NodeInfo` and `From` of `PatchMapWithPatchingMove`'s versions of those.
16− There are complete constructor and field patterns too, and everything is
17− exported under the newtype as real constructors and fields would be.
18−
19−## 0.0.4.0 - 2021-04-20
20−
21−* Enable PolyKinds
22−
23−## 0.0.3.2 - 2020-11-06
24−
25−* Update version bounds
26−
27−## 0.0.3.1 - 2020-02-05
28−
29−* Replace `fromJust` with something easier to debug.
30−
31−## 0.0.3.0 - 2020-02-05
32−
33−* Create `PatchMapWithPatchingMove` variant which supports moves with a patch.
34−
35−* Create `DecidablyEmpty` subclass of `Monoid`.
36−
37−## 0.0.2.0 - 2020-01-17
38−
39−* Consistently provide:
40−
41− - `Wrapped` instances
42−
43− - `*WithIndex` instances
44−
45− - `un*` newtype unwrappers
46−
47− for `PatchMap`, `PatchIntMap`, and `PatchMapWithMove`.
48−
49−## 0.0.1.0 - 2020-01-09
50−
51−* Support older GHCs with `split-these` flag.
52−
53−* Additional instances for the `Group` class for basic types.
54−
55−## 0.0.0.1 - 2020-01-08
56−
57−* Remove unneeded dependencies
58−
59−## 0.0.0.0 - 2020-01-08
60−
61−* Extract patching functionality from Reflex.
Quickref.mdnew file+286
@@ -0,0 +1,286 @@
1+# Reflex Quick(ish) Reference
2+
3+## Typeclasses
4+
5+Many Reflex functions operate in monadic context `m a`, where the monad 'm' supports various additional typeclasses such as MonadWidget, MonadHold, or MonadSample in addition to Monad itself. The actual 'm' in use will be determined by the top-level entry point of the FRP host (such as Reflex-Dom -- see the bottom of the Reflex-Dom quick reference for details).
6+
7+The function signatures here have been simplified by removing many typeclass constraints and adding simple annotations to each function. Also the ubiquitous 't' type parameter has been removed.
8+
9+Some of these functions are *pure*: They operate on Events, Behaviors, or Dynamics uniformly without regard to the "current time". Other functions must operate in some monadic context, because they produce a result "as of now" (e.g., any function that takes an "initial" value, or returns a "current" value). Annotations are used to distinguish these cases:
10+
11+```haskell
12+[ ] -- Pure function
13+[S] -- Function runs in any monad supporting MonadSample
14+[H] -- Function runs in any monad supporting MonadHold
15+```
16+Since MonadHold depends on MonadSample, any [S] function also runs in [H] context.
17+
18+## Functions producing Event
19+
20+```haskell
21+-- Trivial Event
22+[ ] never :: Event a
23+
24+-- Extract Event from Dynamic
25+[ ] updated :: Dynamic a -> Event a
26+
27+-- Transform Event to Event using function
28+[ ] fmap :: (a -> b) -> Event a -> Event b
29+[ ] fmapMaybe :: (a -> Maybe b) -> Event a -> Event b
30+[ ] ffilter :: (a -> Bool) -> Event a -> Event a
31+[ ] ffor :: Event a -> (a -> b) -> Event b
32+[ ] fforMaybe :: Event a -> (a -> Maybe b) -> Event b
33+[ ] <$ :: a -> Event b -> Event a
34+
35+-- Event to identical Event with debug trace. (Only prints if Event is ultimately used.)
36+[ ] traceEvent :: Show a => String -> Event a -> Event a
37+[ ] traceEventWith :: (a -> String) -> Event a -> Event a
38+
39+-- Transform Event to Event by sampling Behavior or Dynamic
40+[ ] gate :: Behavior Bool -> Event a -> Event a
41+[ ] tag :: Behavior a -> Event b -> Event a
42+[ ] tagPromptlyDyn :: Dynamic a -> Event b -> Event a
43+[ ] attach :: Behavior a -> Event b -> Event (a, b)
44+[ ] attachPromptlyDyn :: Dynamic a -> Event b -> Event (a, b)
45+[ ] attachWith :: (a -> b -> c) -> Behavior a -> Event b -> Event c
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
51+
52+-- Combine multiple Events
53+[ ] <> :: Semigroup a => Event a -> Event a -> Event a
54+[ ] difference :: Event a -> Event b -> Event a
55+[ ] align :: Event a -> Event b -> Event (These a b)
56+[ ] alignWith :: (These a b -> c) -> Event a -> Event b -> Event c
57+[ ] mergeWith :: (a -> a -> a) -> [Event a] -> Event a
58+[ ] leftmost :: [Event a] -> Event a
59+[ ] mergeList :: [Event a] -> Event (NonEmpty a)
60+[ ] merge :: GCompare k => DMap (WrapArg Event k) -> Event (DMap k)
61+[ ] mergeMap :: Ord k => Map k (Event a) -> Event (Map k a)
62+
63+-- Efficient one-to-many fanout
64+[ ] fanMap :: Ord k => Event (Map k a) -> EventSelector (Const2 k a)
65+[ ] fan :: GCompare k => Event (DMap k) -> EventSelector k
66+[ ] select :: EventSelector k -> k a -> Event a
67+[ ] fanEither :: Event (Either a b) -> (Event a, Event b)
68+[ ] fanThese :: Event (These a b) -> (Event a, Event b)
69+
70+-- Event to Event via function that can sample current values
71+[ ] push :: (a -> m (Maybe b)) -> Event a -> Event b
72+[ ] pushAlways :: (a -> m b ) -> Event a -> Event b
73+ -- Note supplied function operates in [H] context
74+
75+-- Split Event into next occurrence and all other future occurrences, as of now.
76+[H] headE :: Event a -> m (Event a)
77+[H] tailE :: Event a -> m (Event a)
78+[H] headTailE :: Event a -> m (Event a, Event a)
79+```
80+
81+## Functions producing Behavior
82+
83+```haskell
84+-- Trivial Behavior
85+[ ] constant :: a -> Behavior a
86+
87+-- Extract Behavior from Dynamic
88+[ ] current :: Dynamic a -> Behavior a
89+
90+-- Create Behavior with given initial value, updated when the Event fires.
91+[H] hold :: a -> Event a -> m (Behavior a)
92+
93+-- Transform Behavior to Behavior using function
94+[ ] fmap :: (a -> b) -> Behavior a -> Behavior b
95+[ ] ffor :: Behavior a -> (a -> b) -> Behavior b
96+[ ] <*> :: Behavior (a -> b) -> Behavior a -> Behavior b
97+[ ] >>= :: Behavior a -> (a -> Behavior b) -> Behavior b
98+[ ] <> :: Monoid a => Behavior a -> Behavior a -> Behavior a
99+-- ... plus many more due to typeclass membership
100+
101+-- Behavior to Behavior by sampling current values
102+[S] sample :: Behavior a -> m a
103+[ ] pull :: m a -> Behavior a
104+ -- Note supplied value is in [S] context
105+```
106+
107+## Functions producing Dynamic
108+
109+```haskell
110+-- Trivial Dynamic
111+[ ] constDyn :: a -> Dynamic a
112+
113+-- Create Dynamic with given initial value, updated (various ways) when the Event fires.
114+[H] holdDyn :: a -> Event a -> m (Dynamic a)
115+[H] foldDyn :: (a -> b -> b ) -> b -> Event a -> m (Dynamic b)
116+[H] foldDynMaybe :: (a -> b -> Maybe b ) -> b -> Event a -> m (Dynamic b)
117+[H] foldDynM :: (a -> b -> m' b ) -> b -> Event a -> m (Dynamic b)
118+[H] foldDynMaybeM :: (a -> b -> m' (Maybe b)) -> b -> Event a -> m (Dynamic b)
119+ -- Note m' supplies [H] context
120+
121+-- Initial value is 0; counts Event firings from now.
122+[H] count :: Num b => Event a -> m (Dynamic b)
123+-- Initial Bool value is supplied; toggles at each Event firing.
124+[H] toggle :: Bool -> Event a -> m (Dynamic Bool)
125+
126+-- Transform Dynamic to Dynamic using function
127+[ ] ffor :: Dynamic a -> (a -> b) -> Dynamic b
128+[ ] fmap :: (a -> b) -> Dynamic a -> Dynamic b
129+[ ] splitDynPure :: Dynamic (a, b) -> (Dynamic a, Dynamic b)
130+
131+-- Combine multiple Dynamics
132+[ ] mconcat :: Monoid a => [Dynamic a] -> Dynamic a
133+[ ] distributeDMapOverDynPure :: GCompare k => DMap (WrapArg Dynamic k) -> Dynamic (DMap k)
134+[ ] <*> :: Dynamic (a -> b) -> Dynamic a -> Dynamic b
135+[ ] >>= :: Dynamic a -> (a -> Dynamic b) -> Dynamic b
136+[ ] zipDynWith :: (a -> b -> c) -> Dynamic a -> Dynamic b -> Dynamic c
137+
138+-- Efficient one-to-many fanout
139+[ ] demux :: Ord k => Dynamic k -> Demux k
140+[ ] demuxed :: Eq k => Demux k -> k -> Dynamic Bool
141+
142+-- Dynamic to Dynamic, removing updates w/o value change
143+[H] holdUniqDyn :: Eq a => Dynamic a -> m (Dynamic a)
144+[H] holdUniqDynBy :: (a -> a -> Bool) -> Dynamic t a -> m (Dynamic t a)
145+
146+-- Dynamic to identical Dynamic with debug trace. (Only prints if Dynamic is ultimately used.)
147+[ ] traceDyn :: Show a => String -> Dynamic a -> Dynamic a
148+[ ] traceDynWith :: (a -> String) -> Dynamic a -> Dynamic a
149+```
150+
151+## Flattening functions
152+
153+These functions flatten nested types such as Event-of-Event, Behavior-of-Event, Event-of-Behavior etc, removing the outer wrapper.
154+
155+For Events, the returned Event fires whenever the latest Event supplied by the wrapper fires. There are differences in how the functions handle *coincidences* -- situations where the old or new Event fires at the same instant that we switch from old to new. In some cases, the output Event tracks the old Event at the instant of switchover, while in other cases it tracks the new Event.
156+
157+```haskell
158+-- Flatten Behavior-of-Event to Event. Old Event is used during switchover.
159+[ ] switch :: Behavior (Event a) -> Event a
160+
161+-- Flatten Dyanmic-of-Event to Event. New Event is used immediately.
162+[ ] switchDyn :: Dynamic (Event a) -> Event a
163+
164+-- Flatten Event-of-Event to Event that fires when both wrapper AND new Event fire.
165+[ ] coincidence :: Event (Event a) -> Event a
166+
167+-- Flatten Behavior-of-Behavior to Behavior. Behavior is an instance of Monad,
168+-- so the 'join' function from 'Control.Monad' suffices. The output of 'join' is
169+-- a Behavior whose value is equal to the current value of the current value of
170+-- the input.
171+[ ] join :: Behavior (Behavior a) -> Behavior a
172+
173+
174+-- Flatten Dynamic-of-Dynamic to Dynamic. New Dynamic is used immediately.
175+-- Output updated whenever inner OR outer Dynamic updates.
176+[ ] join :: Dynamic (Dynamic a) -> Dynamic a
177+[ ] joinDynThroughMap :: Ord k => Dynamic (Map k (Dynamic a)) -> Dynamic (Map k a)
178+
179+-- Analogous to 'hold': Create a Behavior that is initially identical to the
180+-- supplied Behavior. Updated to track a new Behavior whenever the Event fires.
181+[H] switcher :: Behavior a -> Event (Behavior a) -> m (Behavior a)
182+
183+-- Similar to above, for Events. Created Event initially tracks the first argument.
184+-- At switchover, the output Event immediately tracks the new Event.
185+[H] switchHold :: Event a -> Event (Event a) -> m (Event a)
186+```
187+
188+## Typeclasses to introspect and modify an FRP network.
189+
190+The functions mentioned above are used to create a static FRP network.
191+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.
192+
193+Th typeclasses and their associated annotations include:
194+
195+- `PostBuild`
196+ Fire an Event when an FRP network has been set up.
197+ ```haskell
198+ [B] -- Function runs in any monad supporting PostBuild
199+ ```
200+
201+- `Adjustable`
202+ Use Events to add or remove pieces of an FRP network.
203+ ```haskell
204+ [A] -- Function runs in any monad supporting Adjustable
205+ ```
206+
207+- `TriggerEvent`
208+ Create new externally-fired Events from within an FRP network.
209+ ```haskell
210+ [T] -- Function runs in any monad supporting TriggerEvent
211+ ```
212+
213+- `PerformEvent`
214+ Use Events to trigger IO actions and to collect their results.
215+ ```haskell
216+ [P] -- Function runs in any monad supporting PerformEvent
217+ ```
218+
219+## Startup
220+
221+```haskell
222+-- One-shot Event that is triggered once the FRP network has been built
223+[B] getPostBuild :: m (Event ())
224+```
225+
226+## Collection management functions
227+
228+```haskell
229+-- Turn a Dynamic key/value map into a set of dynamically-changing widgets.
230+[H,A,B] listWithKey :: Ord k =>
231+ Dynamic (Map k v) -> (k -> Dynamic v -> m a ) -> m (Dynamic (Map k a))
232+
233+-- Same as above where the widget constructor doesn't care about the key.
234+[H,A,B] list :: Ord k =>
235+ Dynamic (Map k v) -> ( Dynamic v -> m a ) -> m (Dynamic (Map k a))
236+
237+-- Even simpler version where there are no keys and we just use a list.
238+[H,A,B] simpleList ::
239+ Dynamic [v] -> ( Dynamic v -> m a ) -> m (Dynamic [a])
240+
241+-- Like listWithKey specialized for widgets returning (Event a).
242+[H,A,B] listViewWithKey :: Ord k =>
243+ Dynamic (Map k v) -> (k -> Dynamic v -> m (Event a)) -> m (Event (Map k a))
244+
245+-- Create a dynamically-changing set of widgets, one of which is selected at any time.
246+[H,A,B] selectViewListWithKey_ :: Ord k => Dynamic k ->
247+ Dynamic (Map k v) -> (k -> Dynamic v -> Dynamic Bool -> m (Event a)) -> m (Event k)
248+
249+-- Same as listWithKey, but takes initial values and an updates Event instead of a Dynamic.
250+[H,A] listWithKeyShallowDiff :: Ord k =>
251+ Map k v -> Event (Map k (Maybe v)) -> (k -> v -> Event v -> m a) -> m (Dynamic (Map k a))
252+```
253+
254+## Creating new events from within an FRP network.
255+
256+```haskell
257+-- Create a new Event and a function that will cause the Event to fire, from within an FRP network
258+[T] newTriggerEvent :: m (Event a, a -> IO ())
259+```
260+
261+## Connecting to the real world (I/O)
262+
263+```haskell
264+-- Run side-effecting actions in Event when it occurs; returned Event contains
265+-- results. Side effects run in the (Performable m) monad which is associated with
266+-- the (PerformEvent t m) typeclass constraint.
267+-- This allows for working with IO when a ((MonadIO (Performable m)) constraint is available.
268+[P] performEvent :: Event (Performable m a ) -> m (Event a)
269+
270+-- Just run side-effects; no return Event
271+[P] performEvent_ :: Event (Performable m ()) -> m ()
272+
273+-- Actions run asynchronously; actions are given a callback to send return values
274+[P,T] performEventAsync :: Event ((a -> IO ()) -> Performable m ()) -> m (Event a)
275+```
276+
277+### Time
278+
279+```haskell
280+-- Create Event at given interval with given basis time.
281+[P,T] tickLossy :: NominalDiffTime -> UTCTime -> m (Event t TickInfo)
282+
283+-- Delay an Event's occurrences by a given amount in seconds.
284+[P,T] delay :: NominalDiffTime -> Event t a -> m (Event t a)
285+```
286+
README.md+11−44
@@ -1,52 +1,19 @@
1−# patch
1+## Reflex
2+### Practical Functional Reactive Programming
2
3
3−[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/patch.svg)](https://hackage.haskell.org/package/patch) [![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/patch/badge)](https://matrix.hackage.haskell.org/#/package/patch) [![Travis CI](https://api.travis-ci.org/reflex-frp/patch.svg?branch=develop)](https://travis-ci.org/reflex-frp/patch) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](https://github.com/reflex-frp/patch/LICENSE)
4+Reflex is an fully-deterministic, higher-order Functional Reactive Programming (FRP) interface and an engine that efficiently implements that interface.
4
5
5−Data structures for describing changes to other data structures.
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.
6
7
7−A `Patch` type represents a kind of change made to a data structure.
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).
8
9
9−```haskell
10+A summary of Reflex functions is available in the [quick reference](Quickref.md).
10−class Patch p where
11− type PatchTarget p :: *
12− -- | Apply the patch p a to the value a. If no change is needed, return
13− -- 'Nothing'.
14− apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
15−```
16
11
17−## Patching Maps
12+### Additional resources
18−For example, `Data.Patch.Map` defines the `PatchMap` type which can be used to patch `Map`s. A `PatchMap` represents updates to a `Map` that can insert, remove, or replace items in the `Map`. In this example, the `Map` is the `PatchTarget` and the `PatchMap` is the `Patch`. Keep in mind that there are many other possible `Patch`es that can be applied to a `Map` (i.e., `Map` can be the `PatchTarget` for many different `Patch` instances).
13+[Get started with Reflex](https://github.com/reflex-frp/reflex-platform)
19
14
20−`PatchMap` is defined as:
15+[/r/reflexfrp](https://www.reddit.com/r/reflexfrp)
21
16
22−```haskell
17+[hackage](https://hackage.haskell.org/package/reflex)
23−newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }
24−```
25
18
26−The `Maybe` around the value is used to represent insertion/updates or deletion of the element at a given key.
19+[irc.freenode.net #reflex-frp](http://webchat.freenode.net?channels=%23reflex-frp&uio=d4)
27−
28−Its `Patch` instance begins with:
29−
30−```haskell
31−instance Ord k => Patch (PatchMap k v) where
32− type PatchTarget (PatchMap k v) = Map k v
33− ...
34−```
35−
36−When a `PatchMap` is applied to its `PatchTarget`, the following changes can occur:
37−
38−- If the key is present in the `Patch` and the `PatchTarget`...
39−
40− - And the `Patch` value at that key is `Nothing`: delete that key from the `PatchTarget`.
41−
42− - And the `Patch` value at that key is `Just x`: update the value at that key in the `PatchTarget` to `x`.
43−
44−- If the key is present in the `Patch` and not present in the `PatchTarget`...
45−
46− - And the `Patch` value at that key is `Nothing`: do nothing because we're trying to delete a key that doesn't exist in the target in the first place.
47−
48− - And the `Patch` value at that key is `Just x`: insert the key and the value `x` into the `PatchTarget`
49−
50−- If the key is *not* present in the `Patch` but present in the `PatchTarget`: do nothing.
51−
52−There are, of course, more complicated ways of patching maps involving, for example, moving values from one key to another. You can find the code for that in `Data.Patch.PatchMapWithMove`. Note that the `PatchTarget` type associated with the `PatchMapWithMove` patch instance is still `Map k v`!
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
42 // or just continue immediately. It's a workaround for the fact
43 // that signalling a condition variable doesn't do anything if the
43 // that signalling a condition variable doesn't do anything if the
44 // thread is already running, but we want it to be sticky.
44 // thread is already running, but we want it to be sticky.
45− HsBool wakeup;
45+ rtsBool wakeup;
46#endif
46#endif
47
47
48 // This points to the Capability that the Task "belongs" to. If
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
62 // The current top-of-stack InCall
63 struct InCall_ *incall;
63 struct InCall_ *incall;
64
64
65− uint32_t n_spare_incalls;
65+ nat n_spare_incalls;
66 struct InCall_ *spare_incalls;
66 struct InCall_ *spare_incalls;
67
67
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
70
70
71 // So that we can detect when a finalizer illegally calls back into Haskell
71 // So that we can detect when a finalizer illegally calls back into Haskell
72− HsBool running_finalizers;
72+ rtsBool running_finalizers;
73
73
74 // Links tasks on the returning_tasks queue of a Capability, and
74 // Links tasks on the returning_tasks queue of a Capability, and
75 // on spare_workers.
75 // on spare_workers.
@@ -88,7 +88,7 @@ struct Capability_ {
88 StgFunTable f;
88 StgFunTable f;
89 StgRegTable r;
89 StgRegTable r;
90
90
91− uint32_t no; // capability number.
91+ nat no; // capability number.
92
92
93 // The Task currently holding this Capability. This task has
93 // The Task currently holding this Capability. This task has
94 // exclusive access to the contents of this Capability (apart from
94 // exclusive access to the contents of this Capability (apart from
@@ -98,12 +98,12 @@ struct Capability_ {
98
98
99 // true if this Capability is running Haskell code, used for
99 // true if this Capability is running Haskell code, used for
100 // catching unsafe call-ins.
100 // catching unsafe call-ins.
101− HsBool in_haskell;
101+ rtsBool in_haskell;
102
102
103 // Has there been any activity on this Capability since the last GC?
103 // Has there been any activity on this Capability since the last GC?
104− uint32_t idle;
104+ nat idle;
105
105
106− HsBool disabled;
106+ rtsBool disabled;
107
107
108 // The run queue. The Task owning this Capability has exclusive
108 // The run queue. The Task owning this Capability has exclusive
109 // access to its run queue, so can wake up threads without
109 // access to its run queue, so can wake up threads without
@@ -159,7 +159,7 @@ struct Capability_ {
159#if defined(THREADED_RTS)
159#if defined(THREADED_RTS)
160 // Worker Tasks waiting in the wings. Singly-linked.
160 // Worker Tasks waiting in the wings. Singly-linked.
161 Task *spare_workers;
161 Task *spare_workers;
162− uint32_t n_spare_workers; // count of above
162+ nat n_spare_workers; // count of above
163
163
164 // This lock protects:
164 // This lock protects:
165 // running_task
165 // running_task
@@ -192,9 +192,10 @@ struct Capability_ {
192
192
193 // Per-capability STM-related data
193 // Per-capability STM-related data
194 StgTVarWatchQueue *free_tvar_watch_queues;
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.hsnew file+109
@@ -0,0 +1,109 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE TupleSections #-}
5+{-# LANGUAGE TypeFamilies #-}
6+
7+-- The instance for NFData (TVar a) is an orphan, but necessary here
8+{-# OPTIONS_GHC -fno-warn-orphans #-}
9+
10+module Main where
11+
12+import Control.Concurrent.STM
13+import Control.DeepSeq
14+import Control.Exception (evaluate)
15+import Control.Monad.Identity
16+import Control.Monad.IO.Class
17+import Criterion.Main
18+import Data.Dependent.Map (DMap)
19+import qualified Data.Dependent.Map as DMap
20+import Data.Dependent.Sum
21+import Data.Functor.Misc
22+import Data.IORef
23+import Reflex
24+import Reflex.Host.Class
25+
26+main :: IO ()
27+main = defaultMain
28+ [ bgroup "micro" micros ]
29+
30+#if !(MIN_VERSION_deepseq(1,4,2))
31+instance NFData (IORef a) where
32+ rnf x = seq x ()
33+#endif
34+
35+instance NFData (TVar a) where
36+ rnf x = seq x ()
37+
38+newtype WHNF a = WHNF a
39+instance NFData (WHNF a) where
40+ rnf (WHNF a) = seq a ()
41+
42+withSetup :: NFData b => String -> SpiderHost Global a -> (a -> SpiderHost Global b) -> Benchmark
43+withSetup name setup action = env (WHNF <$> runSpiderHost setup) $ \ ~(WHNF a) ->
44+ bench name . nfIO $ runSpiderHost (action a)
45+
46+withSetupWHNF :: String -> SpiderHost Global a -> (a -> SpiderHost Global b) -> Benchmark
47+withSetupWHNF name setup action = env (WHNF <$> runSpiderHost setup) $ \ ~(WHNF a) ->
48+ bench name . whnfIO $ runSpiderHost (action a)
49+
50+micros :: [Benchmark]
51+micros =
52+ [ bench "newIORef" $ whnfIO $ void $ newIORef ()
53+ , env (newIORef (42 :: Int)) (bench "readIORef" . whnfIO . readIORef)
54+ , bench "newTVar" $ whnfIO $ void $ newTVarIO ()
55+ , env (newTVarIO (42 :: Int)) (bench "readTVar" . whnfIO . readTVarIO)
56+ , bench "newEventWithTrigger" $ whnfIO . void $ runSpiderHost $ newEventWithTrigger $
57+ \trigger -> return () <$ evaluate trigger
58+ , bench "newEventWithTriggerRef" $ whnfIO . void $ runSpiderHost newEventWithTriggerRef
59+ , withSetupWHNF "subscribeEvent" newEventWithTriggerRef $ subscribeEvent . fst
60+ , withSetupWHNF "subscribeSwitch"
61+ (join $ hold <$> fmap fst newEventWithTriggerRef <*> fmap fst newEventWithTriggerRef)
62+ (subscribeEvent . switch)
63+ , withSetupWHNF "subscribeMerge(1)" (setupMerge 1) $ \(ev,_) -> subscribeEvent ev
64+ , withSetupWHNF "subscribeMerge(100)" (setupMerge 100) (subscribeEvent . fst)
65+ , withSetupWHNF "subscribeMerge(10000)" (setupMerge 10000) (subscribeEvent . fst)
66+ , bench "runHostFrame" $ whnfIO $ runSpiderHost $ runHostFrame $ return ()
67+ , withSetupWHNF "fireEventsAndRead(single/single)"
68+ (newEventWithTriggerRef >>= subscribePair)
69+ (\(subd, trigger) -> fireAndRead trigger (42 :: Int) subd)
70+ , withSetupWHNF "fireEventsOnly"
71+ (newEventWithTriggerRef >>= subscribePair)
72+ (\(_, trigger) -> do
73+ Just key <- liftIO $ readIORef trigger
74+ fireEvents [key :=> Identity (42 :: Int)])
75+ , withSetupWHNF "fireEventsAndRead(head/merge1)"
76+ (setupMerge 1 >>= subscribePair)
77+ (\(subd, t:_) -> fireAndRead t (42 :: Int) subd)
78+ , withSetupWHNF "fireEventsAndRead(head/merge100)"
79+ (setupMerge 100 >>= subscribePair)
80+ (\(subd, t:_) -> fireAndRead t (42 :: Int) subd)
81+ , withSetupWHNF "fireEventsAndRead(head/merge10000)"
82+ (setupMerge 10000 >>= subscribePair)
83+ (\(subd, t:_) -> fireAndRead t (42 :: Int) subd)
84+ , withSetupWHNF "fireEventsOnly(head/merge100)"
85+ (setupMerge 100 >>= subscribePair)
86+ (\(_, t:_) -> do
87+ Just key <- liftIO $ readIORef t
88+ fireEvents [key :=> Identity (42 :: Int)])
89+ , withSetupWHNF "hold" newEventWithTriggerRef $ \(ev, _) -> hold (42 :: Int) ev
90+ , withSetupWHNF "sample" (newEventWithTriggerRef >>= hold (42 :: Int) . fst) sample
91+ ]
92+
93+setupMerge :: Int
94+ -> SpiderHost Global ( Event (SpiderEnv Global) (DMap (Const2 Int a) Identity)
95+ , [IORef (Maybe (EventTrigger Spider a))]
96+ )
97+setupMerge num = do
98+ (evs, triggers) <- unzip <$> replicateM num newEventWithTriggerRef
99+ let !m = DMap.fromList [Const2 i :=> v | (i,v) <- zip [0..] evs]
100+ pure (merge m, triggers)
101+
102+subscribePair :: (Event (SpiderEnv Global) a, b) -> SpiderHost Global (EventHandle (SpiderEnv Global) a, b)
103+subscribePair (ev, b) = (,b) <$> subscribeEvent ev
104+
105+fireAndRead :: IORef (Maybe (EventTrigger (SpiderEnv Global) a)) -> a -> EventHandle (SpiderEnv Global) b
106+ -> SpiderHost Global (Maybe b)
107+fireAndRead trigger val subd = do
108+ Just key <- liftIO $ readIORef trigger
109+ fireEventsAndRead [key :=> Identity val] $ readEvent subd >>= sequence
bench/RunAll.hsnew file+157
@@ -0,0 +1,157 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE ForeignFunctionInterface #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
9+{-# LANGUAGE PatternSynonyms #-}
10+{-# LANGUAGE RankNTypes #-}
11+{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TemplateHaskell #-}
13+{-# LANGUAGE TupleSections #-}
14+{-# LANGUAGE TypeSynonymInstances #-}
15+{-# LANGUAGE ViewPatterns #-}
16+{-# OPTIONS_GHC -fno-warn-orphans #-}
17+
18+module Main where
19+
20+import Criterion.Main
21+import Criterion.Types
22+
23+import Reflex
24+import Reflex.Host.Class
25+
26+import Reflex.Plan.Reflex
27+import Reflex.TestPlan
28+
29+import qualified Reflex.Bench.Focused as Focused
30+import Reflex.Spider.Internal (SpiderEventHandle)
31+
32+import Control.Applicative
33+import Control.DeepSeq (NFData (..))
34+
35+import Prelude
36+import System.IO
37+import System.Mem
38+
39+import Control.Arrow
40+import Control.Concurrent
41+import Control.Concurrent.STM
42+import Control.Exception
43+import Control.Monad
44+import Control.Monad.Trans
45+import Data.Bool
46+import Data.Function
47+import Data.Int
48+import Data.IORef
49+import Data.Monoid
50+import Data.Time.Clock
51+import Debug.Trace.LocationTH
52+import GHC.Stats
53+import System.Environment
54+import System.Mem.Weak
55+import System.Process
56+import Text.Read
57+
58+import Unsafe.Coerce
59+
60+import Data.Map (Map)
61+import qualified Data.Map as Map
62+
63+type MonadReflexHost' t m = (MonadReflexHost t m, MonadIORef m, MonadIORef (HostFrame t))
64+
65+
66+setupFiring :: (MonadReflexHost t m, MonadIORef m) => Plan t (Event t a) -> m (EventHandle t a, Schedule t)
67+setupFiring p = do
68+ (e, s) <- runPlan p
69+ h <- subscribeEvent e
70+ return (h, s)
71+
72+-- Hack to avoid the NFData constraint for EventHandle which is a synonym
73+newtype Ignore a = Ignore a
74+instance NFData (Ignore a) where
75+ rnf !_ = ()
76+
77+instance NFData (SpiderEventHandle x a) where
78+ rnf !_ = ()
79+
80+instance NFData (Behavior t a) where
81+ rnf !_ = ()
82+
83+instance NFData (Firing t) where
84+ rnf !_ = ()
85+
86+-- Measure the running time
87+benchFiring :: forall t m. (MonadReflexHost' t m, MonadSample t m) => (forall a. m a -> IO a) -> TestCase -> Int -> IO ()
88+benchFiring runHost tc n = runHost $ do
89+ let runIterations :: m a -> m ()
90+ runIterations test = replicateM_ (10*n) $ do
91+ result <- test
92+ liftIO $ evaluate result
93+ case tc of
94+ TestE p -> do
95+ (h, s) <- setupFiring p
96+ runIterations $ readSchedule_ s $ readEvent' h
97+ TestB p -> do
98+ (b, s) <- runPlan p
99+ runIterations $ readSchedule_ (makeDense s) $ sample b
100+
101+waitForFinalizers :: IO ()
102+waitForFinalizers = do
103+ performGC
104+ x <- getCurrentTime
105+ isFinalized <- newIORef False
106+ mkWeakPtr x $ Just $ writeIORef isFinalized True
107+ performGC
108+ fix $ \loop -> do
109+ f <- readIORef isFinalized
110+ unless f $ do
111+ threadDelay 1
112+ loop
113+
114+benchmarks :: [(String, Int -> IO ())]
115+benchmarks = implGroup "spider" runSpiderHost cases
116+ where
117+ implGroup :: (MonadReflexHost' t m, MonadSample t m) => String -> (forall a. m a -> IO a) -> [(String, TestCase)] -> [(String, Int -> IO ())]
118+ implGroup name runHost = group name . fmap (second (benchFiring runHost))
119+ group name = fmap $ first ((name <> "/") <>)
120+ sub n frames = group ("subscribing " ++ show (n, frames)) $ Focused.subscribing n frames
121+ firing n = group ("firing " <> show n) $ Focused.firing n
122+ merging n = group ("merging " <> show n) $ Focused.merging n
123+ dynamics n = group ("dynamics " <> show n) $ Focused.dynamics n
124+ cases = concat
125+ [ sub 100 40
126+ , dynamics 100
127+ , dynamics 1000
128+ , firing 1000
129+ , firing 10000
130+ , merging 10
131+ , merging 50
132+ , merging 100
133+ , merging 200
134+ ]
135+
136+pattern RunTestCaseFlag = "--run-test-case"
137+
138+spawnBenchmark :: String -> Benchmark
139+spawnBenchmark name = Benchmark name $ Benchmarkable $ \n -> do
140+ self <- getExecutablePath
141+ callProcess self [RunTestCaseFlag, name, show n, "+RTS", "-N1"]
142+
143+foreign import ccall unsafe "myCapabilityHasOtherRunnableThreads" myCapabilityHasOtherRunnableThreads :: IO Bool
144+
145+main :: IO ()
146+main = do
147+ args <- getArgs
148+ case args of
149+ RunTestCaseFlag : t -> case t of
150+ [name, readMaybe -> Just count] -> do
151+ case lookup name benchmarks of
152+ Just testCase -> testCase count
153+ performGC
154+ fix $ \loop -> bool (return ()) (yield >> loop) =<< myCapabilityHasOtherRunnableThreads
155+ return ()
156+ _ -> $failure "--run-test-case: expected test name and iteration count to follow"
157+ _ -> defaultMainWith (defaultConfig { timeLimit = 20, csvFile = Just "dmap-original.csv", reportFile = Just "report.html" }) $ fmap (spawnBenchmark . fst) benchmarks
cabal.projectdeleted−1
@@ -1 +0,0 @@
1−packages: .
default.nixnew file+38
@@ -0,0 +1,38 @@
1+{ mkDerivation, ghc, base, bifunctors, containers, deepseq
2+, dependent-map, dependent-sum, exception-transformers
3+, haskell-src-exts, haskell-src-meta, hlint, lens, MemoTrie
4+, monad-control, mtl, primitive, random, ref-tf
5+, semigroupoids , semigroups, split, stdenv, stm, syb
6+, template-haskell , these, time, transformers
7+, transformers-compat, unbounded-delays, prim-uniq
8+, data-default , filepath, directory, filemanip, ghcjs-base
9+, useTemplateHaskell ? true
10+}:
11+mkDerivation {
12+ pname = "reflex";
13+ version = "0.5.0";
14+ src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.;
15+ libraryHaskellDepends = [
16+ base bifunctors containers dependent-map dependent-sum
17+ exception-transformers lens
18+ MemoTrie monad-control mtl primitive ref-tf semigroupoids
19+ semigroups stm syb template-haskell these transformers
20+ transformers-compat prim-uniq
21+ base bifunctors containers deepseq dependent-map dependent-sum
22+ mtl ref-tf split transformers data-default
23+ random time unbounded-delays
24+ ] ++ (if ghc.isGhcjs or false then [
25+ ghcjs-base
26+ ] else []) ++ (if !useTemplateHaskell then [] else [
27+ haskell-src-exts haskell-src-meta
28+ ]);
29+ testHaskellDepends = if ghc.isGhcjs or false then [] else [
30+ hlint filepath directory filemanip
31+ ];
32+ configureFlags = if useTemplateHaskell then [] else [
33+ "-f-use-template-haskell"
34+ ];
35+ homepage = "https://github.com/reflex-frp/reflex";
36+ description = "Higher-order Functional Reactive Programming";
37+ license = stdenv.lib.licenses.bsd3;
38+}
dep/reflex-platform/default.nixdeleted−8
@@ -1,8 +0,0 @@
1−# DO NOT HAND-EDIT THIS FILE
2−let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:
3− if !fetchSubmodules && !private then builtins.fetchTarball {
4− url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;
5− } else (import <nixpkgs> {}).fetchFromGitHub {
6− inherit owner repo rev sha256 fetchSubmodules private;
7− };
8−in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))
dep/reflex-platform/github.jsondeleted−8
@@ -1,8 +0,0 @@
1−{
2− "owner": "reflex-frp",
3− "repo": "reflex-platform",
4− "branch": "master",
5− "private": false,
6− "rev": "c9d11db1b98855fe8ab24a3ff6a5dbe0ad902ad9",
7− "sha256": "0sfzkqdvyah5mwvmli0wq1nl0b8cvk2cmfgfy4rz57wv42x3099y"
8−}
patch.cabaldeleted−100
@@ -1,100 +0,0 @@
1−Name: patch
2−Version: 0.0.5.0
3−Synopsis: Data structures for describing changes to other data structures.
4−Description:
5− Data structures for describing changes to other data structures.
6− .
7− In this library, a patch is something which can be applied, analogous to a
8− function, and which distinguishes returning the argument it was provided from
9− returning something else.
10−License: BSD3
11−License-file: LICENSE
12−Author: Ryan Trinkle
13−Maintainer: maintainer@obsidian.systems
14−Stability: Experimental
15−Category: FRP
16−Build-type: Simple
17−Cabal-version: >=1.10
18−homepage: https://obsidian.systems
19−bug-reports: https://github.com/reflex-frp/patch/issues
20−extra-source-files:
21− README.md
22− ChangeLog.md
23−
24−tested-with:
25− GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.1
26− GHCJS ==8.4
27−
28−flag split-these
29− description: Use split these/semialign packages
30− manual: False
31− default: True
32−
33−library
34− hs-source-dirs: src
35− default-language: Haskell2010
36− build-depends: base >= 4.9 && < 4.15
37− , constraints-extras >= 0.3 && < 0.4
38− , containers >= 0.6 && < 0.7
39− , dependent-map >= 0.3 && < 0.5
40− , dependent-sum >= 0.6 && < 0.8
41− , lens >= 4.7 && < 5
42− , semigroupoids >= 4.0 && < 6
43− , transformers >= 0.5.6.0 && < 0.6
44− , witherable >= 0.3 && < 0.5
45−
46− if impl(ghc < 8.6) -- really, if base < 8.12
47− build-depends: base-orphans >= 0.8 && < 0.9
48−
49− exposed-modules: Data.Functor.Misc
50− , Data.Monoid.DecidablyEmpty
51− , Data.Patch
52− , Data.Patch.Class
53− , Data.Patch.DMap
54− , Data.Patch.DMapWithMove
55− , Data.Patch.IntMap
56− , Data.Patch.Map
57− , Data.Patch.MapWithMove
58− , Data.Patch.MapWithPatchingMove
59− , Data.Semigroup.Additive
60−
61− ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs
62− default-extensions: PolyKinds
63−
64− if flag(split-these)
65− build-depends: these >= 1 && <1.2
66− , semialign >=1 && <1.2
67− , monoidal-containers >= 0.6 && < 0.7
68− else
69− build-depends: these >= 0.4 && <0.9
70− , monoidal-containers == 0.4.0.0
71−
72−test-suite tests
73− default-language: Haskell2010
74− type: exitcode-stdio-1.0
75− main-is: tests.hs
76− hs-source-dirs: test
77− build-depends: base
78− , patch
79− , containers
80− , hedgehog
81− , HUnit
82− if impl(ghcjs)
83− buildable: False
84−
85−test-suite hlint
86− default-language: Haskell2010
87− type: exitcode-stdio-1.0
88− main-is: hlint.hs
89− hs-source-dirs: test
90− build-depends: base
91− , directory
92− , filepath
93− , filemanip
94− , hlint (< 2.1 || >= 2.2.2) && < 3.3
95− if impl(ghcjs)
96− buildable: False
97−
98−source-repository head
99− type: git
100− location: https://github.com/reflex-frp/patch
reflex.cabalnew file+295
@@ -0,0 +1,295 @@
1+Name: reflex
2+Version: 0.5
3+Synopsis: Higher-order Functional Reactive Programming
4+Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system
5+License: BSD3
6+License-file: LICENSE
7+Author: Ryan Trinkle
8+Maintainer: ryan.trinkle@gmail.com
9+Stability: Experimental
10+Category: FRP
11+Build-type: Simple
12+Cabal-version: >=1.9.2
13+homepage: https://github.com/reflex-frp/reflex
14+bug-reports: https://github.com/reflex-frp/reflex/issues
15+
16+flag use-reflex-optimizer
17+ description: Use the GHC plugin Reflex.Optimizer on some of the modules in the package. This is still experimental.
18+ default: False
19+ manual: True
20+
21+flag use-template-haskell
22+ description: Use template haskell to generate lenses
23+ default: True
24+ manual: True
25+
26+flag debug-trace-events
27+ description: Add instrumentation that outputs the stack trace of the definition of an event whenever it is subscribed to. Warning: It is very slow!
28+ default: False
29+ manual: True
30+
31+flag fast-weak
32+ 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
33+ default: False
34+ manual: True
35+
36+library
37+ hs-source-dirs: src
38+ build-depends:
39+ MemoTrie == 0.6.*,
40+ base >= 4.7 && < 4.12,
41+ bifunctors >= 5.2 && < 5.6,
42+ comonad,
43+ containers == 0.5.*,
44+ data-default >= 0.5 && < 0.8,
45+ dependent-map >= 0.2.4 && < 0.3,
46+ exception-transformers == 0.4.*,
47+ lens >= 4.7 && < 5,
48+ monad-control >= 1.0.1 && < 1.1,
49+ mtl >= 2.1 && < 2.3,
50+ prim-uniq >= 0.1.0.1 && < 0.2,
51+ primitive >= 0.5 && < 0.7,
52+ random == 1.1.*,
53+ ref-tf == 0.4.*,
54+ reflection == 2.1.*,
55+ semigroupoids >= 4.0 && < 6,
56+ semigroups >= 0.16 && < 0.19,
57+ stm == 2.4.*,
58+ syb >= 0.5 && < 0.8,
59+ these >= 0.4 && < 0.8,
60+ time >= 1.4 && < 1.9,
61+ transformers >= 0.2,
62+ transformers-compat >= 0.3,
63+ unbounded-delays >= 0.1.0.0 && < 0.2
64+
65+ exposed-modules:
66+ Data.AppendMap,
67+ Data.FastMutableIntMap,
68+ Data.FastWeakBag,
69+ Data.Functor.Misc,
70+ Data.Map.Misc,
71+ Data.WeakBag,
72+ Reflex,
73+ Reflex.Class,
74+ Reflex.Collection,
75+ Reflex.Dynamic,
76+ Reflex.Dynamic.Uniq,
77+ Reflex.DynamicWriter,
78+ Reflex.DynamicWriter.Base,
79+ Reflex.DynamicWriter.Class,
80+ Reflex.EventWriter,
81+ Reflex.EventWriter.Base,
82+ Reflex.EventWriter.Class,
83+ Reflex.FastWeak,
84+ Reflex.FunctorMaybe,
85+ Reflex.Host.Class,
86+ Reflex.Network,
87+ Reflex.NotReady.Class,
88+ Reflex.Patch,
89+ Reflex.Patch.Class,
90+ Reflex.Patch.DMap,
91+ Reflex.Patch.DMapWithMove,
92+ Reflex.Patch.IntMap,
93+ Reflex.Patch.Map,
94+ Reflex.Patch.MapWithMove,
95+ Reflex.PerformEvent.Base,
96+ Reflex.PerformEvent.Class,
97+ Reflex.PostBuild.Base,
98+ Reflex.PostBuild.Class,
99+ Reflex.Profiled,
100+ Reflex.Pure,
101+ Reflex.Query.Base,
102+ Reflex.Query.Class,
103+ Reflex.Requester.Base,
104+ Reflex.Requester.Class,
105+ Reflex.Spider,
106+ Reflex.Spider.Internal,
107+ Reflex.Time,
108+ Reflex.TriggerEvent.Base,
109+ Reflex.TriggerEvent.Class,
110+ Reflex.Widget.Basic,
111+ Reflex.Workflow
112+
113+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively -ddump-simpl -ddump-to-file -dsuppress-coercions -dsuppress-idinfo
114+ ghc-prof-options: -fprof-auto
115+
116+ if flag(debug-trace-events)
117+ cpp-options: -DDEBUG_TRACE_EVENTS
118+ build-depends: bytestring
119+
120+ if flag(use-reflex-optimizer)
121+ cpp-options: -DUSE_REFLEX_OPTIMIZER
122+ build-depends: ghc
123+ exposed-modules: Reflex.Optimizer
124+
125+ if flag(use-template-haskell)
126+ cpp-options: -DUSE_TEMPLATE_HASKELL
127+ build-depends:
128+ dependent-sum >= 0.3 && < 0.5,
129+ haskell-src-exts >= 1.16 && < 1.21,
130+ haskell-src-meta >= 0.6 && < 0.9,
131+ template-haskell >= 2.9 && < 2.14
132+ exposed-modules:
133+ Reflex.Dynamic.TH
134+ other-extensions: TemplateHaskell
135+ else
136+ build-depends:
137+ dependent-sum == 0.4.*
138+
139+ if flag(fast-weak) && impl(ghcjs)
140+ ghc-options: -DGHCJS_FAST_WEAK
141+
142+ if impl(ghcjs)
143+ build-depends: ghcjs-base
144+
145+test-suite semantics
146+ type: exitcode-stdio-1.0
147+ main-is: semantics.hs
148+ hs-source-dirs: test
149+ ghc-options: -O2 -Wall -rtsopts
150+ build-depends:
151+ base,
152+ bifunctors,
153+ containers,
154+ deepseq >= 1.3 && < 1.5,
155+ dependent-map,
156+ dependent-sum,
157+ mtl,
158+ ref-tf,
159+ reflex,
160+ split,
161+ transformers >= 0.3
162+
163+test-suite CrossImpl
164+ type: exitcode-stdio-1.0
165+ main-is: Reflex/Test/CrossImpl.hs
166+ hs-source-dirs: test
167+ ghc-options: -O2 -Wall -rtsopts -main-is Reflex.Test.CrossImpl.test
168+ build-depends:
169+ base,
170+ containers,
171+ dependent-map,
172+ mtl,
173+ ref-tf,
174+ reflex
175+
176+test-suite hlint
177+ type: exitcode-stdio-1.0
178+ main-is: hlint.hs
179+ hs-source-dirs: test
180+ build-depends: base
181+ , directory
182+ , filepath
183+ , filemanip
184+ , hlint
185+ if impl(ghcjs)
186+ buildable: False
187+
188+test-suite EventWriterT
189+ type: exitcode-stdio-1.0
190+ main-is: EventWriterT.hs
191+ hs-source-dirs: test
192+ build-depends: base
193+ , dependent-sum
194+ , lens
195+ , these
196+ , transformers
197+ , reflex
198+ , ref-tf
199+
200+test-suite RequesterT
201+ type: exitcode-stdio-1.0
202+ main-is: RequesterT.hs
203+ hs-source-dirs: test
204+ build-depends: base
205+ , dependent-sum
206+ , dependent-map
207+ , lens
208+ , these
209+ , transformers
210+ , reflex
211+ , ref-tf
212+ buildable: False
213+
214+test-suite QueryT
215+ type: exitcode-stdio-1.0
216+ main-is: QueryT.hs
217+ hs-source-dirs: test
218+ build-depends: base
219+ , containers
220+ , dependent-sum
221+ , dependent-map
222+ , lens
223+ , these
224+ , transformers
225+ , semigroups
226+ , reflex
227+ , ref-tf
228+ other-modules: Test.Run
229+
230+test-suite GC-Semantics
231+ type: exitcode-stdio-1.0
232+ main-is: GC.hs
233+ hs-source-dirs: test
234+ build-depends: base
235+ , dependent-sum
236+ , dependent-map
237+ , these
238+ , transformers
239+ , reflex
240+ , ref-tf
241+ if impl(ghc < 8)
242+ build-depends: semigroups
243+
244+test-suite rootCleanup
245+ type: exitcode-stdio-1.0
246+ main-is: rootCleanup.hs
247+ hs-source-dirs: test
248+ build-depends: base
249+ , reflex
250+
251+benchmark spider-bench
252+ type: exitcode-stdio-1.0
253+ hs-source-dirs: bench
254+ main-is: Main.hs
255+ ghc-options: -Wall -O2 -rtsopts
256+ build-depends:
257+ base,
258+ criterion == 1.1.*,
259+ deepseq >= 1.3 && < 1.5,
260+ dependent-map,
261+ dependent-sum,
262+ mtl,
263+ primitive,
264+ reflex,
265+ stm,
266+ transformers >= 0.3
267+
268+benchmark saulzar-bench
269+ type: exitcode-stdio-1.0
270+ hs-source-dirs: bench test
271+ c-sources: bench-cbits/checkCapability.c
272+ main-is: RunAll.hs
273+ ghc-options: -Wall -O2 -rtsopts -threaded
274+ ghc-prof-options: -fprof-auto
275+ build-depends:
276+ base,
277+ containers == 0.5.*,
278+ criterion == 1.1.*,
279+ deepseq >= 1.3 && < 1.5,
280+ dependent-map,
281+ dependent-sum,
282+ loch-th,
283+ mtl,
284+ primitive,
285+ process,
286+ ref-tf,
287+ reflex,
288+ split,
289+ stm,
290+ time,
291+ transformers >= 0.3
292+
293+source-repository head
294+ type: git
295+ location: https://github.com/reflex-frp/reflex
release.nixdeleted−49
@@ -1,49 +0,0 @@
1−{ reflex-platform-fun ? import ./dep/reflex-platform
2−}:
3−
4−let
5− native-reflex-platform = reflex-platform-fun {};
6− inherit (native-reflex-platform.nixpkgs) lib;
7− systems = ["x86_64-linux" "x86_64-darwin"];
8−
9− perPlatform = lib.genAttrs systems (system: let
10− reflex-platform = reflex-platform-fun { inherit system; };
11− compilers = [
12− "ghc"
13− "ghcjs"
14− ] ++ lib.optionals (reflex-platform.androidSupport) [
15− "ghcAndroidAarch64"
16− "ghcAndroidAarch32"
17− ] ++ lib.optionals (reflex-platform.iosSupport) [
18− "ghcIosAarch64"
19− ];
20− compilerPkgs = lib.genAttrs compilers (ghc: let
21− reflex-platform = reflex-platform-fun {
22− inherit system;
23− haskellOverlays = [
24− # Use this package's source for reflex
25− (self: super: {
26− _dep = super._dep // {
27− patch = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [
28− "release.nix"
29− ".git"
30− "dist"
31− "dist-newstyle"
32− "cabal.haskell-ci"
33− "cabal.project"
34− ".travis.yml"
35− ])) ./.;
36− };
37− })
38− ];
39− };
40− in reflex-platform.${ghc}.patch);
41− in compilerPkgs // {
42− cache = reflex-platform.pinBuildInputs "patch-${system}"
43− (builtins.attrValues compilerPkgs);
44− });
45−
46− metaCache = native-reflex-platform.pinBuildInputs "patch-everywhere"
47− (map (a: a.cache) (builtins.attrValues perPlatform));
48−
49−in perPlatform // { inherit metaCache; }
src/Data/AppendMap.hsnew file+408
@@ -0,0 +1,408 @@
1+{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE DeriveGeneric #-}
3+{-# LANGUAGE DeriveTraversable #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE RoleAnnotations #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TypeFamilies #-}
11+-- | 'Data.Map' with a better 'Monoid' instance
12+--
13+-- 'Data.Map' has @mappend = union@, which is left-biased. AppendMap has
14+-- @mappend = unionWith mappend@ instead.
15+module Data.AppendMap where
16+
17+import Prelude hiding (map)
18+
19+import Control.Lens
20+import Data.Align
21+import Data.Coerce
22+import Data.Default
23+import Data.Map (Map)
24+import qualified Data.Map as Map
25+import Data.Semigroup
26+import Data.Set (Set)
27+import Data.Typeable
28+import GHC.Generics (Generic)
29+import Reflex.Class (FunctorMaybe (..))
30+import Reflex.Patch (Additive, Group (..))
31+
32+newtype AppendMap k m = AppendMap { _unAppendMap :: Map k m }
33+ deriving (Eq, Ord, Show, Read, Typeable, Generic, Functor, Foldable, Traversable, Align)
34+
35+type instance (Index (AppendMap k m)) = k
36+type instance (IxValue (AppendMap k m)) = m
37+
38+instance Ord k => Ixed (AppendMap k m) where
39+ ix i = _Wrapped . ix i
40+
41+instance Ord k => At (AppendMap k m) where
42+ at i = _Wrapped . at i
43+
44+instance FunctorMaybe (AppendMap k) where
45+ fmapMaybe = mapMaybe
46+
47+-- | Deletes a key, returning 'Nothing' if the result is empty.
48+nonEmptyDelete :: Ord k => k -> AppendMap k a -> Maybe (AppendMap k a)
49+nonEmptyDelete k vs =
50+ let deleted = delete k vs
51+ in if Data.AppendMap.null deleted
52+ then Nothing
53+ else Just deleted
54+
55+mapMaybeNoNull :: (a -> Maybe b)
56+ -> AppendMap token a
57+ -> Maybe (AppendMap token b)
58+mapMaybeNoNull f as =
59+ let bs = fmapMaybe f as
60+ in if Data.AppendMap.null bs
61+ then Nothing
62+ else Just bs
63+
64+instance FunctorWithIndex k (AppendMap k) where
65+ imap f = AppendMap . imap f . _unAppendMap
66+ imapped = _Wrapped . imapped
67+
68+instance FoldableWithIndex k (AppendMap k) where
69+ ifolded = _Wrapped . ifolded
70+
71+instance TraversableWithIndex k (AppendMap k) where
72+ itraverse = itraverseOf itraversed
73+ itraversed = _Wrapped . itraversed
74+
75+instance (Ord k, Semigroup m) => Semigroup (AppendMap k m) where
76+ (AppendMap m0) <> (AppendMap m1) = AppendMap $ Map.unionWith (<>) m0 m1
77+
78+instance (Ord k, Semigroup m) => Monoid (AppendMap k m) where
79+ mempty = empty
80+ mappend = (<>)
81+
82+instance (Ord k, Group q) => Group (AppendMap k q) where
83+ negateG = map negateG
84+
85+instance (Ord k, Additive q) => Additive (AppendMap k q)
86+
87+(!) :: forall k a. Ord k => AppendMap k a -> k -> a
88+(!) = coerce ((Map.!) :: Map k a -> k -> a)
89+infixl 9 !
90+
91+(\\) :: forall k a b. Ord k => AppendMap k a -> AppendMap k b -> AppendMap k a
92+(\\) = coerce ((Map.\\) :: Map k a -> Map k b -> Map k a)
93+infixl 9 \\
94+
95+null :: forall k a. AppendMap k a -> Bool
96+null = coerce (Map.null :: Map k a -> Bool)
97+
98+size :: forall k a. AppendMap k a -> Int
99+size = coerce (Map.size :: Map k a -> Int)
100+
101+member :: forall k a. Ord k => k -> AppendMap k a -> Bool
102+member = coerce (Map.member :: k -> Map k a -> Bool)
103+
104+notMember :: forall k a. Ord k => k -> AppendMap k a -> Bool
105+notMember = coerce (Map.notMember :: k -> Map k a -> Bool)
106+
107+lookup :: forall k a. Ord k => k -> AppendMap k a -> Maybe a
108+lookup = coerce (Map.lookup :: k -> Map k a -> Maybe a)
109+
110+findWithDefault :: forall k a. Ord k => a -> k -> AppendMap k a -> a
111+findWithDefault = coerce (Map.findWithDefault :: a -> k -> Map k a -> a)
112+
113+lookupLT :: forall k a. Ord k => k -> AppendMap k a -> Maybe (k, a)
114+lookupLT = coerce (Map.lookupLT :: k -> Map k a -> Maybe (k,a))
115+
116+lookupGT :: forall k a. Ord k => k -> AppendMap k a -> Maybe (k, a)
117+lookupGT = coerce (Map.lookupGT :: k -> Map k a -> Maybe (k,a))
118+
119+lookupLE :: forall k a. Ord k => k -> AppendMap k a -> Maybe (k, a)
120+lookupLE = coerce (Map.lookupLE :: k -> Map k a -> Maybe (k,a))
121+
122+lookupGE :: forall k a. Ord k => k -> AppendMap k a -> Maybe (k, a)
123+lookupGE = coerce (Map.lookupGE :: k -> Map k a -> Maybe (k,a))
124+
125+empty :: forall k a. AppendMap k a
126+empty = coerce (Map.empty :: Map k a)
127+
128+singleton :: forall k a. k -> a -> AppendMap k a
129+singleton = coerce (Map.singleton :: k -> a -> Map k a)
130+
131+insert :: forall k a. Ord k => k -> a -> AppendMap k a -> AppendMap k a
132+insert = coerce (Map.insert :: k -> a -> Map k a -> Map k a)
133+
134+insertWith :: forall k a. Ord k => (a -> a -> a) -> k -> a -> AppendMap k a -> AppendMap k a
135+insertWith = coerce (Map.insertWith :: (a -> a -> a) -> k -> a -> Map k a -> Map k a)
136+
137+insertWithKey :: forall k a. Ord k => (k -> a -> a -> a) -> k -> a -> AppendMap k a -> AppendMap k a
138+insertWithKey = coerce (Map.insertWithKey :: (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a)
139+
140+insertLookupWithKey :: forall k a. Ord k => (k -> a -> a -> a) -> k -> a -> AppendMap k a -> (Maybe a, AppendMap k a)
141+insertLookupWithKey = coerce (Map.insertLookupWithKey :: (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a))
142+
143+delete :: forall k a. Ord k => k -> AppendMap k a -> AppendMap k a
144+delete = coerce (Map.delete :: k -> Map k a -> Map k a)
145+
146+adjust :: forall k a. Ord k => (a -> a) -> k -> AppendMap k a -> AppendMap k a
147+adjust = coerce (Map.adjust :: (a -> a) -> k -> Map k a -> Map k a)
148+
149+adjustWithKey :: forall k a. Ord k => (k -> a -> a) -> k -> AppendMap k a -> AppendMap k a
150+adjustWithKey = coerce (Map.adjustWithKey :: (k -> a -> a) -> k -> Map k a -> Map k a)
151+
152+update :: forall k a. Ord k => (a -> Maybe a) -> k -> AppendMap k a -> AppendMap k a
153+update = coerce (Map.update :: (a -> Maybe a) -> k -> Map k a -> Map k a)
154+
155+updateWithKey :: forall k a. Ord k => (k -> a -> Maybe a) -> k -> AppendMap k a -> AppendMap k a
156+updateWithKey = coerce (Map.updateWithKey :: (k -> a -> Maybe a) -> k -> Map k a -> Map k a)
157+
158+updateLookupWithKey :: forall k a. Ord k => (k -> a -> Maybe a) -> k -> AppendMap k a -> (Maybe a, AppendMap k a)
159+updateLookupWithKey = coerce (Map.updateLookupWithKey :: (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a))
160+
161+alter :: forall k a. Ord k => (Maybe a -> Maybe a) -> k -> AppendMap k a -> AppendMap k a
162+alter = coerce (Map.alter :: (Maybe a -> Maybe a) -> k -> Map k a -> Map k a)
163+
164+unionWith :: forall k a. Ord k => (a -> a -> a) -> AppendMap k a -> AppendMap k a -> AppendMap k a
165+unionWith = coerce (Map.unionWith :: (a -> a -> a) -> Map k a -> Map k a -> Map k a)
166+
167+unionWithKey :: forall k a. Ord k => (k -> a -> a -> a) -> AppendMap k a -> AppendMap k a -> AppendMap k a
168+unionWithKey = coerce (Map.unionWithKey :: (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a)
169+
170+unionsWith :: forall k a. Ord k => (a -> a -> a) -> [AppendMap k a] -> AppendMap k a
171+unionsWith = coerce (Map.unionsWith :: (a -> a -> a) -> [Map k a] -> Map k a)
172+
173+difference :: forall k a b. Ord k => AppendMap k a -> AppendMap k b -> AppendMap k a
174+difference = (\\)
175+
176+differenceWith :: forall k a b. Ord k => (a -> b -> Maybe a) -> AppendMap k a -> AppendMap k b -> AppendMap k a
177+differenceWith = coerce (Map.differenceWith :: (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a)
178+
179+differenceWithKey :: forall k a b. Ord k => (k -> a -> b -> Maybe a) -> AppendMap k a -> AppendMap k b -> AppendMap k a
180+differenceWithKey = coerce (Map.differenceWithKey :: (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a)
181+
182+intersectionWith :: forall k a b c. Ord k => (a -> b -> c) -> AppendMap k a -> AppendMap k b -> AppendMap k c
183+intersectionWith = coerce (Map.intersectionWith :: (a -> b -> c) -> Map k a -> Map k b -> Map k c)
184+
185+intersectionWithKey :: forall k a b c. Ord k => (k -> a -> b -> c) -> AppendMap k a -> AppendMap k b -> AppendMap k c
186+intersectionWithKey = coerce (Map.intersectionWithKey :: (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c)
187+
188+mergeWithKey :: forall k a b c. 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
189+mergeWithKey = coerce (Map.mergeWithKey :: (k -> a -> b -> Maybe c) -> (Map k a -> Map k c) -> (Map k b -> Map k c) -> Map k a -> Map k b -> Map k c)
190+
191+map :: (a -> b) -> AppendMap k a -> AppendMap k b
192+map = fmap
193+
194+mapWithKey :: (k -> a -> b) -> AppendMap k a -> AppendMap k b
195+mapWithKey = imap
196+
197+traverseWithKey :: Applicative t => (k -> a -> t b) -> AppendMap k a -> t (AppendMap k b)
198+traverseWithKey = itraverse
199+
200+mapAccum :: forall k a b c. (a -> b -> (a, c)) -> a -> AppendMap k b -> (a, AppendMap k c)
201+mapAccum = coerce (Map.mapAccum :: (a -> b -> (a, c)) -> a -> Map k b -> (a, Map k c))
202+
203+mapAccumWithKey :: forall k a b c. (a -> k -> b -> (a, c)) -> a -> AppendMap k b -> (a, AppendMap k c)
204+mapAccumWithKey = coerce (Map.mapAccumWithKey :: (a -> k -> b -> (a, c)) -> a -> Map k b -> (a, Map k c))
205+
206+mapAccumRWithKey :: forall k a b c. (a -> k -> b -> (a, c)) -> a -> AppendMap k b -> (a, AppendMap k c)
207+mapAccumRWithKey = coerce (Map.mapAccumRWithKey :: (a -> k -> b -> (a, c)) -> a -> Map k b -> (a, Map k c))
208+
209+mapKeys :: forall k1 k2 a. Ord k2 => (k1 -> k2) -> AppendMap k1 a -> AppendMap k2 a
210+mapKeys = coerce (Map.mapKeys :: (k1 -> k2) -> Map k1 a -> Map k2 a)
211+
212+mapKeysWith :: forall k1 k2 a. Ord k2 => (a -> a -> a) -> (k1 -> k2) -> AppendMap k1 a -> AppendMap k2 a
213+mapKeysWith = coerce (Map.mapKeysWith :: (a -> a -> a) -> (k1 -> k2) -> Map k1 a -> Map k2 a)
214+
215+mapKeysMonotonic :: forall k1 k2 a. (k1 -> k2) -> AppendMap k1 a -> AppendMap k2 a
216+mapKeysMonotonic = coerce (Map.mapKeysMonotonic :: (k1 -> k2) -> Map k1 a -> Map k2 a)
217+
218+foldr :: forall k a b. (a -> b -> b) -> b -> AppendMap k a -> b
219+foldr = coerce (Map.foldr :: (a -> b -> b) -> b -> Map k a -> b)
220+
221+foldl :: forall k a b. (a -> b -> a) -> a -> AppendMap k b -> a
222+foldl = coerce (Map.foldl :: (a -> b -> a) -> a -> Map k b -> a)
223+
224+foldrWithKey :: forall k a b. (k -> a -> b -> b) -> b -> AppendMap k a -> b
225+foldrWithKey = coerce (Map.foldrWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b)
226+
227+foldlWithKey :: forall k a b. (a -> k -> b -> a) -> a -> AppendMap k b -> a
228+foldlWithKey = coerce (Map.foldlWithKey :: (a -> k -> b -> a) -> a -> Map k b -> a)
229+
230+foldMapWithKey :: forall k a m. Monoid m => (k -> a -> m) -> AppendMap k a -> m
231+foldMapWithKey = coerce (Map.foldMapWithKey :: Monoid m => (k -> a -> m) -> Map k a -> m)
232+
233+foldr' :: forall k a b. (a -> b -> b) -> b -> AppendMap k a -> b
234+foldr' = coerce (Map.foldr' :: (a -> b -> b) -> b -> Map k a -> b)
235+
236+foldl' :: forall k a b. (a -> b -> a) -> a -> AppendMap k b -> a
237+foldl' = coerce (Map.foldl' :: (a -> b -> a) -> a -> Map k b -> a)
238+
239+foldrWithKey' :: forall k a b. (k -> a -> b -> b) -> b -> AppendMap k a -> b
240+foldrWithKey' = coerce (Map.foldrWithKey' :: (k -> a -> b -> b) -> b -> Map k a -> b)
241+
242+foldlWithKey' :: forall k a b. (a -> k -> b -> a) -> a -> AppendMap k b -> a
243+foldlWithKey' = coerce (Map.foldlWithKey' :: (a -> k -> b -> a) -> a -> Map k b -> a)
244+
245+elems :: forall k a. AppendMap k a -> [a]
246+elems = coerce (Map.elems :: Map k a -> [a])
247+
248+keys :: forall k a. AppendMap k a -> [k]
249+keys = coerce (Map.keys :: Map k a -> [k])
250+
251+assocs :: forall k a. AppendMap k a -> [(k, a)]
252+assocs = coerce (Map.assocs :: Map k a -> [(k, a)])
253+
254+keysSet :: forall k a. AppendMap k a -> Set k
255+keysSet = coerce (Map.keysSet :: Map k a -> Set k)
256+
257+fromSet :: forall k a. (k -> a) -> Set k -> AppendMap k a
258+fromSet = coerce (Map.fromSet :: (k -> a) -> Set k -> Map k a)
259+
260+toList :: forall k a. AppendMap k a -> [(k, a)]
261+toList = coerce (Map.toList :: Map k a -> [(k, a)])
262+
263+fromList :: forall k a. Ord k => [(k, a)] -> AppendMap k a
264+fromList = coerce (Map.fromList :: [(k, a)] -> Map k a)
265+
266+fromListWith :: forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> AppendMap k a
267+fromListWith = coerce (Map.fromListWith :: (a -> a -> a) -> [(k, a)] -> Map k a)
268+
269+fromListWithKey :: forall k a. Ord k => (k -> a -> a -> a) -> [(k, a)] -> AppendMap k a
270+fromListWithKey = coerce (Map.fromListWithKey :: (k -> a -> a -> a) -> [(k, a)] -> Map k a)
271+
272+toAscList :: forall k a. AppendMap k a -> [(k, a)]
273+toAscList = coerce (Map.toAscList :: Map k a -> [(k, a)])
274+
275+toDescList :: forall k a. AppendMap k a -> [(k, a)]
276+toDescList = coerce (Map.toDescList :: Map k a -> [(k, a)])
277+
278+fromAscList :: forall k a. Eq k => [(k, a)] -> AppendMap k a
279+fromAscList = coerce (Map.fromAscList :: [(k, a)] -> Map k a)
280+
281+fromAscListWith :: forall k a. Eq k => (a -> a -> a) -> [(k, a)] -> AppendMap k a
282+fromAscListWith = coerce (Map.fromAscListWith :: (a -> a -> a) -> [(k, a)] -> Map k a)
283+
284+fromAscListWithKey :: forall k a. Eq k => (k -> a -> a -> a) -> [(k, a)] -> AppendMap k a
285+fromAscListWithKey = coerce (Map.fromAscListWithKey :: (k -> a -> a -> a) -> [(k, a)] -> Map k a)
286+
287+fromDistinctAscList :: forall k a. [(k, a)] -> AppendMap k a
288+fromDistinctAscList = coerce (Map.fromDistinctAscList :: [(k, a)] -> Map k a)
289+
290+filter :: forall k a. (a -> Bool) -> AppendMap k a -> AppendMap k a
291+filter = coerce (Map.filter :: (a -> Bool) -> Map k a -> Map k a)
292+
293+filterWithKey :: forall k a. (k -> a -> Bool) -> AppendMap k a -> AppendMap k a
294+filterWithKey = coerce (Map.filterWithKey :: (k -> a -> Bool) -> Map k a -> Map k a)
295+
296+partition :: forall k a. (a -> Bool) -> AppendMap k a -> (AppendMap k a, AppendMap k a)
297+partition = coerce (Map.partition :: (a -> Bool) -> Map k a -> (Map k a, Map k a))
298+
299+partitionWithKey :: forall k a. (k -> a -> Bool) -> AppendMap k a -> (AppendMap k a, AppendMap k a)
300+partitionWithKey = coerce (Map.partitionWithKey :: (k -> a -> Bool) -> Map k a -> (Map k a, Map k a))
301+
302+mapMaybe :: forall k a b. (a -> Maybe b) -> AppendMap k a -> AppendMap k b
303+mapMaybe = coerce (Map.mapMaybe :: (a -> Maybe b) -> Map k a -> Map k b)
304+
305+mapMaybeWithKey :: forall k a b. (k -> a -> Maybe b) -> AppendMap k a -> AppendMap k b
306+mapMaybeWithKey = coerce (Map.mapMaybeWithKey :: (k -> a -> Maybe b) -> Map k a -> Map k b)
307+
308+mapEither :: forall k a b c. (a -> Either b c) -> AppendMap k a -> (AppendMap k b, AppendMap k c)
309+mapEither = coerce (Map.mapEither :: (a -> Either b c) -> Map k a -> (Map k b, Map k c))
310+
311+mapEitherWithKey :: forall k a b c. (k -> a -> Either b c) -> AppendMap k a -> (AppendMap k b, AppendMap k c)
312+mapEitherWithKey = coerce (Map.mapEitherWithKey :: (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c))
313+
314+split :: forall k a. Ord k => k -> AppendMap k a -> (AppendMap k a, AppendMap k a)
315+split = coerce (Map.split :: k -> Map k a -> (Map k a, Map k a))
316+
317+splitLookup :: forall k a. Ord k => k -> AppendMap k a -> (AppendMap k a, Maybe a, AppendMap k a)
318+splitLookup = coerce (Map.splitLookup :: k -> Map k a -> (Map k a, Maybe a, Map k a))
319+
320+splitRoot :: forall k a. AppendMap k a -> [AppendMap k a]
321+splitRoot = coerce (Map.splitRoot :: Map k a -> [Map k a])
322+
323+isSubmapOf :: forall k a. (Ord k, Eq a) => AppendMap k a -> AppendMap k a -> Bool
324+isSubmapOf = coerce (Map.isSubmapOf :: Map k a -> Map k a -> Bool)
325+
326+isSubmapOfBy :: forall k a b. Ord k => (a -> b -> Bool) -> AppendMap k a -> AppendMap k b -> Bool
327+isSubmapOfBy = coerce (Map.isSubmapOfBy :: (a -> b -> Bool) -> Map k a -> Map k b -> Bool)
328+
329+isProperSubmapOf :: forall k a. (Ord k, Eq a) => AppendMap k a -> AppendMap k a -> Bool
330+isProperSubmapOf = coerce (Map.isProperSubmapOf :: Map k a -> Map k a -> Bool)
331+
332+isProperSubmapOfBy :: forall k a b. Ord k => (a -> b -> Bool) -> AppendMap k a -> AppendMap k b -> Bool
333+isProperSubmapOfBy = coerce (Map.isProperSubmapOfBy :: (a -> b -> Bool) -> Map k a -> Map k b -> Bool)
334+
335+lookupIndex :: forall k a. Ord k => k -> AppendMap k a -> Maybe Int
336+lookupIndex = coerce (Map.lookupIndex :: k -> Map k a -> Maybe Int)
337+
338+findIndex :: forall k a. Ord k => k -> AppendMap k a -> Int
339+findIndex = coerce (Map.findIndex :: k -> Map k a -> Int)
340+
341+elemAt :: forall k a. Int -> AppendMap k a -> (k, a)
342+elemAt = coerce (Map.elemAt :: Int -> Map k a -> (k, a))
343+
344+updateAt :: forall k a. (k -> a -> Maybe a) -> Int -> AppendMap k a -> AppendMap k a
345+updateAt = coerce (Map.updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a)
346+
347+deleteAt :: forall k a. Int -> AppendMap k a -> AppendMap k a
348+deleteAt = coerce (Map.deleteAt :: Int -> Map k a -> Map k a)
349+
350+findMin :: forall k a. AppendMap k a -> (k, a)
351+findMin = coerce (Map.findMin :: Map k a -> (k, a))
352+
353+findMax :: forall k a. AppendMap k a -> (k, a)
354+findMax = coerce (Map.findMax :: Map k a -> (k, a))
355+
356+deleteMin :: forall k a. AppendMap k a -> AppendMap k a
357+deleteMin = coerce (Map.deleteMin :: Map k a -> Map k a)
358+
359+deleteMax :: forall k a. AppendMap k a -> AppendMap k a
360+deleteMax = coerce (Map.deleteMax :: Map k a -> Map k a)
361+
362+deleteFindMin :: forall k a. AppendMap k a -> ((k, a), AppendMap k a)
363+deleteFindMin = coerce (Map.deleteFindMin :: Map k a -> ((k, a), Map k a))
364+
365+deleteFindMax :: forall k a. AppendMap k a -> ((k, a), AppendMap k a)
366+deleteFindMax = coerce (Map.deleteFindMax :: Map k a -> ((k, a), Map k a))
367+
368+updateMin :: forall k a. (a -> Maybe a) -> AppendMap k a -> AppendMap k a
369+updateMin = coerce (Map.updateMin :: (a -> Maybe a) -> Map k a -> Map k a)
370+
371+updateMax :: forall k a. (a -> Maybe a) -> AppendMap k a -> AppendMap k a
372+updateMax = coerce (Map.updateMax :: (a -> Maybe a) -> Map k a -> Map k a)
373+
374+updateMinWithKey :: forall k a. (k -> a -> Maybe a) -> AppendMap k a -> AppendMap k a
375+updateMinWithKey = coerce (Map.updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a)
376+
377+updateMaxWithKey :: forall k a. (k -> a -> Maybe a) -> AppendMap k a -> AppendMap k a
378+updateMaxWithKey = coerce (Map.updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a)
379+
380+minView :: forall k a. AppendMap k a -> Maybe (a, AppendMap k a)
381+minView = coerce (Map.minView :: Map k a -> Maybe (a, Map k a))
382+
383+maxView :: forall k a. AppendMap k a -> Maybe (a, AppendMap k a)
384+maxView = coerce (Map.maxView :: Map k a -> Maybe (a, Map k a))
385+
386+minViewWithKey :: forall k a. AppendMap k a -> Maybe ((k, a), AppendMap k a)
387+minViewWithKey = coerce (Map.minViewWithKey :: Map k a -> Maybe ((k, a), Map k a))
388+
389+maxViewWithKey :: forall k a. AppendMap k a -> Maybe ((k, a), AppendMap k a)
390+maxViewWithKey = coerce (Map.maxViewWithKey :: Map k a -> Maybe ((k, a), Map k a))
391+
392+showTree :: forall k a. (Show k, Show a) => AppendMap k a -> String
393+showTree = coerce (Map.showTree :: (Show k, Show a) => Map k a -> String)
394+
395+showTreeWith :: forall k a. (k -> a -> String) -> Bool -> Bool -> AppendMap k a -> String
396+showTreeWith = coerce (Map.showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String)
397+
398+valid :: forall k a. Ord k => AppendMap k a -> Bool
399+valid = coerce (Map.valid :: Ord k => Map k a -> Bool)
400+
401+instance Default (AppendMap k a) where
402+ def = empty
403+
404+instance AppendMap k' v' ~ t => Rewrapped (AppendMap k a) t
405+
406+instance Wrapped (AppendMap k a) where
407+ type Unwrapped (AppendMap k a) = Map k a
408+ _Wrapped' = iso (\(AppendMap m) -> m) AppendMap
src/Data/FastMutableIntMap.hsnew file+76
@@ -0,0 +1,76 @@
1+{-# LANGUAGE TypeFamilies #-}
2+module Data.FastMutableIntMap
3+ ( FastMutableIntMap
4+ , new
5+ , newEmpty
6+ , insert
7+ , isEmpty
8+ , getFrozenAndClear
9+ , size
10+ , applyPatch
11+ , PatchIntMap (..)
12+ , traverseIntMapPatchWithKey
13+ , lookup
14+ , forIntersectionWithImmutable_
15+ , for_
16+ , patchIntMapNewElements
17+ , patchIntMapNewElementsMap
18+ , getDeletions
19+ ) where
20+
21+--TODO: Pure JS version
22+--TODO: Fast copy to FastIntMap
23+--TODO: Fast patch type
24+
25+import Control.Monad.IO.Class
26+import Data.Foldable (traverse_)
27+import Data.IntMap.Strict (IntMap)
28+import qualified Data.IntMap.Strict as IntMap
29+import Data.IORef
30+import Data.Maybe
31+import Prelude hiding (lookup)
32+import Reflex.Patch.Class
33+import Reflex.Patch.IntMap
34+
35+newtype FastMutableIntMap a = FastMutableIntMap (IORef (IntMap a))
36+
37+new :: IntMap a -> IO (FastMutableIntMap a)
38+new m = FastMutableIntMap <$> newIORef m
39+
40+newEmpty :: IO (FastMutableIntMap a)
41+newEmpty = FastMutableIntMap <$> newIORef IntMap.empty
42+
43+insert :: FastMutableIntMap a -> Int -> a -> IO ()
44+insert (FastMutableIntMap r) k v = modifyIORef' r $ IntMap.insert k v
45+
46+lookup :: FastMutableIntMap a -> Int -> IO (Maybe a)
47+lookup (FastMutableIntMap r) k = IntMap.lookup k <$> readIORef r
48+
49+forIntersectionWithImmutable_ :: MonadIO m => FastMutableIntMap a -> IntMap b -> (a -> b -> m ()) -> m ()
50+forIntersectionWithImmutable_ (FastMutableIntMap r) b f = do
51+ a <- liftIO $ readIORef r
52+ traverse_ (uncurry f) $ IntMap.intersectionWith (,) a b
53+
54+for_ :: MonadIO m => FastMutableIntMap a -> (a -> m ()) -> m ()
55+for_ (FastMutableIntMap r) f = do
56+ a <- liftIO $ readIORef r
57+ traverse_ f a
58+
59+isEmpty :: FastMutableIntMap a -> IO Bool
60+isEmpty (FastMutableIntMap r) = IntMap.null <$> readIORef r
61+
62+size :: FastMutableIntMap a -> IO Int
63+size (FastMutableIntMap r) = IntMap.size <$> readIORef r
64+
65+-- | Make an immutable snapshot of the datastructure and clear it
66+getFrozenAndClear :: FastMutableIntMap a -> IO (IntMap a)
67+getFrozenAndClear (FastMutableIntMap r) = do
68+ result <- readIORef r
69+ writeIORef r IntMap.empty
70+ return result
71+
72+applyPatch :: FastMutableIntMap a -> PatchIntMap a -> IO (IntMap a)
73+applyPatch (FastMutableIntMap r) p@(PatchIntMap m) = do
74+ v <- readIORef r
75+ writeIORef r $! applyAlways p v
76+ return $ IntMap.intersection v m
src/Data/FastWeakBag.hsnew file+157
@@ -0,0 +1,157 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ExistentialQuantification #-}
3+#ifdef USE_REFLEX_OPTIMIZER
4+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
5+#endif
6+#ifdef GHCJS_FAST_WEAK
7+{-# LANGUAGE ForeignFunctionInterface #-}
8+{-# LANGUAGE JavaScriptFFI #-}
9+#endif
10+-- | This module defines the 'FastWeakBag' type, which represents a mutable
11+-- collection of items that does not cause the items to be retained in memory.
12+-- This is useful for situations where a value needs to be inspected or modified
13+-- if it is still alive, but can be ignored if it is dead.
14+module Data.FastWeakBag
15+ ( FastWeakBag
16+ , FastWeakBagTicket
17+ , empty
18+ , isEmpty
19+ , insert
20+ , traverse
21+ , remove
22+ -- * Internal functions
23+ -- These will not always be available.
24+#ifndef GHCJS_FAST_WEAK
25+ , _weakBag_children --TODO: Don't export this
26+#endif
27+ ) where
28+
29+import Control.Monad hiding (forM_, mapM_)
30+import Control.Monad.IO.Class
31+
32+#ifdef GHCJS_FAST_WEAK
33+import GHCJS.Types
34+import Reflex.FastWeak (js_isNull, unsafeFromRawJSVal, unsafeToRawJSVal)
35+#else
36+import Control.Exception
37+import Data.Foldable (forM_, mapM_)
38+import Data.IntMap.Strict (IntMap)
39+import qualified Data.IntMap.Strict as IntMap
40+import Data.IORef
41+import System.Mem.Weak
42+#endif
43+
44+import Prelude hiding (mapM_, traverse)
45+
46+-- | 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@s remain
48+-- alive, the 'FastWeakBag' will continue to refer to them.
49+#ifdef GHCJS_FAST_WEAK
50+newtype FastWeakBag a = FastWeakBag JSVal
51+#else
52+data FastWeakBag a = FastWeakBag
53+ { _weakBag_nextId :: {-# UNPACK #-} !(IORef Int) --TODO: what if this wraps around?
54+ , _weakBag_children :: {-# UNPACK #-} !(IORef (IntMap (Weak a)))
55+ }
56+#endif
57+
58+-- | When inserting an item into a 'FastWeakBag', a 'FastWeakBagTicket' is returned. If
59+-- the caller retains the ticket, the item is guranteed to stay in memory (and
60+-- thus in the 'FastWeakBag'). The ticket can also be used to remove the item from
61+-- the 'FastWeakBag' prematurely (i.e. while it is still alive), using 'remove'.
62+#ifdef GHCJS_FAST_WEAK
63+newtype FastWeakBagTicket a = FastWeakBagTicket JSVal
64+#else
65+data FastWeakBagTicket a = FastWeakBagTicket
66+ { _weakBagTicket_weakItem :: {-# UNPACK #-} !(Weak a)
67+ , _weakBagTicket_item :: {-# NOUNPACK #-} !a
68+ }
69+#endif
70+
71+-- | Insert an item into a 'FastWeakBag'.
72+{-# INLINE insert #-}
73+insert :: a -- ^ The item
74+ -> FastWeakBag a -- ^ The 'FastWeakBag' to insert into
75+ -> IO (FastWeakBagTicket a) -- ^ Returns a 'FastWeakBagTicket' that ensures the item
76+ -- is retained and allows the item to be removed.
77+#ifdef GHCJS_FAST_WEAK
78+insert a wb = js_insert (unsafeToRawJSVal a) wb
79+foreign import javascript unsafe "$r = new h$FastWeakBagTicket($2, $1);" js_insert :: JSVal -> FastWeakBag a -> IO (FastWeakBagTicket a)
80+#else
81+insert a (FastWeakBag nextId children) = {-# SCC "insert" #-} do
82+ a' <- evaluate a
83+ myId <- atomicModifyIORef' nextId $ \n -> (succ n, n)
84+ let cleanup = atomicModifyIORef' children $ \cs -> (IntMap.delete myId cs, ())
85+ wa <- mkWeakPtr a' $ Just cleanup
86+ atomicModifyIORef' children $ \cs -> (IntMap.insert myId wa cs, ())
87+ return $ FastWeakBagTicket
88+ { _weakBagTicket_weakItem = wa
89+ , _weakBagTicket_item = a'
90+ }
91+#endif
92+
93+-- | Create an empty 'FastWeakBag'.
94+{-# INLINE empty #-}
95+empty :: IO (FastWeakBag a)
96+#ifdef GHCJS_FAST_WEAK
97+empty = js_empty
98+foreign import javascript unsafe "$r = new h$FastWeakBag();" js_empty :: IO (FastWeakBag a)
99+#else
100+empty = {-# SCC "empty" #-} do
101+ nextId <- newIORef 1
102+ children <- newIORef IntMap.empty
103+ let bag = FastWeakBag
104+ { _weakBag_nextId = nextId
105+ , _weakBag_children = children
106+ }
107+ return bag
108+#endif
109+
110+-- | Check whether a 'FastWeakBag' is empty.
111+{-# INLINE isEmpty #-}
112+isEmpty :: FastWeakBag a -> IO Bool
113+#ifdef GHCJS_FAST_WEAK
114+isEmpty = js_isEmpty
115+foreign import javascript unsafe "(function(){ for(var i = 0; i < $1.tickets.length; i++) { if($1.tickets[i] !== null) { return false; } }; return true; })()" js_isEmpty :: FastWeakBag a -> IO Bool --TODO: Clean up as we go along so this isn't O(n) every time
116+#else
117+isEmpty bag = {-# SCC "isEmpty" #-} IntMap.null <$> readIORef (_weakBag_children bag)
118+#endif
119+
120+{-# INLINE traverse #-}
121+-- | Visit every node in the given list. If new nodes are appended during the
122+-- traversal, they will not be visited. Every live node that was in the list
123+-- when the traversal began will be visited exactly once; however, no guarantee
124+-- is made about the order of the traversal.
125+traverse :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m ()
126+#ifdef GHCJS_FAST_WEAK
127+traverse wb f = do
128+ let go cursor = when (not $ js_isNull cursor) $ do
129+ val <- liftIO $ js_getTicketValue cursor
130+ f $ unsafeFromRawJSVal val
131+ go =<< liftIO (js_getNext (FastWeakBagTicket cursor))
132+ go =<< liftIO (js_getInitial wb)
133+foreign import javascript unsafe "(function(){ for(var i = $1.tickets.length - 1; i >= 0; i--) { if($1.tickets[i] !== null) { return $1.tickets[i]; } }; return null; })()" js_getInitial :: FastWeakBag a -> IO JSVal --TODO: Clean up as we go along so this isn't O(n) every time -- Result can be null or a FastWeakBagTicket a
134+foreign import javascript unsafe "$r = $1.val;" js_getTicketValue :: JSVal -> IO JSVal
135+--TODO: Fix the race condition where if a cursor is deleted (presumably using 'remove', below) while we're holding it, it can't find its way back to the correct bag
136+foreign import javascript unsafe "(function(){ for(var i = $1.pos - 1; i >= 0; i--) { if($1.bag.tickets[i] !== null) { return $1.bag.tickets[i]; } }; return null; })()" js_getNext :: FastWeakBagTicket a -> IO JSVal --TODO: Clean up as we go along so this isn't O(n) every time -- Result can be null or a FastWeakBagTicket a
137+#else
138+traverse (FastWeakBag _ children) f = {-# SCC "traverse" #-} do
139+ cs <- liftIO $ readIORef children
140+ forM_ cs $ \c -> do
141+ ma <- liftIO $ deRefWeak c
142+ mapM_ f ma
143+#endif
144+
145+-- | Remove an item from the 'FastWeakBag'; does nothing if invoked multiple times
146+-- on the same 'FastWeakBagTicket'.
147+{-# INLINE remove #-}
148+remove :: FastWeakBagTicket a -> IO ()
149+#ifdef GHCJS_FAST_WEAK
150+remove = js_remove
151+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
152+#else
153+remove (FastWeakBagTicket w _) = {-# SCC "remove" #-} finalize w
154+#endif
155+--TODO: Should 'remove' also drop the reference to the item?
156+
157+--TODO: can/should we provide a null FastWeakBagTicket?
src/Data/Functor/Misc.hs+61−5
@@ -4,12 +4,17 @@
4{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE GADTs #-}
6{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE KindSignatures #-}
7{-# LANGUAGE LambdaCase #-}
8{-# LANGUAGE LambdaCase #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
9{-# LANGUAGE MultiParamTypeClasses #-}
10+{-# LANGUAGE PatternSynonyms #-}
9{-# LANGUAGE PolyKinds #-}
11{-# LANGUAGE PolyKinds #-}
10{-# LANGUAGE RankNTypes #-}
12{-# LANGUAGE RankNTypes #-}
11{-# LANGUAGE ScopedTypeVariables #-}
13{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE StandaloneDeriving #-}
14{-# LANGUAGE StandaloneDeriving #-}
15+#ifdef USE_REFLEX_OPTIMIZER
16+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
17+#endif
13-- | This module provides types and functions with no particular theme, but
18-- | This module provides types and functions with no particular theme, but
14-- which are relevant to the use of 'Functor'-based datastructures like
19-- which are relevant to the use of 'Functor'-based datastructures like
15-- 'Data.Dependent.Map.DMap'.
20-- 'Data.Dependent.Map.DMap'.
@@ -33,23 +38,30 @@ module Data.Functor.Misc
33 , dmapToThese
38 , dmapToThese
34 , eitherToDSum
39 , eitherToDSum
35 , dsumToEither
40 , dsumToEither
41+ -- * Deprecated functions
42+ , sequenceDmap
43+ , wrapDMap
44+ , rewrapDMap
45+ , unwrapDMap
46+ , unwrapDMapMaybe
47+ , extractFunctorDMap
36 , ComposeMaybe (..)
48 , ComposeMaybe (..)
37 ) where
49 ) where
38
50
39−import Control.Applicative ((<$>))
51+import Control.Applicative (Applicative, (<$>))
52+import Control.Monad.Identity
40import Data.Dependent.Map (DMap)
53import Data.Dependent.Map (DMap)
41import qualified Data.Dependent.Map as DMap
54import qualified Data.Dependent.Map as DMap
42import Data.Dependent.Sum
55import Data.Dependent.Sum
43−import Data.Functor.Identity
44import Data.GADT.Compare
56import Data.GADT.Compare
45import Data.GADT.Show
57import Data.GADT.Show
46import Data.IntMap (IntMap)
58import Data.IntMap (IntMap)
47import qualified Data.IntMap as IntMap
59import qualified Data.IntMap as IntMap
48import Data.Map (Map)
60import Data.Map (Map)
49import qualified Data.Map as Map
61import qualified Data.Map as Map
50−import Data.Some (Some, mkSome)
62+import Data.Some (Some)
63+import qualified Data.Some as Some
51import Data.These
64import Data.These
52−import Data.Type.Equality ((:~:)(Refl))
53import Data.Typeable hiding (Refl)
65import Data.Typeable hiding (Refl)
54
66
55--------------------------------------------------------------------------------
67--------------------------------------------------------------------------------
@@ -74,6 +86,9 @@ deriving instance Read k => Read (Const2 k v v)
74instance Show k => GShow (Const2 k v) where
86instance Show k => GShow (Const2 k v) where
75 gshowsPrec n x@(Const2 _) = showsPrec n x
87 gshowsPrec n x@(Const2 _) = showsPrec n x
76
88
89+instance (Show k, Show (f v)) => ShowTag (Const2 k v) f where
90+ showTaggedPrec (Const2 _) = showsPrec
91+
77instance Eq k => GEq (Const2 k v) where
92instance Eq k => GEq (Const2 k v) where
78 geq (Const2 a) (Const2 b) =
93 geq (Const2 a) (Const2 b) =
79 if a == b
94 if a == b
@@ -116,7 +131,7 @@ intMapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=
116-- | Convert a 'DMap' to a regular 'Map' by forgetting the types associated with
131-- | Convert a 'DMap' to a regular 'Map' by forgetting the types associated with
117-- the keys, using a function to remove the wrapping 'Functor'
132-- the keys, using a function to remove the wrapping 'Functor'
118weakenDMapWith :: (forall a. v a -> v') -> DMap k v -> Map (Some k) v'
133weakenDMapWith :: (forall a. v a -> v') -> DMap k v -> Map (Some k) v'
119−weakenDMapWith f = Map.fromDistinctAscList . map (\(k :=> v) -> (mkSome k, f v)) . DMap.toAscList
134+weakenDMapWith f = Map.fromDistinctAscList . map (\(k :=> v) -> (Some.This k, f v)) . DMap.toAscList
120
135
121--------------------------------------------------------------------------------
136--------------------------------------------------------------------------------
122-- WrapArg
137-- WrapArg
@@ -206,6 +221,11 @@ instance GShow (EitherTag l r) where
206 LeftTag -> showString "LeftTag"
221 LeftTag -> showString "LeftTag"
207 RightTag -> showString "RightTag"
222 RightTag -> showString "RightTag"
208
223
224+instance (Show l, Show r) => ShowTag (EitherTag l r) Identity where
225+ showTaggedPrec t n (Identity a) = case t of
226+ LeftTag -> showsPrec n a
227+ RightTag -> showsPrec n a
228+
209-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.
229-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.
210eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity
230eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity
211eitherToDSum = \case
231eitherToDSum = \case
@@ -229,3 +249,39 @@ newtype ComposeMaybe f a =
229 ComposeMaybe { getComposeMaybe :: Maybe (f a) } deriving (Show, Eq, Ord)
249 ComposeMaybe { getComposeMaybe :: Maybe (f a) } deriving (Show, Eq, Ord)
230
250
231deriving instance Functor f => Functor (ComposeMaybe f)
251deriving instance Functor f => Functor (ComposeMaybe f)
252+
253+--------------------------------------------------------------------------------
254+-- Deprecated functions
255+--------------------------------------------------------------------------------
256+
257+{-# INLINE sequenceDmap #-}
258+{-# DEPRECATED sequenceDmap "Use 'Data.Dependent.Map.traverseWithKey (\\_ -> fmap Identity)' instead" #-}
259+-- | Run the actions contained in the 'DMap'
260+sequenceDmap :: Applicative t => DMap f t -> t (DMap f Identity)
261+sequenceDmap = DMap.traverseWithKey $ \_ t -> Identity <$> t
262+
263+{-# DEPRECATED wrapDMap "Use 'Data.Dependent.Map.map (f . runIdentity)' instead" #-}
264+-- | Replace the 'Identity' functor for a 'DMap''s values with a different functor
265+wrapDMap :: (forall a. a -> f a) -> DMap k Identity -> DMap k f
266+wrapDMap f = DMap.map $ f . runIdentity
267+
268+{-# DEPRECATED rewrapDMap "Use 'Data.Dependent.Map.map' instead" #-}
269+-- | Replace one functor for a 'DMap''s values with a different functor
270+rewrapDMap :: (forall (a :: *). f a -> g a) -> DMap k f -> DMap k g
271+rewrapDMap = DMap.map
272+
273+{-# DEPRECATED unwrapDMap "Use 'Data.Dependent.Map.map (Identity . f)' instead" #-}
274+-- | Replace one functor for a 'DMap''s values with the 'Identity' functor
275+unwrapDMap :: (forall a. f a -> a) -> DMap k f -> DMap k Identity
276+unwrapDMap f = DMap.map $ Identity . f
277+
278+{-# DEPRECATED unwrapDMapMaybe "Use 'Data.Dependent.Map.mapMaybeWithKey (\\_ a -> fmap Identity $ f a)' instead" #-}
279+-- | Like 'unwrapDMap', but possibly delete some values from the DMap
280+unwrapDMapMaybe :: GCompare k => (forall a. f a -> Maybe a) -> DMap k f -> DMap k Identity
281+unwrapDMapMaybe f = DMap.mapMaybeWithKey $ \_ a -> Identity <$> f a
282+
283+{-# DEPRECATED extractFunctorDMap "Use 'mapKeyValuePairsMonotonic (\\(Const2 k :=> Identity v) -> Const2 k :=> v)' instead" #-}
284+-- | Eliminate the 'Identity' functor in a 'DMap' and replace it with the
285+-- underlying functor
286+extractFunctorDMap :: DMap (Const2 k (f v)) Identity -> DMap (Const2 k v) f
287+extractFunctorDMap = mapKeyValuePairsMonotonic $ \(Const2 k :=> Identity v) -> Const2 k :=> v
src/Data/Map/Misc.hsnew file+55
@@ -0,0 +1,55 @@
1+{-# LANGUAGE LambdaCase #-}
2+module Data.Map.Misc
3+ (
4+ -- * Working with Maps
5+ diffMapNoEq
6+ , diffMap
7+ , applyMap
8+ , mapPartitionEithers
9+ , applyMapKeysSet
10+ ) where
11+
12+import Data.Align
13+import Data.Either
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+diffMapNoEq :: (Ord k) => Map k v -> Map k v -> Map k (Maybe v)
22+diffMapNoEq olds news = flip Map.mapMaybe (align olds news) $ \case
23+ This _ -> Just Nothing
24+ These _ new -> Just $ Just new
25+ That new -> Just $ Just new
26+
27+diffMap :: (Ord k, Eq v) => Map k v -> Map k v -> Map k (Maybe v)
28+diffMap olds news = flip Map.mapMaybe (align olds news) $ \case
29+ This _ -> Just Nothing
30+ These old new
31+ | old == new -> Nothing
32+ | otherwise -> Just $ Just new
33+ That new -> Just $ Just new
34+
35+applyMap :: Ord k => Map k (Maybe v) -> Map k v -> Map k v
36+applyMap patch old = insertions `Map.union` (old `Map.difference` deletions)
37+ where (deletions, insertions) = mapPartitionEithers $ maybeToEither <$> patch
38+ maybeToEither = \case
39+ Nothing -> Left ()
40+ Just r -> Right r
41+
42+mapPartitionEithers :: Map k (Either a b) -> (Map k a, Map k b)
43+mapPartitionEithers m = (fromLeft <$> ls, fromRight <$> rs)
44+ where (ls, rs) = Map.partition isLeft m
45+ fromLeft (Left l) = l
46+ fromLeft _ = error "mapPartitionEithers: fromLeft received a Right value; this should be impossible"
47+ fromRight (Right r) = r
48+ fromRight _ = error "mapPartitionEithers: fromRight received a Left value; this should be impossible"
49+
50+-- | Apply a map patch to a set
51+-- > applyMapKeysSet patch (Map.keysSet m) == Map.keysSet (applyMap patch m)
52+applyMapKeysSet :: Ord k => Map k (Maybe v) -> Set k -> Set k
53+applyMapKeysSet patch old = Map.keysSet insertions `Set.union` (old `Set.difference` Map.keysSet deletions)
54+ where (insertions, deletions) = Map.partition isJust patch
55+
src/Data/Monoid/DecidablyEmpty.hsdeleted−115
@@ -1,115 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DefaultSignatures #-}
3−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4−{-# LANGUAGE StandaloneDeriving #-}
5−{-# LANGUAGE TypeOperators #-}
6−
7−-- TODO upstream somwhere else?
8−module Data.Monoid.DecidablyEmpty where
9−
10−import Data.Functor.Identity
11−import Data.Functor.Const
12−import Data.Monoid
13−import Data.Maybe (isNothing)
14−#if MIN_VERSION_base(4,11,0)
15−import Data.Ord
16−#endif
17−import Data.Proxy
18−import Data.Semigroup hiding (First, Last)
19−#if MIN_VERSION_base(4,12,0)
20−import GHC.Generics
21−#endif
22−
23−import qualified Data.IntSet as IntSet
24−import qualified Data.IntMap as IntMap
25−import qualified Data.Map as Map
26−import qualified Data.Sequence as Seq
27−import qualified Data.Set as Set
28−
29−import Data.GADT.Compare
30−import qualified Data.Dependent.Map as DMap
31−
32−-- | A 'DecidablyEmpty' is one where it can be computed whether or not an
33−-- arbitrary value is 'mempty'.
34−--
35−-- By using this class rather than 'Eq', we avoid unnecessary constraining the
36−-- contents of 'Functor's. This makes it possible to efficiently combine and/or
37−-- nest patch maps with 'Eq'-lacking values (e.g. functions) at the leaves.
38−class Monoid a => DecidablyEmpty a where
39− isEmpty :: a -> Bool
40− default isEmpty :: Eq a => a -> Bool
41− isEmpty = (==) mempty
42−
43−-- base
44−
45−instance DecidablyEmpty Ordering
46−instance DecidablyEmpty ()
47−instance DecidablyEmpty Any
48−instance DecidablyEmpty All
49−-- instance DecidablyEmpty Lifetime
50−-- instance DecidablyEmpty Event
51−instance DecidablyEmpty [a] where
52− isEmpty = null
53−instance
54−#if MIN_VERSION_base(4,11,0)
55− Semigroup a
56−#else
57− Monoid a
58−#endif
59− => DecidablyEmpty (Maybe a) where
60− isEmpty = isNothing
61−deriving instance (Num a, DecidablyEmpty a) => DecidablyEmpty (Product a)
62−deriving instance (DecidablyEmpty a, Num a) => DecidablyEmpty (Sum a)
63−deriving instance DecidablyEmpty a => DecidablyEmpty (Dual a)
64−instance DecidablyEmpty (First a) where
65− isEmpty (First a) = isNothing a
66−instance DecidablyEmpty (Last a) where
67− isEmpty (Last a) = isNothing a
68−deriving instance DecidablyEmpty a => DecidablyEmpty (Identity a)
69−instance Semigroup a => DecidablyEmpty (Option a) where
70− isEmpty (Option a) = isNothing a
71−deriving instance DecidablyEmpty m => DecidablyEmpty (WrappedMonoid m)
72−instance (Ord a, Bounded a) => DecidablyEmpty (Max a)
73−instance (Ord a, Bounded a) => DecidablyEmpty (Min a)
74−instance DecidablyEmpty (Proxy s)
75−deriving instance DecidablyEmpty a => DecidablyEmpty (Const a b)
76−#if MIN_VERSION_base(4,11,0)
77−deriving instance DecidablyEmpty a => DecidablyEmpty (Down a)
78−#endif
79−#if MIN_VERSION_base(4,12,0)
80−deriving instance DecidablyEmpty p => DecidablyEmpty (Par1 p)
81−instance DecidablyEmpty (U1 p)
82−deriving instance DecidablyEmpty (f p) => DecidablyEmpty (Rec1 f p)
83−deriving instance DecidablyEmpty (f p) => DecidablyEmpty (M1 i c f p)
84−deriving instance DecidablyEmpty c => DecidablyEmpty (K1 i c p)
85−instance (DecidablyEmpty (f p), DecidablyEmpty (g p)) => DecidablyEmpty ((f :*: g) p) where
86− isEmpty (x :*: y) = isEmpty x && isEmpty y
87−deriving instance DecidablyEmpty (f (g p)) => DecidablyEmpty ((f :.: g) p)
88−#endif
89−
90−instance (DecidablyEmpty a, DecidablyEmpty b) => DecidablyEmpty (a, b) where
91− isEmpty (a, b) = isEmpty a && isEmpty b
92−instance (DecidablyEmpty a, DecidablyEmpty b, DecidablyEmpty c) => DecidablyEmpty (a, b, c) where
93− isEmpty (a, b, c) = isEmpty a && isEmpty b && isEmpty c
94−instance (DecidablyEmpty a, DecidablyEmpty b, DecidablyEmpty c, DecidablyEmpty d) => DecidablyEmpty (a, b, c, d) where
95− isEmpty (a, b, c, d) = isEmpty a && isEmpty b && isEmpty c && isEmpty d
96−instance (DecidablyEmpty a, DecidablyEmpty b, DecidablyEmpty c, DecidablyEmpty d, DecidablyEmpty e) => DecidablyEmpty (a, b, c, d, e) where
97− isEmpty (a, b, c, d, e) = isEmpty a && isEmpty b && isEmpty c && isEmpty d && isEmpty e
98−
99−-- containers
100−
101−instance DecidablyEmpty IntSet.IntSet where
102− isEmpty = IntSet.null
103−instance DecidablyEmpty (IntMap.IntMap v) where
104− isEmpty = IntMap.null
105−instance Ord k => DecidablyEmpty (Map.Map k v) where
106− isEmpty = Map.null
107−instance DecidablyEmpty (Seq.Seq v) where
108− isEmpty = Seq.null
109−instance Ord k => DecidablyEmpty (Set.Set k) where
110− isEmpty = Set.null
111−
112−-- dependent-map
113−
114−instance GCompare k => DecidablyEmpty (DMap.DMap k v) where
115− isEmpty = DMap.null
src/Data/Patch.hsdeleted−95
@@ -1,95 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3−{-# LANGUAGE StandaloneDeriving #-}
4−{-# LANGUAGE TypeFamilies #-}
5−{-# LANGUAGE TypeOperators #-}
6−-- |
7−-- Module:
8−-- Data.Patch
9−-- Description:
10−-- This module defines the 'Patch' class.
11−module Data.Patch
12− ( module Data.Patch
13− , module X
14− ) where
15−
16−import Control.Applicative
17−import Data.Functor.Const (Const (..))
18−import Data.Functor.Identity
19−import Data.Map.Monoidal (MonoidalMap)
20−import Data.Proxy
21−#if !MIN_VERSION_base(4,11,0)
22−import Data.Semigroup (Semigroup (..))
23−#endif
24−import GHC.Generics
25−
26−import Data.Semigroup.Additive as X
27−import Data.Patch.Class as X
28−import Data.Patch.DMap as X hiding (getDeletions)
29−import Data.Patch.DMapWithMove as X
30− ( PatchDMapWithMove, const2PatchDMapWithMoveWith, mapPatchDMapWithMove
31− , patchDMapWithMoveToPatchMapWithMoveWith
32− , traversePatchDMapWithMoveWithKey, unPatchDMapWithMove
33− , unsafePatchDMapWithMove, weakenPatchDMapWithMoveWith
34− )
35−import Data.Patch.IntMap as X hiding (getDeletions)
36−import Data.Patch.Map as X
37−import Data.Patch.MapWithMove as X
38− ( PatchMapWithMove, patchMapWithMoveNewElements
39− , patchMapWithMoveNewElementsMap, unPatchMapWithMove
40− , unsafePatchMapWithMove
41− )
42−
43−-- | A 'Group' is a 'Monoid' where every element has an inverse.
44−class (Semigroup q, Monoid q) => Group q where
45− negateG :: q -> q
46− (~~) :: q -> q -> q
47− r ~~ s = r <> negateG s
48−
49−-- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type.
50−newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }
51−
52−instance Additive p => Patch (AdditivePatch p) where
53− type PatchTarget (AdditivePatch p) = p
54− apply (AdditivePatch p) q = Just $ p <> q
55−
56−instance (Ord k, Group q) => Group (MonoidalMap k q) where
57− negateG = fmap negateG
58−
59−-- | Trivial group.
60−instance Group () where
61− negateG _ = ()
62− _ ~~ _ = ()
63−
64−-- | Product group. A Pair of groups gives rise to a group
65−instance (Group a, Group b) => Group (a, b) where
66− negateG (a, b) = (negateG a, negateG b)
67− (a, b) ~~ (c, d) = (a ~~ c, b ~~ d)
68−
69−-- See https://gitlab.haskell.org/ghc/ghc/issues/11135#note_111802 for the reason Compose is not also provided.
70−-- Base does not define Monoid (Compose f g a) so this is the best we can
71−-- really do for functor composition.
72−instance Group (f (g a)) => Group ((f :.: g) a) where
73− negateG (Comp1 xs) = Comp1 (negateG xs)
74− Comp1 xs ~~ Comp1 ys = Comp1 (xs ~~ ys)
75−
76−-- | Product of groups, Functor style.
77−instance (Group (f a), Group (g a)) => Group ((f :*: g) a) where
78− negateG (a :*: b) = negateG a :*: negateG b
79− (a :*: b) ~~ (c :*: d) = (a ~~ c) :*: (b ~~ d)
80−
81−-- | Trivial group, Functor style
82−instance Group (Proxy x) where
83− negateG _ = Proxy
84− _ ~~ _ = Proxy
85−
86−-- | Const lifts groups into a functor.
87−deriving instance Group a => Group (Const a x)
88−
89−-- | Identity lifts groups pointwise (at only one point)
90−deriving instance Group a => Group (Identity a)
91−
92−-- | Functions lift groups pointwise.
93−instance Group b => Group (a -> b) where
94− negateG f = negateG . f
95− (~~) = liftA2 (~~)
src/Data/Patch/Class.hsdeleted−45
@@ -1,45 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ScopedTypeVariables #-}
3−{-# LANGUAGE TypeFamilies #-}
4−-- | The interface for types which represent changes made to other types
5−module Data.Patch.Class where
6−
7−import Data.Functor.Identity
8−import Data.Kind (Type)
9−import Data.Maybe
10−#if !MIN_VERSION_base(4,11,0)
11−import Data.Semigroup (Semigroup(..))
12−#endif
13−import Data.Proxy
14−
15−-- | A 'Patch' type represents a kind of change made to a datastructure.
16−--
17−-- If an instance of 'Patch' is also an instance of 'Semigroup', it should obey
18−-- the law that @applyAlways (f <> g) == applyAlways f . applyAlways g@.
19−class Patch p where
20− type PatchTarget p :: Type
21− -- | Apply the patch @p a@ to the value @a@. If no change is needed, return
22− -- 'Nothing'.
23− apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
24−
25−-- | Apply a 'Patch'; if it does nothing, return the original value
26−applyAlways :: Patch p => p -> PatchTarget p -> PatchTarget p
27−applyAlways p t = fromMaybe t $ apply p t
28−
29−-- | 'Identity' can be used as a 'Patch' that always fully replaces the value
30−instance Patch (Identity a) where
31− type PatchTarget (Identity a) = a
32− apply (Identity a) _ = Just a
33−
34−-- | 'Proxy' can be used as a 'Patch' that does nothing.
35−instance forall (a :: Type). Patch (Proxy a) where
36− type PatchTarget (Proxy a) = a
37− apply ~Proxy _ = Nothing
38−
39−-- | Like '(.)', but composes functions that return patches rather than
40−-- functions that return new values. The Semigroup instance for patches must
41−-- apply patches right-to-left, like '(.)'.
42−composePatchFunctions :: (Patch p, Semigroup p) => (PatchTarget p -> p) -> (PatchTarget p -> p) -> PatchTarget p -> p
43−composePatchFunctions g f a =
44− let fp = f a
45− in g (applyAlways fp a) <> fp
src/Data/Patch/IntMap.hsdeleted−76
@@ -1,76 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveTraversable #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5−{-# LANGUAGE MultiParamTypeClasses #-}
6−{-# LANGUAGE StandaloneDeriving #-}
7−{-# LANGUAGE TemplateHaskell #-}
8−{-# LANGUAGE TypeFamilies #-}
9−
10−-- | Module containing 'PatchIntMap', a 'Patch' for 'IntMap' which allows for
11−-- insert/update or delete of associations.
12−module Data.Patch.IntMap where
13−
14−import Control.Lens
15−import Data.IntMap.Strict (IntMap)
16−import qualified Data.IntMap.Strict as IntMap
17−import Data.Maybe
18−import Data.Monoid.DecidablyEmpty
19−#if !MIN_VERSION_base(4,11,0)
20−import Data.Semigroup (Semigroup (..))
21−#endif
22−import Data.Patch.Class
23−
24−-- | 'Patch' for 'IntMap' which represents insertion or deletion of keys in the mapping.
25−-- Internally represented by 'IntMap (Maybe a)', where @Just@ means insert/update
26−-- and @Nothing@ means delete.
27−newtype PatchIntMap a = PatchIntMap { unPatchIntMap :: IntMap (Maybe a) }
28− deriving ( Show, Read, Eq, Ord
29− , Functor, Foldable, Traversable
30− , Monoid, DecidablyEmpty
31− )
32−
33−-- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@.
34−-- If the same key is modified by both patches, the one on the left will take
35−-- precedence.
36−deriving instance Semigroup (PatchIntMap v)
37−
38−makeWrapped ''PatchIntMap
39−
40−-- | Apply the insertions or deletions to a given 'IntMap'.
41−instance Patch (PatchIntMap a) where
42− type PatchTarget (PatchIntMap a) = IntMap a
43− apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $
44− let removes = IntMap.filter isNothing p
45− adds = IntMap.mapMaybe id p
46− in IntMap.union adds $ v `IntMap.difference` removes
47−
48−instance FunctorWithIndex Int PatchIntMap
49−instance FoldableWithIndex Int PatchIntMap
50−instance TraversableWithIndex Int PatchIntMap where
51− itraverse = itraversed . Indexed
52− itraversed = _Wrapped .> itraversed <. traversed
53−
54−-- | Map a function @Int -> a -> b@ over all @a@s in the given @'PatchIntMap' a@
55−-- (that is, all inserts/updates), producing a @PatchIntMap b@.
56−mapIntMapPatchWithKey :: (Int -> a -> b) -> PatchIntMap a -> PatchIntMap b
57−mapIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap $ IntMap.mapWithKey (\ k mv -> f k <$> mv) m
58−
59−-- | Map an effectful function @Int -> a -> f b@ over all @a@s in the given @'PatchIntMap' a@
60−-- (that is, all inserts/updates), producing a @f (PatchIntMap b)@.
61−traverseIntMapPatchWithKey :: Applicative f => (Int -> a -> f b) -> PatchIntMap a -> f (PatchIntMap b)
62−traverseIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap <$> IntMap.traverseWithKey (traverse . f) m
63−
64−-- | Extract all @a@s inserted/updated by the given @'PatchIntMap' a@.
65−patchIntMapNewElements :: PatchIntMap a -> [a]
66−patchIntMapNewElements (PatchIntMap m) = catMaybes $ IntMap.elems m
67−
68−-- | Convert the given @'PatchIntMap' a@ into an @'IntMap' a@ with all
69−-- the inserts/updates in the given patch.
70−patchIntMapNewElementsMap :: PatchIntMap a -> IntMap a
71−patchIntMapNewElementsMap (PatchIntMap m) = IntMap.mapMaybe id m
72−
73−-- | Subset the given @'IntMap' a@ to contain only the keys that would be
74−-- deleted by the given @'PatchIntMap' a@.
75−getDeletions :: PatchIntMap v -> IntMap v' -> IntMap v'
76−getDeletions (PatchIntMap m) v = IntMap.intersection v m
src/Data/Patch/MapWithMove.hsdeleted−312
@@ -1,312 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveTraversable #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6−{-# LANGUAGE LambdaCase #-}
7−{-# LANGUAGE MultiParamTypeClasses #-}
8−{-# LANGUAGE PatternGuards #-}
9−{-# LANGUAGE PatternSynonyms #-}
10−{-# LANGUAGE ScopedTypeVariables #-}
11−{-# LANGUAGE StandaloneDeriving #-}
12−{-# LANGUAGE TemplateHaskell #-}
13−{-# LANGUAGE TypeApplications #-}
14−{-# LANGUAGE TypeFamilies #-}
15−{-# LANGUAGE ViewPatterns #-}
16−
17−-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
18−-- another
19−module Data.Patch.MapWithMove
20− ( PatchMapWithMove
21− ( PatchMapWithMove
22− , unPatchMapWithMove
23− , ..
24− )
25− , patchMapWithMove
26− , patchMapWithMoveInsertAll
27− , insertMapKey
28− , moveMapKey
29− , swapMapKey
30− , deleteMapKey
31− , unsafePatchMapWithMove
32− , patchMapWithMoveNewElements
33− , patchMapWithMoveNewElementsMap
34− , patchThatSortsMapWith
35− , patchThatChangesAndSortsMapWith
36− , patchThatChangesMap
37−
38− -- * Node Info
39− , NodeInfo
40− ( NodeInfo
41− , _nodeInfo_to
42− , _nodeInfo_from
43− , ..
44− )
45− , bitraverseNodeInfo
46− , nodeInfoMapFrom
47− , nodeInfoMapMFrom
48− , nodeInfoSetTo
49−
50− -- * From
51− , From
52− ( From_Insert
53− , From_Delete
54− , From_Move
55− , ..
56− )
57− , bitraverseFrom
58−
59− -- * To
60− , To
61− ) where
62−
63−import Data.Coerce
64−import Data.Kind (Type)
65−import Data.Patch.Class
66−import Data.Patch.MapWithPatchingMove (PatchMapWithPatchingMove(..), To)
67−import qualified Data.Patch.MapWithPatchingMove as PM -- already a transparent synonym
68−
69−import Control.Lens
70−import Data.List
71−import Data.Map (Map)
72−import qualified Data.Map as Map
73−import Data.Proxy
74−#if !MIN_VERSION_base(4,11,0)
75−import Data.Semigroup (Semigroup (..))
76−#endif
77−import Data.Traversable (foldMapDefault)
78−
79−-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
80−-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
81−-- and vice versa. There should never be any unpaired From/To keys.
82−newtype PatchMapWithMove k (v :: Type) = PatchMapWithMove'
83− { -- | Extract the underlying 'PatchMapWithPatchingMove k (Proxy v)'
84− unPatchMapWithMove' :: PatchMapWithPatchingMove k (Proxy v)
85− }
86− deriving ( Show, Read, Eq, Ord
87−-- Haddock cannot handle documentation here before GHC 8.6
88− ,
89−#if __GLASGOW_HASKELL__ >= 806
90− -- | Compose patches having the same effect as applying the
91− -- patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p .
92− -- 'applyAlways' q@
93−#endif
94− Semigroup
95− , Monoid
96− )
97−
98−pattern Coerce :: Coercible a b => a -> b
99−pattern Coerce x <- (coerce -> x)
100− where Coerce x = coerce x
101−
102−{-# COMPLETE PatchMapWithMove #-}
103−pattern PatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
104−-- | Extract the representation of the 'PatchMapWithMove' as a map of
105−-- 'NodeInfo'.
106−unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)
107−pattern PatchMapWithMove { unPatchMapWithMove } = PatchMapWithMove' (PatchMapWithPatchingMove (Coerce unPatchMapWithMove))
108−
109−_PatchMapWithMove
110− :: Iso
111− (PatchMapWithMove k0 v0)
112− (PatchMapWithMove k1 v1)
113− (Map k0 (NodeInfo k0 v0))
114− (Map k1 (NodeInfo k1 v1))
115−_PatchMapWithMove = iso unPatchMapWithMove PatchMapWithMove
116−
117−instance Functor (PatchMapWithMove k) where
118− fmap f = runIdentity . traverse (Identity . f)
119−
120−instance Foldable (PatchMapWithMove k) where
121− foldMap = foldMapDefault
122−
123−instance Traversable (PatchMapWithMove k) where
124− traverse =
125− _PatchMapWithMove .
126− traverse .
127− traverse
128−
129−instance FunctorWithIndex k (PatchMapWithMove k)
130−instance FoldableWithIndex k (PatchMapWithMove k)
131−instance TraversableWithIndex k (PatchMapWithMove k) where
132− itraverse = itraversed . Indexed
133− itraversed =
134− _PatchMapWithMove .>
135− itraversed <.
136− traverse
137−
138−-- | Create a 'PatchMapWithMove', validating it
139−patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
140−patchMapWithMove = fmap PatchMapWithMove' . PM.patchMapWithPatchingMove . coerce
141−
142−-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'
143−patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v
144−patchMapWithMoveInsertAll = PatchMapWithMove' . PM.patchMapWithPatchingMoveInsertAll
145−
146−-- | Make a @'PatchMapWithMove' k v@ which has the effect of inserting or updating a value @v@ to the given key @k@, like 'Map.insert'.
147−insertMapKey :: k -> v -> PatchMapWithMove k v
148−insertMapKey k v = PatchMapWithMove' $ PM.insertMapKey k v
149−
150−-- |Make a @'PatchMapWithMove' k v@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to:
151−--
152−-- @
153−-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
154−-- @
155−moveMapKey :: Ord k => k -> k -> PatchMapWithMove k v
156−moveMapKey src dst = PatchMapWithMove' $ PM.moveMapKey src dst
157−
158−-- |Make a @'PatchMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
159−--
160−-- @
161−-- let aMay = Map.lookup a map
162−-- bMay = Map.lookup b map
163−-- in maybe id (Map.insert a) (bMay <> aMay)
164−-- . maybe id (Map.insert b) (aMay <> bMay)
165−-- . Map.delete a . Map.delete b $ map
166−-- @
167−swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v
168−swapMapKey src dst = PatchMapWithMove' $ PM.swapMapKey src dst
169−
170−-- |Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'Map.delete'.
171−deleteMapKey :: k -> PatchMapWithMove k v
172−deleteMapKey = PatchMapWithMove' . PM.deleteMapKey
173−
174−-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants.
175−--
176−-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithMove' are preserved; they will not be checked.
177−unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
178−unsafePatchMapWithMove = coerce PM.unsafePatchMapWithPatchingMove
179−
180−-- | Apply the insertions, deletions, and moves to a given 'Map'
181−instance Ord k => Patch (PatchMapWithMove k v) where
182− type PatchTarget (PatchMapWithMove k v) = Map k v
183− apply (PatchMapWithMove' p) = apply p
184−
185−-- | Returns all the new elements that will be added to the 'Map'.
186−patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
187−patchMapWithMoveNewElements = PM.patchMapWithPatchingMoveNewElements . unPatchMapWithMove'
188−
189−-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@.
190−patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v
191−patchMapWithMoveNewElementsMap = PM.patchMapWithPatchingMoveNewElementsMap . unPatchMapWithMove'
192−
193−-- | Create a 'PatchMapWithMove' that, if applied to the given 'Map', will sort
194−-- its values using the given ordering function. The set keys of the 'Map' is
195−-- not changed.
196−patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v
197−patchThatSortsMapWith cmp = PatchMapWithMove' . PM.patchThatSortsMapWith cmp
198−
199−-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
200−-- will produce a 'Map' with the same values as the second 'Map' but with the
201−-- values sorted with the given ordering function.
202−patchThatChangesAndSortsMapWith :: (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
203−patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
204− where newList = Map.toList newByIndexUnsorted
205− newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
206−
207−-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
208−-- will produce the second 'Map'.
209−patchThatChangesMap :: (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v
210−patchThatChangesMap oldByIndex newByIndex = PatchMapWithMove' $
211− PM.patchThatChangesMap oldByIndex newByIndex
212−
213−--
214−-- NodeInfo
215−--
216−
217−-- | Holds the information about each key: where its new value should come from,
218−-- and where its old value should go to
219−newtype NodeInfo k (v :: Type) = NodeInfo' { unNodeInfo' :: PM.NodeInfo k (Proxy v) }
220−
221−deriving instance (Show k, Show p) => Show (NodeInfo k p)
222−deriving instance (Read k, Read p) => Read (NodeInfo k p)
223−deriving instance (Eq k, Eq p) => Eq (NodeInfo k p)
224−deriving instance (Ord k, Ord p) => Ord (NodeInfo k p)
225−
226−{-# COMPLETE NodeInfo #-}
227−pattern NodeInfo :: To k -> From k v -> NodeInfo k v
228−_nodeInfo_to :: NodeInfo k v -> To k
229−_nodeInfo_from :: NodeInfo k v -> From k v
230−pattern NodeInfo { _nodeInfo_to, _nodeInfo_from } = NodeInfo'
231− PM.NodeInfo
232− { PM._nodeInfo_to = _nodeInfo_to
233− , PM._nodeInfo_from = Coerce _nodeInfo_from
234− }
235−
236−_NodeInfo
237− :: Iso
238− (NodeInfo k0 v0)
239− (NodeInfo k1 v1)
240− (PM.NodeInfo k0 (Proxy v0))
241− (PM.NodeInfo k1 (Proxy v1))
242−_NodeInfo = iso unNodeInfo' NodeInfo'
243−
244−instance Functor (NodeInfo k) where
245− fmap f = runIdentity . traverse (Identity . f)
246−
247−instance Foldable (NodeInfo k) where
248− foldMap = foldMapDefault
249−
250−instance Traversable (NodeInfo k) where
251− traverse = bitraverseNodeInfo pure
252−
253−bitraverseNodeInfo
254− :: Applicative f
255− => (k0 -> f k1)
256− -> (v0 -> f v1)
257− -> NodeInfo k0 v0 -> f (NodeInfo k1 v1)
258−bitraverseNodeInfo fk fv = fmap NodeInfo'
259− . PM.bitraverseNodeInfo fk (\ ~Proxy -> pure Proxy) fv
260− . coerce
261−
262−-- | Change the 'From' value of a 'NodeInfo'
263−nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
264−nodeInfoMapFrom f = coerce $ PM.nodeInfoMapFrom (unFrom' . f . From')
265−
266−-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
267−-- 'Applicative', 'Monad', etc.) action to get the new value
268−nodeInfoMapMFrom
269− :: Functor f
270− => (From k v -> f (From k v))
271− -> NodeInfo k v -> f (NodeInfo k v)
272−nodeInfoMapMFrom f = fmap NodeInfo'
273− . PM.nodeInfoMapMFrom (fmap unFrom' . f . From')
274− . coerce
275−
276−-- | Set the 'To' field of a 'NodeInfo'
277−nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v
278−nodeInfoSetTo = coerce . PM.nodeInfoSetTo
279−
280−--
281−-- From
282−--
283−
284−-- | Describe how a key's new value should be produced
285−newtype From k (v :: Type) = From' { unFrom' :: PM.From k (Proxy v) }
286−
287−{-# COMPLETE From_Insert, From_Delete, From_Move #-}
288−
289−-- | Insert the given value here
290−pattern From_Insert :: v -> From k v
291−pattern From_Insert v = From' (PM.From_Insert v)
292−
293−-- | Delete the existing value, if any, from here
294−pattern From_Delete :: From k v
295−pattern From_Delete = From' PM.From_Delete
296−
297−-- | Move the value here from the given key
298−pattern From_Move :: k -> From k v
299−pattern From_Move k = From' (PM.From_Move k Proxy)
300−
301−bitraverseFrom
302− :: Applicative f
303− => (k0 -> f k1)
304− -> (v0 -> f v1)
305− -> From k0 v0 -> f (From k1 v1)
306−bitraverseFrom fk fv = fmap From'
307− . PM.bitraverseFrom fk (\ ~Proxy -> pure Proxy) fv
308− . coerce
309−
310−makeWrapped ''PatchMapWithMove
311−makeWrapped ''NodeInfo
312−makeWrapped ''From
src/Data/Patch/MapWithPatchingMove.hsdeleted−432
@@ -1,432 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3−{-# LANGUAGE FlexibleContexts #-}
4−{-# LANGUAGE FlexibleInstances #-}
5−{-# LANGUAGE LambdaCase #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE PatternGuards #-}
8−{-# LANGUAGE ScopedTypeVariables #-}
9−{-# LANGUAGE StandaloneDeriving #-}
10−{-# LANGUAGE TemplateHaskell #-}
11−{-# LANGUAGE TypeFamilies #-}
12−{-# LANGUAGE UndecidableInstances #-}
13−
14−-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
15−-- another
16−module Data.Patch.MapWithPatchingMove
17− ( PatchMapWithPatchingMove (..)
18− , patchMapWithPatchingMove
19− , patchMapWithPatchingMoveInsertAll
20− , insertMapKey
21− , moveMapKey
22− , swapMapKey
23− , deleteMapKey
24− , unsafePatchMapWithPatchingMove
25− , patchMapWithPatchingMoveNewElements
26− , patchMapWithPatchingMoveNewElementsMap
27− , patchThatSortsMapWith
28− , patchThatChangesAndSortsMapWith
29− , patchThatChangesMap
30−
31− -- * Node Info
32− , NodeInfo (..)
33− , bitraverseNodeInfo
34− , nodeInfoMapFrom
35− , nodeInfoMapMFrom
36− , nodeInfoSetTo
37−
38− -- * From
39− , From(..)
40− , bitraverseFrom
41−
42− -- * To
43− , To
44−
45− -- TODO internals module
46− , Fixup (..)
47− ) where
48−
49−import Data.Patch.Class
50−
51−import Control.Lens hiding (from, to)
52−import Control.Lens.TH (makeWrapped)
53−import Data.Align (align)
54−import Data.Foldable (toList)
55−import Data.Function
56−import Data.List
57−import Data.Map (Map)
58−import qualified Data.Map as Map
59−import Data.Maybe
60−#if !MIN_VERSION_base(4,11,0)
61−import Data.Semigroup (Semigroup (..))
62−#endif
63−import Data.Monoid.DecidablyEmpty
64−import Data.Set (Set)
65−import qualified Data.Set as Set
66−import Data.These (These (..))
67−
68−-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
69−-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
70−-- and vice versa. There should never be any unpaired From/To keys.
71−newtype PatchMapWithPatchingMove k p = PatchMapWithPatchingMove
72− { -- | Extract the internal representation of the 'PatchMapWithPatchingMove'
73− unPatchMapWithPatchingMove :: Map k (NodeInfo k p)
74− }
75−
76−deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (PatchMapWithPatchingMove k p)
77−deriving instance (Ord k, Read k, Read p, Read (PatchTarget p)) => Read (PatchMapWithPatchingMove k p)
78−deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (PatchMapWithPatchingMove k p)
79−deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (PatchMapWithPatchingMove k p)
80−
81−deriving instance ( Ord k
82−#if !MIN_VERSION_base(4,11,0)
83− , Semigroup p
84−#endif
85− , DecidablyEmpty p
86− , Patch p
87− ) => DecidablyEmpty (PatchMapWithPatchingMove k p)
88−
89−-- | Create a 'PatchMapWithPatchingMove', validating it
90−patchMapWithPatchingMove
91− :: Ord k => Map k (NodeInfo k p) -> Maybe (PatchMapWithPatchingMove k p)
92−patchMapWithPatchingMove m = if valid then Just $ PatchMapWithPatchingMove m else Nothing
93− where valid = forwardLinks == backwardLinks
94− forwardLinks = Map.mapMaybe _nodeInfo_to m
95− backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, p) ->
96− case _nodeInfo_from p of
97− From_Move from _ -> Just (from, to)
98− _ -> Nothing
99−
100−-- | Create a 'PatchMapWithPatchingMove' that inserts everything in the given 'Map'
101−patchMapWithPatchingMoveInsertAll
102− :: Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
103−patchMapWithPatchingMoveInsertAll m = PatchMapWithPatchingMove $ flip fmap m $ \v -> NodeInfo
104− { _nodeInfo_from = From_Insert v
105− , _nodeInfo_to = Nothing
106− }
107−
108−-- | Make a @'PatchMapWithPatchingMove' k p@ which has the effect of inserting or replacing a value @v@ at the given key @k@, like 'Map.insert'.
109−insertMapKey
110− :: k -> PatchTarget p -> PatchMapWithPatchingMove k p
111−insertMapKey k v = PatchMapWithPatchingMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing
112−
113−-- |Make a @'PatchMapWithPatchingMove' k p@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to:
114−--
115−-- @
116−-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
117−-- @
118−moveMapKey
119− :: ( DecidablyEmpty p
120−#if !MIN_VERSION_base(4,11,0)
121− , Semigroup p
122−#endif
123− , Patch p
124− )
125− => Ord k => k -> k -> PatchMapWithPatchingMove k p
126−moveMapKey src dst
127− | src == dst = mempty
128− | otherwise =
129− PatchMapWithPatchingMove $ Map.fromList
130− [ (dst, NodeInfo (From_Move src mempty) Nothing)
131− , (src, NodeInfo From_Delete (Just dst))
132− ]
133−
134−-- |Make a @'PatchMapWithPatchingMove' k p@ which has the effect of swapping two keys in the mapping, equivalent to:
135−--
136−-- @
137−-- let aMay = Map.lookup a map
138−-- bMay = Map.lookup b map
139−-- in maybe id (Map.insert a) (bMay <> aMay)
140−-- . maybe id (Map.insert b) (aMay <> bMay)
141−-- . Map.delete a . Map.delete b $ map
142−-- @
143−swapMapKey
144− :: ( DecidablyEmpty p
145−#if !MIN_VERSION_base(4,11,0)
146− , Semigroup p
147−#endif
148− , Patch p
149− )
150− => Ord k => k -> k -> PatchMapWithPatchingMove k p
151−swapMapKey src dst
152− | src == dst = mempty
153− | otherwise =
154− PatchMapWithPatchingMove $ Map.fromList
155− [ (dst, NodeInfo (From_Move src mempty) (Just src))
156− , (src, NodeInfo (From_Move dst mempty) (Just dst))
157− ]
158−
159−-- | Make a @'PatchMapWithPatchingMove' k v@ which has the effect of deleting a key in
160−-- the mapping, equivalent to 'Map.delete'.
161−deleteMapKey
162− :: k -> PatchMapWithPatchingMove k v
163−deleteMapKey k = PatchMapWithPatchingMove . Map.singleton k $ NodeInfo From_Delete Nothing
164−
165−-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithPatchingMove' k v@, without checking any invariants.
166−--
167−-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithPatchingMove' are preserved; they will not be checked.
168−unsafePatchMapWithPatchingMove
169− :: Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
170−unsafePatchMapWithPatchingMove = PatchMapWithPatchingMove
171−
172−-- | Apply the insertions, deletions, and moves to a given 'Map'
173−instance (Ord k, Patch p) => Patch (PatchMapWithPatchingMove k p) where
174− type PatchTarget (PatchMapWithPatchingMove k p) = Map k (PatchTarget p)
175− -- TODO: return Nothing sometimes
176− -- Note: the strict application here is critical to ensuring that incremental
177− -- merges don't hold onto all their prerequisite events forever; can we make
178− -- this more robust?
179− apply (PatchMapWithPatchingMove m) old = Just $! insertions `Map.union` (old `Map.difference` deletions)
180− where insertions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
181− From_Insert v -> Just v
182− From_Move k p -> applyAlways p <$> Map.lookup k old
183− From_Delete -> Nothing
184− deletions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
185− From_Delete -> Just ()
186− _ -> Nothing
187−
188−-- | Returns all the new elements that will be added to the 'Map'
189−patchMapWithPatchingMoveNewElements
190− :: PatchMapWithPatchingMove k p -> [PatchTarget p]
191−patchMapWithPatchingMoveNewElements = Map.elems . patchMapWithPatchingMoveNewElementsMap
192−
193−-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithPatchingMove' k v@.
194−patchMapWithPatchingMoveNewElementsMap
195− :: PatchMapWithPatchingMove k p -> Map k (PatchTarget p)
196−patchMapWithPatchingMoveNewElementsMap (PatchMapWithPatchingMove p) = Map.mapMaybe f p
197− where f ni = case _nodeInfo_from ni of
198− From_Insert v -> Just v
199− From_Move _ _ -> Nothing
200− From_Delete -> Nothing
201−
202−-- | Create a 'PatchMapWithPatchingMove' that, if applied to the given 'Map', will sort
203−-- its values using the given ordering function. The set keys of the 'Map' is
204−-- not changed.
205−patchThatSortsMapWith
206− :: (Ord k, Monoid p)
207− => (PatchTarget p -> PatchTarget p -> Ordering)
208− -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
209−patchThatSortsMapWith cmp m = PatchMapWithPatchingMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted
210− where unsorted = Map.toList m
211− sorted = sortBy (cmp `on` snd) unsorted
212− f (to, _) (from, _) = if to == from then Nothing else
213− Just (from, to)
214− reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
215− g (to, _) (from, _) = if to == from then Nothing else
216− let Just movingTo = Map.lookup from reverseMapping
217− in Just (to, NodeInfo (From_Move from mempty) $ Just movingTo)
218−
219−-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
220−-- will produce a 'Map' with the same values as the second 'Map' but with the
221−-- values sorted with the given ordering function.
222−patchThatChangesAndSortsMapWith
223− :: forall k p. (Ord k, Ord (PatchTarget p), Monoid p)
224− => (PatchTarget p -> PatchTarget p -> Ordering)
225− -> Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
226−patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
227− where newList = Map.toList newByIndexUnsorted
228− newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
229−
230−-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
231−-- will produce the second 'Map'.
232−-- Note: this will never produce a patch on a value.
233−patchThatChangesMap
234− :: forall k p
235− . (Ord k, Ord (PatchTarget p), Monoid p)
236− => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
237−patchThatChangesMap oldByIndex newByIndex = patch
238− where invert :: Map k (PatchTarget p) -> Map (PatchTarget p) (Set k)
239− invert = Map.fromListWith (<>) . fmap (\(k, v) -> (v, Set.singleton k)) . Map.toList
240− -- In the places where we use unionDistinct, a non-distinct key indicates a bug in this function
241− unionDistinct :: forall k' v'. Ord k' => Map k' v' -> Map k' v' -> Map k' v'
242− unionDistinct = Map.unionWith (error "patchThatChangesMap: non-distinct keys")
243− unionPairDistinct :: (Map k (From k v), Map k (To k)) -> (Map k (From k v), Map k (To k)) -> (Map k (From k v), Map k (To k))
244− unionPairDistinct (oldFroms, oldTos) (newFroms, newTos) = (unionDistinct oldFroms newFroms, unionDistinct oldTos newTos)
245− -- Generate patch info for a single value
246− -- Keys that are found in both the old and new sets will not be patched
247− -- Keys that are found in only the old set will be moved to a new position if any are available; otherwise they will be deleted
248− -- Keys that are found in only the new set will be populated by moving an old key if any are available; otherwise they will be inserted
249− patchSingleValue :: PatchTarget p -> Set k -> Set k -> (Map k (From k p), Map k (To k))
250− patchSingleValue v oldKeys newKeys = foldl' unionPairDistinct mempty $ align (toList $ oldKeys `Set.difference` newKeys) (toList $ newKeys `Set.difference` oldKeys) <&> \case
251− This oldK -> (mempty, Map.singleton oldK Nothing) -- There's nowhere for this value to go, so we know we are deleting it
252− That newK -> (Map.singleton newK $ From_Insert v, mempty) -- There's nowhere fo this value to come from, so we know we are inserting it
253− These oldK newK -> (Map.singleton newK $ From_Move oldK mempty, Map.singleton oldK $ Just newK)
254− -- Run patchSingleValue on a These. Missing old or new sets are considered empty
255− patchSingleValueThese :: PatchTarget p -> These (Set k) (Set k) -> (Map k (From k p), Map k (To k))
256− patchSingleValueThese v = \case
257− This oldKeys -> patchSingleValue v oldKeys mempty
258− That newKeys -> patchSingleValue v mempty newKeys
259− These oldKeys newKeys -> patchSingleValue v oldKeys newKeys
260− -- Generate froms and tos for all values, then merge them together
261− (froms, tos) = foldl' unionPairDistinct mempty $ Map.mapWithKey patchSingleValueThese $ align (invert oldByIndex) (invert newByIndex)
262− patch = unsafePatchMapWithPatchingMove $ align froms tos <&> \case
263− This from -> NodeInfo from Nothing -- Since we don't have a 'to' record for this key, that must mean it isn't being moved anywhere, so it should be deleted.
264− That to -> NodeInfo From_Delete to -- Since we don't have a 'from' record for this key, it must be getting deleted
265− These from to -> NodeInfo from to
266−
267−--
268−-- NodeInfo
269−--
270−
271−-- | Holds the information about each key: where its new value should come from,
272−-- and where its old value should go to
273−data NodeInfo k p = NodeInfo
274− { _nodeInfo_from :: !(From k p)
275− -- ^ Where do we get the new value for this key?
276− , _nodeInfo_to :: !(To k)
277− -- ^ If the old value is being kept (i.e. moved rather than deleted or
278− -- replaced), where is it going?
279− }
280−deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (NodeInfo k p)
281−deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (NodeInfo k p)
282−deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (NodeInfo k p)
283−deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (NodeInfo k p)
284−
285−-- | Traverse the 'NodeInfo' over the key, patch, and patch target. Because of
286−-- the type families here, this doesn't it any bi- or tri-traversal class.
287−bitraverseNodeInfo
288− :: Applicative f
289− => (k0 -> f k1)
290− -> (p0 -> f p1)
291− -> (PatchTarget p0 -> f (PatchTarget p1))
292− -> NodeInfo k0 p0 -> f (NodeInfo k1 p1)
293−bitraverseNodeInfo fk fp fpt (NodeInfo from to) = NodeInfo
294− <$> bitraverseFrom fk fp fpt from
295− <*> traverse fk to
296−
297−-- | Change the 'From' value of a 'NodeInfo'
298−nodeInfoMapFrom
299− :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
300−nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
301−
302−-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
303−-- 'Applicative', 'Monad', etc.) action to get the new value
304−nodeInfoMapMFrom
305− :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
306−nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
307−
308−-- | Set the 'To' field of a 'NodeInfo'
309−nodeInfoSetTo
310− :: To k -> NodeInfo k v -> NodeInfo k v
311−nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
312−
313−--
314−-- From
315−--
316−
317−-- | Describe how a key's new value should be produced
318−data From k p
319− = From_Insert (PatchTarget p) -- ^ Insert the given value here
320− | From_Delete -- ^ Delete the existing value, if any, from here
321− | From_Move !k !p -- ^ Move the value here from the given key, and apply the given patch
322−
323−deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (From k p)
324−deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (From k p)
325−deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (From k p)
326−deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (From k p)
327−
328−-- | Traverse the 'From' over the key, patch, and patch target. Because of
329−-- the type families here, this doesn't it any bi- or tri-traversal class.
330−bitraverseFrom
331− :: Applicative f
332− => (k0 -> f k1)
333− -> (p0 -> f p1)
334− -> (PatchTarget p0 -> f (PatchTarget p1))
335− -> From k0 p0 -> f (From k1 p1)
336−bitraverseFrom fk fp fpt = \case
337− From_Insert pt -> From_Insert <$> fpt pt
338− From_Delete -> pure From_Delete
339− From_Move k p -> From_Move <$> fk k <*> fp p
340−
341−--
342−-- To
343−--
344−
345−-- | Describe where a key's old value will go. If this is 'Just', that means
346−-- the key's old value will be moved to the given other key; if it is 'Nothing',
347−-- that means it will be deleted.
348−type To = Maybe
349−
350−--
351−-- Fixup
352−--
353−
354−-- | Helper data structure used for composing patches using the monoid instance.
355−data Fixup k v
356− = Fixup_Delete
357− | Fixup_Update (These (From k v) (To k))
358−
359−-- | Compose patches having the same effect as applying the patches in turn:
360−-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
361−instance ( Ord k
362−#if !MIN_VERSION_base(4,11,0)
363− , Semigroup p
364−#endif
365− , DecidablyEmpty p
366− , Patch p
367− ) => Semigroup (PatchMapWithPatchingMove k p) where
368− PatchMapWithPatchingMove ma <> PatchMapWithPatchingMove mb = PatchMapWithPatchingMove m
369− where
370− connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb
371− h :: (k, (Maybe k, From k p)) -> [(k, Fixup k p)]
372− h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of
373− (Just toAfter, From_Move fromBefore p)
374− | fromBefore == toAfter && isEmpty p
375− -> [(toAfter, Fixup_Delete)]
376− | otherwise
377− -> [ (toAfter, Fixup_Update (This editBefore))
378− , (fromBefore, Fixup_Update (That mToAfter))
379− ]
380− (Nothing, From_Move fromBefore _) -> [(fromBefore, Fixup_Update (That mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map
381− (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]
382− (Nothing, _) -> []
383− mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
384− mergeFixups _ (Fixup_Update a) (Fixup_Update b)
385− | This x <- a, That y <- b
386− = Fixup_Update $ These x y
387− | That y <- a, This x <- b
388− = Fixup_Update $ These x y
389− mergeFixups _ _ _ = error "PatchMapWithPatchingMove: incompatible fixups"
390− fixups = Map.fromListWithKey mergeFixups $ concatMap h connections
391− combineNodeInfos _ nia nib = NodeInfo
392− { _nodeInfo_from = _nodeInfo_from nia
393− , _nodeInfo_to = _nodeInfo_to nib
394− }
395− applyFixup _ ni = \case
396− Fixup_Delete -> Nothing
397− Fixup_Update u -> Just $ NodeInfo
398− { _nodeInfo_from = case _nodeInfo_from ni of
399− f@(From_Move _ p') -> case getHere u of -- The `from` fixup comes from the "old" patch
400− Nothing -> f -- If there's no `from` fixup, just use the "new" `from`
401− Just (From_Insert v) -> From_Insert $ applyAlways p' v
402− Just From_Delete -> From_Delete
403− Just (From_Move oldKey p) -> From_Move oldKey $ p' <> p
404− _ -> error "PatchMapWithPatchingMove: fixup for non-move From"
405− , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
406− }
407− m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups
408− getHere :: These a b -> Maybe a
409− getHere = \case
410− This a -> Just a
411− These a _ -> Just a
412− That _ -> Nothing
413− getThere :: These a b -> Maybe b
414− getThere = \case
415− This _ -> Nothing
416− These _ b -> Just b
417− That b -> Just b
418−
419−--TODO: Figure out how to implement this in terms of PatchDMapWithPatchingMove rather than duplicating it here
420−-- | Compose patches having the same effect as applying the patches in turn:
421−-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
422−instance ( Ord k
423−#if !MIN_VERSION_base(4,11,0)
424− , Semigroup p
425−#endif
426− , DecidablyEmpty p
427− , Patch p
428− ) => Monoid (PatchMapWithPatchingMove k p) where
429− mempty = PatchMapWithPatchingMove mempty
430− mappend = (<>)
431−
432−makeWrapped ''PatchMapWithPatchingMove
src/Data/Semigroup/Additive.hsdeleted−54
@@ -1,54 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE TypeOperators #-}
3−{-# LANGUAGE TypeFamilies #-}
4−-- |
5−-- Module:
6−-- Data.Semigroup.Additive
7−-- Description:
8−-- This module defines a class for commutative semigroups, until it is moved
9−-- to another library.
10−module Data.Semigroup.Additive
11− ( Additive
12− ) where
13−
14−import Data.Functor.Const (Const (..))
15−import Data.Functor.Identity
16−import Data.Proxy
17−#if !MIN_VERSION_base(4,12,0)
18−-- for :*: and :.: semigroup instances
19−import Data.Orphans ()
20−#endif
21−#if !MIN_VERSION_base(4,11,0)
22−import Data.Semigroup (Semigroup (..))
23−#endif
24−import GHC.Generics
25−
26−-- | An 'Additive' 'Semigroup' is one where (<>) is commutative
27−class Semigroup q => Additive q where
28−
29−-- | Trivial additive semigroup.
30−instance Additive ()
31−
32−-- | Product additive semigroup.
33−-- A Pair of additive semigroups gives rise to a additive semigroup
34−instance (Additive a, Additive b) => Additive (a, b)
35−
36−-- See https://gitlab.haskell.org/ghc/ghc/issues/11135#note_111802 for the reason Compose is not also provided.
37−-- Base does not define Monoid (Compose f g a) so this is the best we can
38−-- really do for functor composition.
39−instance Additive (f (g a)) => Additive ((f :.: g) a)
40−
41−-- | Product of additive semigroups, Functor style.
42−instance (Additive (f a), Additive (g a)) => Additive ((f :*: g) a)
43−
44−-- | Trivial additive semigroup, Functor style
45−instance Additive (Proxy x)
46−
47−-- | Const lifts additive semigroups into a functor.
48−instance Additive a => Additive (Const a x)
49−
50−-- | Identity lifts additive semigroups pointwise (at only one point)
51−instance Additive a => Additive (Identity a)
52−
53−-- | Functions lift additive semigroups pointwise.
54−instance Additive b => Additive (a -> b)
src/Data/WeakBag.hsnew file+124
@@ -0,0 +1,124 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE ExistentialQuantification #-}
4+#ifdef USE_REFLEX_OPTIMIZER
5+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
6+#endif
7+-- | This module defines the 'WeakBag' type, which represents a mutable
8+-- collection of items that does not cause the items to be retained in memory.
9+-- This is useful for situations where a value needs to be inspected or modified
10+-- if it is still alive, but can be ignored if it is dead.
11+module Data.WeakBag
12+ ( WeakBag
13+ , WeakBagTicket
14+ , empty
15+ , singleton
16+ , insert
17+ , traverse
18+ , remove
19+ -- * Internal functions
20+ -- These will not always be available.
21+ , _weakBag_children --TODO: Don't export this
22+ ) where
23+
24+import Control.Exception
25+import Control.Monad hiding (forM_, mapM_)
26+import Control.Monad.IO.Class
27+import Data.Foldable (forM_, mapM_)
28+import Data.IntMap.Strict (IntMap)
29+import qualified Data.IntMap.Strict as IntMap
30+import Data.IORef
31+import System.Mem.Weak
32+
33+import Prelude hiding (mapM_, traverse)
34+
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@s remain
37+-- alive, the 'WeakBag' will continue to refer to them.
38+data 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
41+ }
42+
43+-- | When inserting an item into a 'WeakBag', a 'WeakBagTicket' is returned. If
44+-- the caller retains the ticket, the item is guranteed to stay in memory (and
45+-- thus in the 'WeakBag'). The ticket can also be used to remove the item from
46+-- the 'WeakBag' prematurely (i.e. while it is still alive), using 'remove'.
47+data WeakBagTicket = forall a. WeakBagTicket
48+ { _weakBagTicket_weakItem :: {-# UNPACK #-} !(Weak a)
49+ , _weakBagTicket_item :: {-# NOUNPACK #-} !a
50+ }
51+
52+-- | Insert an item into a 'WeakBag'.
53+{-# INLINE insert #-}
54+insert :: a -- ^ The item
55+ -> WeakBag a -- ^ The 'WeakBag' to insert into
56+ -> IORef (Weak b) -- ^ An arbitrary value to be used in the following
57+ -- callback
58+ -> (b -> IO ()) -- ^ A callback to be invoked when the item is removed
59+ -- (whether automatically by the item being garbage
60+ -- collected or manually via 'remove')
61+ -> IO WeakBagTicket -- ^ Returns a 'WeakBagTicket' that ensures the item
62+ -- is retained and allows the item to be removed.
63+insert a (WeakBag nextId children) wbRef finalizer = {-# SCC "insert" #-} do
64+ a' <- evaluate a
65+ wbRef' <- evaluate wbRef
66+ myId <- atomicModifyIORef' nextId $ \n -> (succ n, n)
67+ let cleanup = do
68+ wb <- readIORef wbRef'
69+ mb <- deRefWeak wb
70+ forM_ mb $ \b -> do
71+ csWithoutMe <- atomicModifyIORef children $ \cs ->
72+ let !csWithoutMe = IntMap.delete myId cs
73+ in (csWithoutMe, csWithoutMe)
74+ when (IntMap.null csWithoutMe) $ finalizer b
75+ return ()
76+ return ()
77+ wa <- mkWeakPtr a' $ Just cleanup
78+ atomicModifyIORef' children $ \cs -> (IntMap.insert myId wa cs, ())
79+ return $ WeakBagTicket
80+ { _weakBagTicket_weakItem = wa
81+ , _weakBagTicket_item = a'
82+ }
83+
84+-- | Create an empty 'WeakBag'.
85+{-# INLINE empty #-}
86+empty :: IO (WeakBag a)
87+empty = {-# SCC "empty" #-} do
88+ nextId <- newIORef 1
89+ children <- newIORef IntMap.empty
90+ let bag = WeakBag
91+ { _weakBag_nextId = nextId
92+ , _weakBag_children = children
93+ }
94+ return bag
95+
96+-- | Create a 'WeakBag' with one item; equivalent to creating the 'WeakBag' with
97+-- 'empty', then using 'insert'.
98+{-# INLINE singleton #-}
99+singleton :: a -> IORef (Weak b) -> (b -> IO ()) -> IO (WeakBag a, WeakBagTicket)
100+singleton a wbRef finalizer = {-# SCC "singleton" #-} do
101+ bag <- empty
102+ ticket <- insert a bag wbRef finalizer
103+ return (bag, ticket)
104+
105+{-# INLINE traverse #-}
106+-- | Visit every node in the given list. If new nodes are appended during the
107+-- traversal, they will not be visited. Every live node that was in the list
108+-- when the traversal began will be visited exactly once; however, no guarantee
109+-- is made about the order of the traversal.
110+traverse :: MonadIO m => WeakBag a -> (a -> m ()) -> m ()
111+traverse (WeakBag _ children) f = {-# SCC "traverse" #-} do
112+ cs <- liftIO $ readIORef children
113+ forM_ cs $ \c -> do
114+ ma <- liftIO $ deRefWeak c
115+ mapM_ f ma
116+
117+-- | Remove an item from the 'WeakBag'; does nothing if invoked multiple times
118+-- on the same 'WeakBagTicket'.
119+{-# INLINE remove #-}
120+remove :: WeakBagTicket -> IO ()
121+remove (WeakBagTicket w _) = {-# SCC "remove" #-} finalize w
122+--TODO: Should 'remove' also drop the reference to the item?
123+
124+--TODO: can/should we provide a null WeakBagTicket?
src/Reflex.hsnew file+31
@@ -0,0 +1,31 @@
1+{-# LANGUAGE CPP #-}
2+-- | This module exports all of the commonly-used functionality of Reflex; if
3+-- you are just getting started with Reflex, this is probably what you want.
4+module Reflex
5+ ( module X
6+ ) where
7+
8+import Reflex.Class as X
9+import Reflex.Collection as X
10+import Reflex.Dynamic as X
11+import Reflex.EventWriter.Base as X
12+import Reflex.EventWriter.Class as X
13+#ifdef USE_TEMPLATE_HASKELL
14+import Reflex.Dynamic.TH as X
15+#endif
16+import Reflex.Dynamic.Uniq as X
17+import Reflex.DynamicWriter.Base as X
18+import Reflex.DynamicWriter.Class as X
19+import Reflex.PerformEvent.Base as X
20+import Reflex.PerformEvent.Class as X
21+import Reflex.PostBuild.Base as X
22+import Reflex.PostBuild.Class as X
23+import Reflex.Profiled as X
24+import Reflex.Query.Base as X
25+import Reflex.Query.Class as X
26+import Reflex.Requester.Base as X
27+import Reflex.Requester.Class as X
28+import Reflex.Spider as X
29+import Reflex.Time as X
30+import Reflex.TriggerEvent.Base as X
31+import Reflex.TriggerEvent.Class as X
src/Reflex/Adjustable/Class.hsnew file+71
@@ -0,0 +1,71 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE FunctionalDependencies #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
5+{-# LANGUAGE RankNTypes #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE UndecidableInstances #-}
9+#ifdef USE_REFLEX_OPTIMIZER
10+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
11+#endif
12+module Reflex.Adjustable.Class
13+ (
14+ -- * The Adjustable typeclass
15+ Adjustable(..)
16+ , sequenceDMapWithAdjust
17+ , sequenceDMapWithAdjustWithMove
18+ , mapMapWithAdjustWithMove
19+ ) where
20+
21+import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
22+import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
23+import Data.Align
24+import Data.Dependent.Map (DMap, GCompare (..))
25+import Data.Functor.Constant
26+import Data.Functor.Misc
27+import Data.Map (Map)
28+import qualified Data.Map as Map
29+import Data.Map.Misc
30+import Data.These
31+
32+import Reflex.Class
33+import Reflex.Dynamic
34+import Reflex.PostBuild.Class
35+
36+-- | A 'Monad' that supports adjustment over time. After an action has been
37+-- run, if the given events fire, it will adjust itself so that its net effect
38+-- is as though it had originally been run with the new value. Note that there
39+-- is some issue here with persistent side-effects: obviously, IO (and some
40+-- other side-effects) cannot be undone, so it is up to the instance implementer
41+-- to determine what the best meaning for this class is in such cases.
42+class (Reflex t, Monad m) => Adjustable t m | m -> t where
43+ runWithReplace :: m a -> Event t (m b) -> m (a, Event t b)
44+ traverseIntMapWithKeyWithAdjust :: (IntMap.Key -> v -> m v') -> IntMap v -> Event t (PatchIntMap v) -> m (IntMap v', Event t (PatchIntMap v'))
45+ 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'))
46+ 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'))
47+
48+instance Adjustable t m => Adjustable t (ReaderT r m) where
49+ runWithReplace a0 a' = do
50+ r <- ask
51+ lift $ runWithReplace (runReaderT a0 r) $ fmap (`runReaderT` r) a'
52+ traverseIntMapWithKeyWithAdjust f dm0 dm' = do
53+ r <- ask
54+ lift $ traverseIntMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'
55+ traverseDMapWithKeyWithAdjust f dm0 dm' = do
56+ r <- ask
57+ lift $ traverseDMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'
58+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do
59+ r <- ask
60+ lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runReaderT (f k v) r) dm0 dm'
61+
62+sequenceDMapWithAdjust :: (GCompare k, Adjustable t m) => DMap k m -> Event t (PatchDMap k m) -> m (DMap k Identity, Event t (PatchDMap k Identity))
63+sequenceDMapWithAdjust = traverseDMapWithKeyWithAdjust $ \_ -> fmap Identity
64+
65+sequenceDMapWithAdjustWithMove :: (GCompare k, Adjustable t m) => DMap k m -> Event t (PatchDMapWithMove k m) -> m (DMap k Identity, Event t (PatchDMapWithMove k Identity))
66+sequenceDMapWithAdjustWithMove = traverseDMapWithKeyWithAdjustWithMove $ \_ -> fmap Identity
67+
68+mapMapWithAdjustWithMove :: forall t m k v v'. (Adjustable 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'))
69+mapMapWithAdjustWithMove f m0 m' = do
70+ (out0 :: DMap (Const2 k v) (Constant v'), out') <- traverseDMapWithKeyWithAdjustWithMove (\(Const2 k) (Identity v) -> Constant <$> f k v) (mapToDMap m0) (const2PatchDMapWithMoveWith Identity <$> m')
71+ return (dmapToMapWith (\(Constant v') -> v') out0, patchDMapWithMoveToPatchMapWithMoveWith (\(Constant v') -> v') <$> out')
src/Reflex/Class.hsnew file+1192
@@ -0,0 +1,1192 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE ConstraintKinds #-}
4+{-# LANGUAGE DefaultSignatures #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE FunctionalDependencies #-}
8+{-# LANGUAGE GADTs #-}
9+{-# LANGUAGE LambdaCase #-}
10+{-# LANGUAGE MultiParamTypeClasses #-}
11+{-# LANGUAGE NoMonomorphismRestriction #-}
12+{-# LANGUAGE RankNTypes #-}
13+{-# LANGUAGE RecursiveDo #-}
14+{-# LANGUAGE RoleAnnotations #-}
15+{-# LANGUAGE ScopedTypeVariables #-}
16+{-# LANGUAGE TypeFamilies #-}
17+{-# LANGUAGE TypeOperators #-}
18+{-# LANGUAGE UndecidableInstances #-}
19+#ifdef USE_REFLEX_OPTIMIZER
20+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
21+#endif
22+
23+-- | This module contains the Reflex interface, as well as a variety of
24+-- convenience functions for working with 'Event's, 'Behavior's, and other
25+-- signals.
26+module Reflex.Class
27+ ( module Reflex.Patch
28+ -- * Primitives
29+ , Reflex (..)
30+ , mergeInt
31+ , coerceBehavior
32+ , coerceEvent
33+ , coerceDynamic
34+ , MonadSample (..)
35+ , MonadHold (..)
36+ -- ** 'fan'-related types
37+ , EventSelector (..)
38+ , EventSelectorInt (..)
39+ -- ** 'Incremental'-related types
40+ -- * Convenience functions
41+ , constDyn
42+ , pushAlways
43+ -- ** Combining 'Event's
44+ , leftmost
45+ , mergeMap
46+ , mergeMapIncremental
47+ , mergeMapIncrementalWithMove
48+ , mergeIntMapIncremental
49+ , mergeList
50+ , mergeWith
51+ , difference
52+ , alignEventWithMaybe
53+ -- ** Breaking up 'Event's
54+ , splitE
55+ , fanEither
56+ , fanThese
57+ , fanMap
58+ , dmapToThese
59+ , EitherTag (..)
60+ , eitherToDSum
61+ , dsumToEither
62+ -- ** Collapsing 'Event . Event'
63+ , switchHold
64+ , switchHoldPromptly
65+ , switchHoldPromptOnly
66+ -- ** Using 'Event's to sample 'Behavior's
67+ , tag
68+ , attach
69+ , attachWith
70+ , attachWithMaybe
71+ -- ** Blocking an 'Event' based on a 'Behavior'
72+ , gate
73+ -- ** Combining 'Dynamic's
74+ , distributeDMapOverDynPure
75+ , distributeListOverDyn
76+ , distributeListOverDynWith
77+ , zipDyn
78+ , zipDynWith
79+ -- ** Accumulating state
80+ , Accumulator (..)
81+ , accumDyn
82+ , accumMDyn
83+ , accumMaybeDyn
84+ , accumMaybeMDyn
85+ , mapAccumDyn
86+ , mapAccumMDyn
87+ , mapAccumMaybeDyn
88+ , mapAccumMaybeMDyn
89+ , accumB
90+ , accumMB
91+ , accumMaybeB
92+ , accumMaybeMB
93+ , mapAccumB
94+ , mapAccumMB
95+ , mapAccumMaybeB
96+ , mapAccumMaybeMB
97+ , mapAccum_
98+ , mapAccumM_
99+ , mapAccumMaybe_
100+ , mapAccumMaybeM_
101+ , zipListWithEvent
102+ , numberOccurrences
103+ , numberOccurrencesFrom
104+ , numberOccurrencesFrom_
105+ , (<@>)
106+ , (<@)
107+ , tailE
108+ , headTailE
109+ , takeWhileE
110+ , switcher
111+ -- * Debugging functions
112+ , traceEvent
113+ , traceEventWith
114+ -- * Unsafe functions
115+ , unsafeDynamic
116+ , unsafeMapIncremental
117+ -- * 'FunctorMaybe'
118+ , FunctorMaybe (..)
119+ , fforMaybe
120+ , ffilter
121+ , filterLeft
122+ , filterRight
123+ -- * 'Adjustable'
124+ , Adjustable(..)
125+ , sequenceDMapWithAdjust
126+ , sequenceDMapWithAdjustWithMove
127+ , mapMapWithAdjustWithMove
128+ -- * Miscellaneous convenience functions
129+ , ffor
130+ -- * Deprecated functions
131+ , MonadAdjust
132+ , appendEvents
133+ , onceE
134+ , sequenceThese
135+ , fmapMaybeCheap
136+ , fmapCheap
137+ , fforCheap
138+ , fforMaybeCheap
139+ , pushAlwaysCheap
140+ , tagCheap
141+ , mergeWithCheap
142+ , mergeWithCheap'
143+ , switchPromptly
144+ , switchPromptOnly
145+ -- * Slow, but general, implementations
146+ , slowHeadE
147+ ) where
148+
149+import Control.Applicative
150+import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
151+import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
152+import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
153+import Control.Monad.Trans.Cont (ContT)
154+import Control.Monad.Trans.Except (ExceptT)
155+import Control.Monad.Trans.RWS (RWST)
156+import Control.Monad.Trans.Writer (WriterT)
157+import Data.Align
158+import Data.Bifunctor
159+import Data.Coerce
160+import Data.Default
161+import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
162+import qualified Data.Dependent.Map as DMap
163+import Data.Either
164+import Data.FastMutableIntMap (PatchIntMap)
165+import Data.Foldable
166+import Data.Functor.Bind hiding (join)
167+import qualified Data.Functor.Bind as Bind
168+import Data.Functor.Constant
169+import Data.Functor.Misc
170+import Data.Functor.Plus
171+import Data.IntMap.Strict (IntMap)
172+import qualified Data.IntMap.Strict as IntMap
173+import Data.List.NonEmpty (NonEmpty (..))
174+import Data.Map (Map)
175+import Data.Maybe
176+import Data.Monoid hiding (Alt, (<>))
177+import Data.Semigroup (Semigroup, sconcat, stimes, (<>))
178+import Data.String
179+import Data.These
180+import Data.Traversable
181+import Data.Type.Coercion
182+import Reflex.FunctorMaybe
183+import Reflex.Patch
184+
185+-- Note: must come last to silence warnings due to AMP on GHC < 7.10
186+import Prelude hiding (foldl, mapM, mapM_, sequence, sequence_)
187+
188+import Debug.Trace (trace)
189+
190+-- | The 'Reflex' class contains all the primitive functionality needed for
191+-- Functional Reactive Programming (FRP). The @t@ type parameter indicates
192+-- which "timeline" is in use. Timelines are fully-independent FRP contexts,
193+-- and the type of the timeline determines the FRP engine to be used. For most
194+-- purposes, the 'Reflex.Spider' implementation is recommended.
195+class ( MonadHold t (PushM t)
196+ , MonadSample t (PullM t)
197+ , MonadFix (PushM t)
198+ , Functor (Dynamic t)
199+ , Applicative (Dynamic t) -- Necessary for GHC <= 7.8
200+ , Monad (Dynamic t)
201+ ) => Reflex t where
202+ -- | A container for a value that can change over time. 'Behavior's can be
203+ -- sampled at will, but it is not possible to be notified when they change
204+ data Behavior t :: * -> *
205+ -- | A stream of occurrences. During any given frame, an 'Event' is either
206+ -- occurring or not occurring; if it is occurring, it will contain a value of
207+ -- the given type (its "occurrence type")
208+ data Event t :: * -> *
209+ -- | A container for a value that can change over time and allows
210+ -- notifications on changes. Basically a combination of a 'Behavior' and an
211+ -- 'Event', with a rule that the 'Behavior' will change if and only if the
212+ -- 'Event' fires.
213+ data Dynamic t :: * -> *
214+ -- | An 'Incremental' is a more general form of a 'Dynamic'.
215+ -- Instead of always fully replacing the value, only parts of it can be patched.
216+ -- This is only needed for performance critical code via `mergeIncremental` to make small
217+ -- changes to large values.
218+ data Incremental t :: * -> *
219+ -- | A monad for doing complex push-based calculations efficiently
220+ type PushM t :: * -> *
221+ -- | A monad for doing complex pull-based calculations efficiently
222+ type PullM t :: * -> *
223+ -- | An 'Event' with no occurrences
224+ never :: Event t a
225+ -- | Create a 'Behavior' that always has the given value
226+ constant :: a -> Behavior t a --TODO: Refactor to use 'pure' from Applicative instead; however, we need to make sure that encouraging Applicative-style use of 'Behavior's doesn't have a negative performance impact
227+ -- | Create an 'Event' from another 'Event'; the provided function can sample
228+ -- 'Behavior's and hold 'Event's, and use the results to produce a occurring
229+ -- (Just) or non-occurring (Nothing) result
230+ push :: (a -> PushM t (Maybe b)) -> Event t a -> Event t b
231+ -- | Like 'push' but intended for functions that the implementation can consider cheap to compute for performance considerations. WARNING: The function passed to 'pushCheap' may be run multiple times without any caching.
232+ pushCheap :: (a -> PushM t (Maybe b)) -> Event t a -> Event t b
233+ -- | Create a 'Behavior' by reading from other 'Behavior's; the result will be
234+ -- recomputed whenever any of the read 'Behavior's changes
235+ pull :: PullM t a -> Behavior t a
236+ -- | Merge a collection of events; the resulting 'Event' will only occur if at
237+ -- least one input event is occuring, and will contain all of the input keys
238+ -- that are occurring simultaneously
239+ 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
240+ -- | Efficiently fan-out an event to many destinations. This function should
241+ -- be partially applied, and then the result applied repeatedly to create
242+ -- child events
243+ 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
244+ -- | Create an 'Event' that will occur whenever the currently-selected input
245+ -- 'Event' occurs
246+ switch :: Behavior t (Event t a) -> Event t a
247+ -- | Create an 'Event' that will occur whenever the input event is occurring
248+ -- and its occurrence value, another 'Event', is also occurring
249+ coincidence :: Event t (Event t a) -> Event t a
250+ -- | Extract the 'Behavior' of a 'Dynamic'.
251+ current :: Dynamic t a -> Behavior t a
252+ -- | Extract the 'Event' of the 'Dynamic'.
253+ updated :: Dynamic t a -> Event t a
254+ -- | Create a new 'Dynamic'. The given 'PullM' must always return the most
255+ -- recent firing of the given 'Event', if any.
256+ unsafeBuildDynamic :: PullM t a -> Event t a -> Dynamic t a
257+ -- | Create a new 'Incremental'. The given 'PullM''s value must always change
258+ -- in the same way that the accumulated application of patches would change
259+ -- that value.
260+ unsafeBuildIncremental :: Patch p => PullM t (PatchTarget p) -> Event t p -> Incremental t p
261+ -- | Create a merge whose parents can change over time
262+ mergeIncremental :: GCompare k => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)
263+ -- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental
264+ mergeIncrementalWithMove :: GCompare k => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)
265+ -- | Extract the 'Behavior' component of an 'Incremental'
266+ currentIncremental :: Patch p => Incremental t p -> Behavior t (PatchTarget p)
267+ -- | Extract the 'Event' component of an 'Incremental'
268+ updatedIncremental :: Patch p => Incremental t p -> Event t p
269+ -- | Convert an 'Incremental' to a 'Dynamic'
270+ incrementalToDynamic :: Patch p => Incremental t p -> Dynamic t (PatchTarget p)
271+ -- | Construct a 'Coercion' for a 'Behavior' given an 'Coercion' for its
272+ -- occurrence type
273+ behaviorCoercion :: Coercion a b -> Coercion (Behavior t a) (Behavior t b)
274+ -- | Construct a 'Coercion' for an 'Event' given an 'Coercion' for its
275+ -- occurrence type
276+ eventCoercion :: Coercion a b -> Coercion (Event t a) (Event t b)
277+ -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its
278+ -- occurrence type
279+ dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)
280+ mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)
281+ fanInt :: Event t (IntMap a) -> EventSelectorInt t a
282+
283+--TODO: Specialize this so that we can take advantage of knowing that there's no changing going on
284+mergeInt :: Reflex t => IntMap (Event t a) -> Event t (IntMap a)
285+mergeInt m = mergeIntIncremental $ unsafeBuildIncremental (return m) never
286+
287+-- | Coerce a 'Behavior' between representationally-equivalent value types
288+coerceBehavior :: (Reflex t, Coercible a b) => Behavior t a -> Behavior t b
289+coerceBehavior = coerceWith $ behaviorCoercion Coercion
290+
291+-- | Coerce an 'Event' between representationally-equivalent occurrence types
292+coerceEvent :: (Reflex t, Coercible a b) => Event t a -> Event t b
293+coerceEvent = coerceWith $ eventCoercion Coercion
294+
295+-- | Coerce a 'Dynamic' between representationally-equivalent value types
296+coerceDynamic :: (Reflex t, Coercible a b) => Dynamic t a -> Dynamic t b
297+coerceDynamic = coerceWith $ dynamicCoercion Coercion
298+
299+-- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'. The 'Behavior'
300+-- _must_ change when and only when the 'Event' fires, such that the
301+-- 'Behavior''s value is always equal to the most recent firing of the 'Event';
302+-- if this is not the case, the resulting 'Dynamic' will behave
303+-- nondeterministically.
304+unsafeDynamic :: Reflex t => Behavior t a -> Event t a -> Dynamic t a
305+unsafeDynamic = unsafeBuildDynamic . sample
306+
307+-- | Construct a 'Dynamic' value that never changes
308+constDyn :: Reflex t => a -> Dynamic t a
309+constDyn = pure
310+
311+instance (Reflex t, Default a) => Default (Dynamic t a) where
312+ def = pure def
313+
314+-- | 'MonadSample' designates monads that can read the current value of a
315+-- 'Behavior'. This includes both 'PullM' and 'PushM'.
316+class (Applicative m, Monad m) => MonadSample t m | m -> t where
317+ -- | Get the current value in the 'Behavior'
318+ sample :: Behavior t a -> m a
319+
320+-- | 'MonadHold' designates monads that can create new 'Behavior's based on
321+-- 'Event's; usually this will be 'PushM' or a monad based on it. 'MonadHold'
322+-- is required to create any stateful computations with Reflex.
323+class MonadSample t m => MonadHold t m where
324+ -- | Create a new 'Behavior' whose value will initially be equal to the given
325+ -- value and will be updated whenever the given 'Event' occurs. The update
326+ -- takes effect immediately after the 'Event' occurs; if the occurrence that
327+ -- sets the 'Behavior' (or one that is simultaneous with it) is used to sample
328+ -- the 'Behavior', it will see the _old_ value of the 'Behavior', not the new
329+ -- one.
330+ hold :: a -> Event t a -> m (Behavior t a)
331+ default hold :: (m ~ f m', MonadTrans f, MonadHold t m') => a -> Event t a -> m (Behavior t a)
332+ hold v0 = lift . hold v0
333+ -- | Create a 'Dynamic' value using the given initial value that changes every
334+ -- time the 'Event' occurs.
335+ holdDyn :: a -> Event t a -> m (Dynamic t a)
336+ default holdDyn :: (m ~ f m', MonadTrans f, MonadHold t m') => a -> Event t a -> m (Dynamic t a)
337+ holdDyn v0 = lift . holdDyn v0
338+ -- | Create an 'Incremental' value using the given initial value that changes
339+ -- every time the 'Event' occurs.
340+ holdIncremental :: Patch p => PatchTarget p -> Event t p -> m (Incremental t p)
341+ default holdIncremental :: (Patch p, m ~ f m', MonadTrans f, MonadHold t m') => PatchTarget p -> Event t p -> m (Incremental t p)
342+ holdIncremental v0 = lift . holdIncremental v0
343+ buildDynamic :: PullM t a -> Event t a -> m (Dynamic t a)
344+ {-
345+ default buildDynamic :: (m ~ f m', MonadTrans f, MonadHold t m') => PullM t a -> Event t a -> m (Dynamic t a)
346+ buildDynamic getV0 = lift . buildDynamic getV0
347+ -}
348+ -- | Create a new 'Event' that only occurs only once, on the first occurence of
349+ -- the supplied 'Event'.
350+ headE :: Event t a -> m (Event t a)
351+
352+
353+slowHeadE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
354+slowHeadE e = do
355+ rec be <- hold e $ fmapCheap (const never) e'
356+ let e' = switch be
357+ return e'
358+
359+-- | An 'EventSelector' allows you to efficiently 'select' an 'Event' based on a
360+-- key. This is much more efficient than filtering for each key with
361+-- 'fmapMaybe'.
362+newtype EventSelector t k = EventSelector
363+ { -- | Retrieve the 'Event' for the given key. The type of the 'Event' is
364+ -- determined by the type of the key, so this can be used to fan-out
365+ -- 'Event's whose sub-'Event's have different types.
366+ --
367+ -- Using 'EventSelector's and the 'fan' primitive is far more efficient than
368+ -- (but equivalent to) using 'fmapMaybe' to select only the relevant
369+ -- occurrences of an 'Event'.
370+ select :: forall a. k a -> Event t a
371+ }
372+
373+newtype EventSelectorInt t a = EventSelectorInt { selectInt :: Int -> Event t a }
374+
375+--------------------------------------------------------------------------------
376+-- Instances
377+--------------------------------------------------------------------------------
378+
379+instance MonadSample t m => MonadSample t (ReaderT r m) where
380+ sample = lift . sample
381+
382+instance MonadHold t m => MonadHold t (ReaderT r m) where
383+ hold a0 = lift . hold a0
384+ holdDyn a0 = lift . holdDyn a0
385+ holdIncremental a0 = lift . holdIncremental a0
386+ buildDynamic a0 = lift . buildDynamic a0
387+ headE = lift . headE
388+
389+instance (MonadSample t m, Monoid r) => MonadSample t (WriterT r m) where
390+ sample = lift . sample
391+
392+instance (MonadHold t m, Monoid r) => MonadHold t (WriterT r m) where
393+ hold a0 = lift . hold a0
394+ holdDyn a0 = lift . holdDyn a0
395+ holdIncremental a0 = lift . holdIncremental a0
396+ buildDynamic a0 = lift . buildDynamic a0
397+ headE = lift . headE
398+
399+instance MonadSample t m => MonadSample t (StateT s m) where
400+ sample = lift . sample
401+
402+instance MonadHold t m => MonadHold t (StateT s m) where
403+ hold a0 = lift . hold a0
404+ holdDyn a0 = lift . holdDyn a0
405+ holdIncremental a0 = lift . holdIncremental a0
406+ buildDynamic a0 = lift . buildDynamic a0
407+ headE = lift . headE
408+
409+instance MonadSample t m => MonadSample t (ExceptT e m) where
410+ sample = lift . sample
411+
412+instance MonadHold t m => MonadHold t (ExceptT e m) where
413+ hold a0 = lift . hold a0
414+ holdDyn a0 = lift . holdDyn a0
415+ holdIncremental a0 = lift . holdIncremental a0
416+ buildDynamic a0 = lift . buildDynamic a0
417+ headE = lift . headE
418+
419+instance (MonadSample t m, Monoid w) => MonadSample t (RWST r w s m) where
420+ sample = lift . sample
421+
422+instance (MonadHold t m, Monoid w) => MonadHold t (RWST r w s m) where
423+ hold a0 = lift . hold a0
424+ holdDyn a0 = lift . holdDyn a0
425+ holdIncremental a0 = lift . holdIncremental a0
426+ buildDynamic a0 = lift . buildDynamic a0
427+ headE = lift . headE
428+
429+instance MonadSample t m => MonadSample t (ContT r m) where
430+ sample = lift . sample
431+
432+instance MonadHold t m => MonadHold t (ContT r m) where
433+ hold a0 = lift . hold a0
434+ holdDyn a0 = lift . holdDyn a0
435+ holdIncremental a0 = lift . holdIncremental a0
436+ buildDynamic a0 = lift . buildDynamic a0
437+ headE = lift . headE
438+
439+--------------------------------------------------------------------------------
440+-- Convenience functions
441+--------------------------------------------------------------------------------
442+
443+-- | Create an 'Event' from another 'Event'. The provided function can sample
444+-- 'Behavior's and hold 'Event's.
445+pushAlways :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b
446+pushAlways f = push (fmap Just . f)
447+
448+-- | Flipped version of 'fmap'.
449+ffor :: Functor f => f a -> (a -> b) -> f b
450+ffor = flip fmap
451+
452+instance Reflex t => Applicative (Behavior t) where
453+ pure = constant
454+ f <*> x = pull $ sample f `ap` sample x
455+ _ *> b = b
456+ a <* _ = a
457+
458+instance Reflex t => Apply (Behavior t) where
459+ (<.>) = (<*>)
460+
461+instance Reflex t => Bind (Behavior t) where
462+ (>>-) = (>>=)
463+
464+instance (Reflex t, Fractional a) => Fractional (Behavior t a) where
465+ (/) = liftA2 (/)
466+ fromRational = pure . fromRational
467+ recip = fmap recip
468+
469+instance Reflex t => Functor (Behavior t) where
470+ fmap f = pull . fmap f . sample
471+
472+instance (Reflex t, IsString a) => IsString (Behavior t a) where
473+ fromString = pure . fromString
474+
475+instance Reflex t => Monad (Behavior t) where
476+ a >>= f = pull $ sample a >>= sample . f
477+ -- 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.
478+ return = constant
479+ fail = error "Monad (Behavior t) does not support fail"
480+
481+instance (Reflex t, Monoid a) => Monoid (Behavior t a) where
482+ mempty = constant mempty
483+ mappend a b = pull $ liftM2 mappend (sample a) (sample b)
484+ mconcat = pull . fmap mconcat . mapM sample
485+
486+instance (Reflex t, Num a) => Num (Behavior t a) where
487+ (+) = liftA2 (+)
488+ (-) = liftA2 (-)
489+ (*) = liftA2 (*)
490+ abs = fmap abs
491+ fromInteger = pure . fromInteger
492+ negate = fmap negate
493+ signum = fmap signum
494+
495+instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where
496+ a <> b = pull $ liftM2 (<>) (sample a) (sample b)
497+ sconcat = pull . fmap sconcat . mapM sample
498+#if MIN_VERSION_semigroups(0,17,0)
499+ stimes n = fmap $ stimes n
500+#else
501+ times1p n = fmap $ times1p n
502+#endif
503+
504+-- | Flipped version of 'fmapMaybe'.
505+fforMaybe :: FunctorMaybe f => f a -> (a -> Maybe b) -> f b
506+fforMaybe = flip fmapMaybe
507+
508+-- | Filter 'f a' using the provided predicate.
509+-- Relies on 'fforMaybe'.
510+ffilter :: FunctorMaybe f => (a -> Bool) -> f a -> f a
511+ffilter f = fmapMaybe $ \x -> if f x then Just x else Nothing
512+
513+-- | Filter 'Left's from 'f (Either a b)' into 'a'.
514+filterLeft :: FunctorMaybe f => f (Either a b) -> f a
515+filterLeft = fmapMaybe (either Just (const Nothing))
516+
517+-- | Filter 'Right's from 'f (Either a b)' into 'b'.
518+filterRight :: FunctorMaybe f => f (Either a b) -> f b
519+filterRight = fmapMaybe (either (const Nothing) Just)
520+
521+-- | Left-biased event union (prefers left event on simultaneous
522+-- occurrence).
523+instance Reflex t => Alt (Event t) where
524+ ev1 <!> ev2 = leftmost [ev1, ev2]
525+
526+-- | 'Event' intersection (convenient interface to 'coincidence').
527+instance Reflex t => Apply (Event t) where
528+ evf <.> evx = coincidence (fmap (<$> evx) evf)
529+
530+-- | 'Event' intersection (convenient interface to 'coincidence').
531+instance Reflex t => Bind (Event t) where
532+ evx >>- f = coincidence (f <$> evx)
533+ join = coincidence
534+
535+instance Reflex t => Functor (Event t) where
536+ {-# INLINE fmap #-}
537+ fmap f = fmapMaybe $ Just . f
538+ {-# INLINE (<$) #-}
539+ x <$ e = fmapCheap (const x) e
540+
541+instance Reflex t => FunctorMaybe (Event t) where
542+ {-# INLINE fmapMaybe #-}
543+ fmapMaybe f = push $ return . f
544+
545+-- | Never: @'zero' = 'never'@.
546+instance Reflex t => Plus (Event t) where
547+ zero = never
548+
549+-- | Replace each occurrence value of the 'Event' with the value of the
550+-- 'Behavior' at the time of that occurrence.
551+tag :: Reflex t => Behavior t b -> Event t a -> Event t b
552+tag b = pushAlways $ \_ -> sample b
553+
554+-- | Create a new 'Event' that combines occurences of supplied 'Event' with the
555+-- current value of the 'Behavior'.
556+attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b)
557+attach = attachWith (,)
558+
559+-- | Create a new 'Event' that occurs when the supplied 'Event' occurs by
560+-- combining it with the current value of the 'Behavior'.
561+attachWith :: Reflex t => (a -> b -> c) -> Behavior t a -> Event t b -> Event t c
562+attachWith f = attachWithMaybe $ \a b -> Just $ f a b
563+
564+-- | Create a new 'Event' by combining each occurence with the current value of
565+-- the 'Behavior'. The occurrence is discarded if the combining function returns
566+-- Nothing
567+attachWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c
568+attachWithMaybe f b e = flip push e $ \o -> (`f` o) <$> sample b
569+
570+-- | Create a new 'Event' that occurs on all but the first occurence of the
571+-- supplied 'Event'.
572+tailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
573+tailE e = snd <$> headTailE e
574+
575+-- | Create a tuple of two 'Event's with the first one occuring only the first
576+-- time the supplied 'Event' occurs and the second occuring on all but the first
577+-- occurence.
578+headTailE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a, Event t a)
579+headTailE e = do
580+ eHead <- headE e
581+ be <- hold never $ fmap (const e) eHead
582+ return (eHead, switch be)
583+
584+-- | Starting at the current time, fire all the occurrences of the 'Event' for
585+-- which the given predicate returns 'True'. When 'False' is returned, do not
586+-- fire, and permanently stop firing, even if 'True' values are encountered
587+-- later.
588+takeWhileE :: forall t m a. (Reflex t, MonadFix m, MonadHold t m) => (a -> Bool) -> Event t a -> m (Event t a)
589+takeWhileE f e = do
590+ rec let (eFalse, eTrue) = fanEither $ ffor e' $ \a -> if f a
591+ then Right a
592+ else Left never
593+ be <- hold e eFalse
594+ let e' = switch be
595+ return eTrue
596+
597+-- | Split the supplied 'Event' into two individual 'Event's occuring at the
598+-- same time with the respective values from the tuple.
599+splitE :: Reflex t => Event t (a, b) -> (Event t a, Event t b)
600+splitE e = (fmap fst e, fmap snd e)
601+
602+-- | Print the supplied 'String' and the value of the 'Event' on each
603+-- occurence. This should /only/ be used for debugging.
604+--
605+-- Note: As with Debug.Trace.trace, the message will only be printed if the
606+-- 'Event' is actually used.
607+traceEvent :: (Reflex t, Show a) => String -> Event t a -> Event t a
608+traceEvent s = traceEventWith $ \x -> s <> ": " <> show x
609+
610+-- | Print the output of the supplied function on each occurence of the
611+-- 'Event'. This should /only/ be used for debugging.
612+--
613+-- Note: As with Debug.Trace.trace, the message will only be printed if the
614+-- 'Event' is actually used.
615+traceEventWith :: Reflex t => (a -> String) -> Event t a -> Event t a
616+traceEventWith f = push $ \x -> trace (f x) $ return $ Just x
617+
618+instance (Semigroup a, Reflex t) => Semigroup (Event t a) where
619+ (<>) = alignWith (mergeThese (<>))
620+ sconcat = fmap sconcat . mergeList . toList
621+#if MIN_VERSION_semigroups(0,17,0)
622+ stimes n = fmap $ stimes n
623+#else
624+ times1p n = fmap $ times1p n
625+#endif
626+
627+instance (Semigroup a, Reflex t) => Monoid (Event t a) where
628+ mempty = never
629+ mappend = (<>)
630+ mconcat = fmap sconcat . mergeList
631+
632+-- | Create a new 'Event' that occurs if at least one of the 'Event's in the
633+-- list occurs. If multiple occur at the same time they are folded from the left
634+-- with the given function.
635+{-# INLINE mergeWith #-}
636+mergeWith :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a
637+mergeWith = mergeWith' id
638+
639+{-# INLINE mergeWith' #-}
640+mergeWith' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b
641+mergeWith' f g es = fmap (Prelude.foldl1 g . fmap f)
642+ . mergeInt
643+ . IntMap.fromDistinctAscList
644+ $ zip [0 :: Int ..] es
645+
646+-- | Create a new 'Event' that occurs if at least one of the 'Event's in the
647+-- list occurs. If multiple occur at the same time the value is the value of the
648+-- leftmost event.
649+{-# INLINE leftmost #-}
650+leftmost :: Reflex t => [Event t a] -> Event t a
651+leftmost = mergeWith const
652+
653+-- | Create a new 'Event' that occurs if at least one of the 'Event's in the
654+-- list occurs and has a list of the values of all 'Event's occuring at that
655+-- time.
656+mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a)
657+mergeList [] = never
658+mergeList es = mergeWithFoldCheap' id es
659+
660+unsafeMapIncremental :: (Reflex t, Patch p, Patch p') => (PatchTarget p -> PatchTarget p') -> (p -> p') -> Incremental t p -> Incremental t p'
661+unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ g <$> updatedIncremental a
662+
663+-- | Create a new 'Event' combining the map of 'Event's into an 'Event' that
664+-- occurs if at least one of them occurs and has a map of values of all 'Event's
665+-- occuring at that time.
666+mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a)
667+mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap
668+
669+-- | Create a merge whose parents can change over time
670+mergeMapIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Event t a)) -> Event t (Map k a)
671+mergeMapIncremental = fmap dmapToMap . mergeIncremental . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWith id)
672+
673+-- | Create a merge whose parents can change over time
674+mergeIntMapIncremental :: Reflex t => Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)
675+mergeIntMapIncremental = fmap dmapToIntMap . mergeIncremental . unsafeMapIncremental intMapWithFunctorToDMap (const2IntPatchDMapWith id)
676+
677+-- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental
678+mergeMapIncrementalWithMove :: (Reflex t, Ord k) => Incremental t (PatchMapWithMove k (Event t a)) -> Event t (Map k a)
679+mergeMapIncrementalWithMove = fmap dmapToMap . mergeIncrementalWithMove . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWithMoveWith id)
680+
681+-- | Split the event into separate events for 'Left' and 'Right' values.
682+fanEither :: Reflex t => Event t (Either a b) -> (Event t a, Event t b)
683+fanEither e =
684+ let justLeft = either Just (const Nothing)
685+ justRight = either (const Nothing) Just
686+ in (fmapMaybe justLeft e, fmapMaybe justRight e)
687+
688+-- | Split the event into separate events for 'This' and 'That' values,
689+-- allowing them to fire simultaneously when the input value is 'These'.
690+fanThese :: Reflex t => Event t (These a b) -> (Event t a, Event t b)
691+fanThese e =
692+ let this (This x) = Just x
693+ this (These x _) = Just x
694+ this _ = Nothing
695+ that (That y) = Just y
696+ that (These _ y) = Just y
697+ that _ = Nothing
698+ in (fmapMaybe this e, fmapMaybe that e)
699+
700+-- | Split the event into an 'EventSelector' that allows efficient selection of
701+-- the individual 'Event's.
702+fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a)
703+fanMap = fan . fmap mapToDMap
704+
705+-- | Switches to the new event whenever it receives one. Only the old event is
706+-- considered the moment a new one is switched in; the output event will fire at
707+-- that moment if only if the old event does.
708+--
709+-- Because the simultaneous firing case is irrelevant, this function imposes
710+-- laxer "timing requirements" on the overall circuit, avoiding many potential
711+-- cyclic dependency / metastability failures. It's also more performant. Use
712+-- this rather than 'switchHoldPromptly' and 'switchHoldPromptOnly' unless you
713+-- are absolutely sure you need to act on the new event in the coincidental
714+-- case.
715+switchHold :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)
716+switchHold ea0 eea = switch <$> hold ea0 eea
717+
718+-- | Switches to the new event whenever it receives one. Whenever a new event is
719+-- provided, if it is firing, its value will be the resulting event's value; if
720+-- it is not firing, but the old one is, the old one's value will be used.
721+--
722+-- 'switchHold', by always forwarding the old event the moment it is switched
723+-- out, avoids many potential cyclic dependency problems / metastability
724+-- problems. It's also more performant. Use it instead unless you are sure you
725+-- cannot.
726+switchHoldPromptly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)
727+switchHoldPromptly ea0 eea = do
728+ bea <- hold ea0 eea
729+ let eLag = switch bea
730+ eCoincidences = coincidence eea
731+ return $ leftmost [eCoincidences, eLag]
732+
733+-- | switches to a new event whenever it receives one. At the moment of
734+-- switching, the old event will be ignored if it fires, and the new one will be
735+-- used if it fires; this is the opposite of 'switch', which will use only the
736+-- old value.
737+--
738+-- 'switchHold', by always forwarding the old event the moment it is switched
739+-- out, avoids many potential cyclic dependency problems / metastability
740+-- problems. It's also more performant. Use it instead unless you are sure you
741+-- cannot.
742+switchHoldPromptOnly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)
743+switchHoldPromptOnly e0 e' = do
744+ eLag <- switch <$> hold e0 e'
745+ return $ coincidence $ leftmost [e', eLag <$ eLag]
746+
747+instance Reflex t => Align (Event t) where
748+ nil = never
749+ align = alignEventWithMaybe Just
750+
751+-- | Create a new 'Event' that only occurs if the supplied 'Event' occurs and
752+-- the 'Behavior' is true at the time of occurence.
753+gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a
754+gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing
755+
756+-- | Create a new behavior given a starting behavior and switch to a the behvior
757+-- carried by the event when it fires.
758+switcher :: (Reflex t, MonadHold t m)
759+ => Behavior t a -> Event t (Behavior t a) -> m (Behavior t a)
760+switcher b eb = pull . (sample <=< sample) <$> hold b eb
761+
762+instance (Reflex t, IsString a) => IsString (Dynamic t a) where
763+ fromString = pure . fromString
764+
765+-- | Combine two 'Dynamic's. The result will change whenever either (or both)
766+-- input 'Dynamic' changes. Equivalent to @zipDynWith (,)@.
767+zipDyn :: Reflex t => Dynamic t a -> Dynamic t b -> Dynamic t (a, b)
768+zipDyn = zipDynWith (,)
769+
770+-- | Combine two 'Dynamic's with a combining function. The result will change
771+-- whenever either (or both) input 'Dynamic' changes.
772+-- More efficient than liftA2.
773+zipDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> Dynamic t c
774+zipDynWith f da db =
775+ let eab = align (updated da) (updated db)
776+ ec = flip push eab $ \o -> do
777+ (a, b) <- case o of
778+ This a -> do
779+ b <- sample $ current db
780+ return (a, b)
781+ That b -> do
782+ a <- sample $ current da
783+ return (a, b)
784+ These a b -> return (a, b)
785+ return $ Just $ f a b
786+ in unsafeBuildDynamic (f <$> sample (current da) <*> sample (current db)) ec
787+
788+instance (Reflex t, Semigroup a) => Semigroup (Dynamic t a) where
789+ (<>) = zipDynWith (<>)
790+#if MIN_VERSION_semigroups(0,17,0)
791+ stimes n = fmap $ stimes n
792+#else
793+ times1p n = fmap $ times1p n
794+#endif
795+
796+instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where
797+ mconcat = distributeListOverDynWith mconcat
798+ mempty = constDyn mempty
799+ mappend = zipDynWith mappend
800+
801+-- | This function converts a 'DMap' whose elements are 'Dynamic's into a
802+-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same
803+-- through the use of multiple uses of 'zipWithDyn' or 'Applicative' operators.
804+distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity)
805+distributeDMapOverDynPure dm = case DMap.toList dm of
806+ [] -> constDyn DMap.empty
807+ [k :=> v] -> fmap (DMap.singleton k . Identity) v
808+ _ ->
809+ let getInitial = DMap.traverseWithKey (\_ -> fmap Identity . sample . current) dm
810+ edmPre = merge $ DMap.map updated dm
811+ result = unsafeBuildDynamic getInitial $ flip pushAlways edmPre $ \news -> do
812+ olds <- sample $ current result
813+ return $ DMap.unionWithKey (\_ _ new -> new) olds news
814+ in result
815+
816+-- | Convert a list of 'Dynamic's into a 'Dynamic' list.
817+distributeListOverDyn :: Reflex t => [Dynamic t a] -> Dynamic t [a]
818+distributeListOverDyn = distributeListOverDynWith id
819+
820+-- | Create a new 'Dynamic' by applying a combining function to a list of 'Dynamic's
821+distributeListOverDynWith :: Reflex t => ([a] -> b) -> [Dynamic t a] -> Dynamic t b
822+distributeListOverDynWith f = fmap (f . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList) . distributeDMapOverDynPure . DMap.fromList . map (\(k, v) -> Const2 k :=> v) . zip [0 :: Int ..]
823+
824+-- | Create a new 'Event' that occurs when the first supplied 'Event' occurs
825+-- unless the second supplied 'Event' occurs simultaneously.
826+difference :: Reflex t => Event t a -> Event t b -> Event t a
827+difference = alignEventWithMaybe $ \case
828+ This a -> Just a
829+ _ -> Nothing
830+
831+alignEventWithMaybe :: Reflex t => (These a b -> Maybe c) -> Event t a -> Event t b -> Event t c
832+alignEventWithMaybe f ea eb =
833+ fmapMaybe (f <=< dmapToThese)
834+ $ merge
835+ $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]
836+
837+
838+--------------------------------------------------------------------------------
839+-- Accumulator
840+--------------------------------------------------------------------------------
841+
842+-- | An 'Accumulator' type can be built by accumulating occurrences of an
843+-- 'Event'.
844+#if __GLASGOW_HASKELL__ < 802
845+{-# WARNING accum "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-}
846+{-# WARNING accumM "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-}
847+{-# WARNING accumMaybe "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-}
848+{-# WARNING accumMaybeM "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-}
849+#endif
850+class Reflex t => Accumulator t f | f -> t where
851+ accum :: (MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (f a)
852+ accum f = accumMaybe $ \v o -> Just $ f v o
853+ accumM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t a) -> a -> Event t b -> m (f a)
854+ accumM f = accumMaybeM $ \v o -> Just <$> f v o
855+ accumMaybe :: (MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (f a)
856+ accumMaybe f = accumMaybeM $ \v o -> return $ f v o
857+ accumMaybeM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (f a)
858+ mapAccum :: (MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (f a, Event t c)
859+ mapAccum f = mapAccumMaybe $ \v o -> bimap Just Just $ f v o
860+ mapAccumM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (f a, Event t c)
861+ mapAccumM f = mapAccumMaybeM $ \v o -> bimap Just Just <$> f v o
862+ mapAccumMaybe :: (MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (f a, Event t c)
863+ mapAccumMaybe f = mapAccumMaybeM $ \v o -> return $ f v o
864+ mapAccumMaybeM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (f a, Event t c)
865+
866+accumDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (Dynamic t a)
867+accumDyn f = accumMaybeDyn $ \v o -> Just $ f v o
868+accumMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t a) -> a -> Event t b -> m (Dynamic t a)
869+accumMDyn f = accumMaybeMDyn $ \v o -> Just <$> f v o
870+accumMaybeDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (Dynamic t a)
871+accumMaybeDyn f = accumMaybeMDyn $ \v o -> return $ f v o
872+accumMaybeMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (Dynamic t a)
873+accumMaybeMDyn f z e = do
874+ rec let e' = flip push e $ \o -> do
875+ v <- sample $ current d'
876+ f v o
877+ d' <- holdDyn z e'
878+ return d'
879+mapAccumDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (Dynamic t a, Event t c)
880+mapAccumDyn f = mapAccumMaybeDyn $ \v o -> bimap Just Just $ f v o
881+mapAccumMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (Dynamic t a, Event t c)
882+mapAccumMDyn f = mapAccumMaybeMDyn $ \v o -> bimap Just Just <$> f v o
883+mapAccumMaybeDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (Dynamic t a, Event t c)
884+mapAccumMaybeDyn f = mapAccumMaybeMDyn $ \v o -> return $ f v o
885+mapAccumMaybeMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (Dynamic t a, Event t c)
886+mapAccumMaybeMDyn f z e = do
887+ rec let e' = flip push e $ \o -> do
888+ v <- sample $ current d'
889+ result <- f v o
890+ return $ case result of
891+ (Nothing, Nothing) -> Nothing
892+ _ -> Just result
893+ d' <- holdDyn z $ fmapMaybe fst e'
894+ return (d', fmapMaybe snd e')
895+
896+{-# INLINE accumB #-}
897+accumB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (Behavior t a)
898+accumB f = accumMaybeB $ \v o -> Just $ f v o
899+{-# INLINE accumMB #-}
900+accumMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t a) -> a -> Event t b -> m (Behavior t a)
901+accumMB f = accumMaybeMB $ \v o -> Just <$> f v o
902+{-# INLINE accumMaybeB #-}
903+accumMaybeB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (Behavior t a)
904+accumMaybeB f = accumMaybeMB $ \v o -> return $ f v o
905+{-# INLINE accumMaybeMB #-}
906+accumMaybeMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (Behavior t a)
907+accumMaybeMB f z e = do
908+ rec let e' = flip push e $ \o -> do
909+ v <- sample d'
910+ f v o
911+ d' <- hold z e'
912+ return d'
913+{-# INLINE mapAccumB #-}
914+mapAccumB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (Behavior t a, Event t c)
915+mapAccumB f = mapAccumMaybeB $ \v o -> bimap Just Just $ f v o
916+{-# INLINE mapAccumMB #-}
917+mapAccumMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (Behavior t a, Event t c)
918+mapAccumMB f = mapAccumMaybeMB $ \v o -> bimap Just Just <$> f v o
919+{-# INLINE mapAccumMaybeB #-}
920+mapAccumMaybeB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (Behavior t a, Event t c)
921+mapAccumMaybeB f = mapAccumMaybeMB $ \v o -> return $ f v o
922+
923+{-# INLINE mapAccumMaybeMB #-}
924+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)
925+mapAccumMaybeMB f z e = do
926+ rec let e' = flip push e $ \o -> do
927+ v <- sample d'
928+ result <- f v o
929+ return $ case result of
930+ (Nothing, Nothing) -> Nothing
931+ _ -> Just result
932+ d' <- hold z $ fmapMaybe fst e'
933+ return (d', fmapMaybe snd e')
934+
935+-- | Accumulate occurrences of an 'Event', producing an output occurrence each
936+-- time. Discard the underlying 'Accumulator'.
937+{-# INLINE mapAccum_ #-}
938+mapAccum_ :: 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)
939+mapAccum_ f z e = do
940+ (_, result) <- mapAccumB f z e
941+ return result
942+
943+-- | Accumulate occurrences of an 'Event', possibly producing an output
944+-- occurrence each time. Discard the underlying 'Accumulator'.
945+{-# INLINE mapAccumMaybe_ #-}
946+mapAccumMaybe_ :: 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)
947+mapAccumMaybe_ f z e = do
948+ (_, result) <- mapAccumMaybeB f z e
949+ return result
950+
951+-- | Accumulate occurrences of an 'Event', using a 'PushM' action and producing
952+-- an output occurrence each time. Discard the underlying 'Accumulator'.
953+{-# INLINE mapAccumM_ #-}
954+mapAccumM_ :: 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)
955+mapAccumM_ f z e = do
956+ (_, result) <- mapAccumMB f z e
957+ return result
958+
959+-- | Accumulate occurrences of an 'Event', using a 'PushM' action and possibly
960+-- producing an output occurrence each time. Discard the underlying
961+-- 'Accumulator'.
962+{-# INLINE mapAccumMaybeM_ #-}
963+mapAccumMaybeM_ :: 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)
964+mapAccumMaybeM_ f z e = do
965+ (_, result) <- mapAccumMaybeMB f z e
966+ return result
967+
968+instance Reflex t => Accumulator t (Dynamic t) where
969+ accumMaybeM = accumMaybeMDyn
970+ mapAccumMaybeM = mapAccumMaybeMDyn
971+
972+instance Reflex t => Accumulator t (Behavior t) where
973+ accumMaybeM = accumMaybeMB
974+ mapAccumMaybeM = mapAccumMaybeMB
975+
976+instance Reflex t => Accumulator t (Event t) where
977+ accumMaybeM f z e = updated <$> accumMaybeM f z e
978+ mapAccumMaybeM f z e = first updated <$> mapAccumMaybeM f z e
979+
980+-- | Create a new 'Event' by combining each occurence with the next value of the
981+-- list using the supplied function. If the list runs out of items, all
982+-- subsequent 'Event' occurrences will be ignored.
983+zipListWithEvent :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> c) -> [a] -> Event t b -> m (Event t c)
984+zipListWithEvent f l e = do
985+ let f' a b = case a of
986+ h:t -> (Just t, Just $ f h b)
987+ _ -> (Nothing, Nothing) --TODO: Unsubscribe the event?
988+ mapAccumMaybe_ f' l e
989+
990+-- | Assign a number to each occurence of the given 'Event', starting from 0
991+{-# INLINE numberOccurrences #-}
992+numberOccurrences :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Event t (b, a))
993+numberOccurrences = numberOccurrencesFrom 0
994+
995+-- | Assign a number to each occurence of the given 'Event'
996+{-# INLINE numberOccurrencesFrom #-}
997+numberOccurrencesFrom :: (Reflex t, MonadHold t m, MonadFix m, Num b) => b -> Event t a -> m (Event t (b, a))
998+numberOccurrencesFrom = mapAccum_ (\n a -> let !next = n + 1 in (next, (n, a)))
999+
1000+-- | Assign a number to each occurence of the given 'Event'; discard the occurrences' values
1001+{-# INLINE numberOccurrencesFrom_ #-}
1002+numberOccurrencesFrom_ :: (Reflex t, MonadHold t m, MonadFix m, Num b) => b -> Event t a -> m (Event t b)
1003+numberOccurrencesFrom_ = mapAccum_ (\n _ -> let !next = n + 1 in (next, n))
1004+
1005+-- | This is used to sample the value of a 'Behavior' using an 'Event'.
1006+--
1007+-- The '<@>' operator is intended to be used in conjunction with
1008+-- the 'Applicative' instance for 'Behavior'.
1009+--
1010+-- This is useful when we want to combine the values of one 'Event' and
1011+-- the value of several 'Behavior's at the time the 'Event' is firing.
1012+--
1013+-- If we have:
1014+--
1015+-- > f :: a -> b -> c -> d
1016+-- > b1 :: Behavior t a
1017+-- > b2 :: Behavior t b
1018+-- > e :: Event t c
1019+--
1020+-- then we can do:
1021+--
1022+-- > f <$> b1 <*> b2 <@> e :: Event t d
1023+--
1024+-- in order to apply the function 'f' to the relevant values.
1025+--
1026+-- The alternative would be something like:
1027+--
1028+-- > attachWith (\(x1, x2) y -> f x1 x2 y) ((,) <$> b1 <*> b2) e :: Event t d
1029+--
1030+-- or a variation involing a custom data type to hold the combination of
1031+-- 'Behavior's even when that combination might only ever be used by 'f'.
1032+--
1033+-- A more suggestive example might be:
1034+--
1035+-- > handleMouse <$> bPlayerState <*> bMousePosition <@> eMouseClick :: Event t (GameState -> GameState)
1036+--
1037+(<@>) :: Reflex t => Behavior t (a -> b) -> Event t a -> Event t b
1038+(<@>) b = push $ \x -> do
1039+ f <- sample b
1040+ return . Just . f $ x
1041+infixl 4 <@>
1042+
1043+-- | An version of '<@>' that does not use the value of the 'Event'.
1044+--
1045+-- Alternatively, it is 'tag' in operator form.
1046+--
1047+-- This is useful when we want to combine the values of several
1048+-- 'Behavior's at particular points in time using an 'Applicative'
1049+-- style syntax.
1050+--
1051+-- If we have:
1052+--
1053+-- > g :: a -> b -> d
1054+-- > b1 :: Behavior t a
1055+-- > b2 :: Behavior t b
1056+-- > e :: Event t c
1057+--
1058+-- where 'e' is firing at the points in time of interest.
1059+--
1060+-- Then we can use '<@':
1061+--
1062+-- > g <$> b1 <*> b2 <@ e :: Event t d
1063+--
1064+-- to combine the values of 'b1' and 'b2' at each of those points of time,
1065+-- with the function 'g' being used to combine the values.
1066+--
1067+-- This is the same as '<@>' except that the 'Event' is being used only
1068+-- to act as a trigger.
1069+(<@) :: (Reflex t) => Behavior t b -> Event t a -> Event t b
1070+(<@) = tag
1071+infixl 4 <@
1072+
1073+------------------
1074+-- Adjustable
1075+------------------
1076+
1077+-- | A 'Monad' that supports adjustment over time. After an action has been
1078+-- run, if the given events fire, it will adjust itself so that its net effect
1079+-- is as though it had originally been run with the new value. Note that there
1080+-- is some issue here with persistent side-effects: obviously, IO (and some
1081+-- other side-effects) cannot be undone, so it is up to the instance implementer
1082+-- to determine what the best meaning for this class is in such cases.
1083+class (Reflex t, Monad m) => Adjustable t m | m -> t where
1084+ runWithReplace :: m a -> Event t (m b) -> m (a, Event t b)
1085+ traverseIntMapWithKeyWithAdjust :: (IntMap.Key -> v -> m v') -> IntMap v -> Event t (PatchIntMap v) -> m (IntMap v', Event t (PatchIntMap v'))
1086+ 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'))
1087+ 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'))
1088+
1089+instance Adjustable t m => Adjustable t (ReaderT r m) where
1090+ runWithReplace a0 a' = do
1091+ r <- ask
1092+ lift $ runWithReplace (runReaderT a0 r) $ fmap (`runReaderT` r) a'
1093+ traverseIntMapWithKeyWithAdjust f dm0 dm' = do
1094+ r <- ask
1095+ lift $ traverseIntMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'
1096+ traverseDMapWithKeyWithAdjust f dm0 dm' = do
1097+ r <- ask
1098+ lift $ traverseDMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'
1099+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do
1100+ r <- ask
1101+ lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runReaderT (f k v) r) dm0 dm'
1102+
1103+sequenceDMapWithAdjust :: (GCompare k, Adjustable t m) => DMap k m -> Event t (PatchDMap k m) -> m (DMap k Identity, Event t (PatchDMap k Identity))
1104+sequenceDMapWithAdjust = traverseDMapWithKeyWithAdjust $ \_ -> fmap Identity
1105+
1106+sequenceDMapWithAdjustWithMove :: (GCompare k, Adjustable t m) => DMap k m -> Event t (PatchDMapWithMove k m) -> m (DMap k Identity, Event t (PatchDMapWithMove k Identity))
1107+sequenceDMapWithAdjustWithMove = traverseDMapWithKeyWithAdjustWithMove $ \_ -> fmap Identity
1108+
1109+mapMapWithAdjustWithMove :: forall t m k v v'. (Adjustable 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'))
1110+mapMapWithAdjustWithMove f m0 m' = do
1111+ (out0 :: DMap (Const2 k v) (Constant v'), out') <- traverseDMapWithKeyWithAdjustWithMove (\(Const2 k) (Identity v) -> Constant <$> f k v) (mapToDMap m0) (const2PatchDMapWithMoveWith Identity <$> m')
1112+ return (dmapToMapWith (\(Constant v') -> v') out0, patchDMapWithMoveToPatchMapWithMoveWith (\(Constant v') -> v') <$> out')
1113+
1114+------------------
1115+-- Cheap Functions
1116+------------------
1117+
1118+{-# INLINE pushAlwaysCheap #-}
1119+pushAlwaysCheap :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b
1120+pushAlwaysCheap f = pushCheap (fmap Just . f)
1121+
1122+{-# INLINE fmapMaybeCheap #-}
1123+fmapMaybeCheap :: Reflex t => (a -> Maybe b) -> Event t a -> Event t b
1124+fmapMaybeCheap f = pushCheap $ return . f
1125+
1126+{-# INLINE fforMaybeCheap #-}
1127+fforMaybeCheap :: Reflex t => Event t a -> (a -> Maybe b) -> Event t b
1128+fforMaybeCheap = flip fmapMaybeCheap
1129+
1130+{-# INLINE fforCheap #-}
1131+fforCheap :: Reflex t => Event t a -> (a -> b) -> Event t b
1132+fforCheap = flip fmapCheap
1133+
1134+{-# INLINE fmapCheap #-}
1135+fmapCheap :: Reflex t => (a -> b) -> Event t a -> Event t b
1136+fmapCheap f = pushCheap $ return . Just . f
1137+
1138+{-# INLINE tagCheap #-}
1139+tagCheap :: Reflex t => Behavior t b -> Event t a -> Event t b
1140+tagCheap b = pushAlwaysCheap $ \_ -> sample b
1141+
1142+{-# INLINE mergeWithCheap #-}
1143+mergeWithCheap :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a
1144+mergeWithCheap = mergeWithCheap' id
1145+
1146+{-# INLINE mergeWithCheap' #-}
1147+mergeWithCheap' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b
1148+mergeWithCheap' f g = mergeWithFoldCheap' $ foldl1 g . fmap f
1149+
1150+{-# INLINE mergeWithFoldCheap' #-}
1151+mergeWithFoldCheap' :: Reflex t => (NonEmpty a -> b) -> [Event t a] -> Event t b
1152+mergeWithFoldCheap' f es =
1153+ fmapCheap (f . (\(h : t) -> h :| t) . IntMap.elems)
1154+ . mergeInt
1155+ . IntMap.fromDistinctAscList
1156+ $ zip [0 :: Int ..] es
1157+
1158+--------------------------------------------------------------------------------
1159+-- Deprecated functions
1160+--------------------------------------------------------------------------------
1161+
1162+{-# DEPRECATED MonadAdjust "Use Adjustable instead" #-}
1163+type MonadAdjust = Adjustable
1164+
1165+-- | Create a new 'Event' that occurs if at least one of the supplied 'Event's
1166+-- occurs. If both occur at the same time they are combined using 'mappend'.
1167+{-# DEPRECATED appendEvents "If a 'Semigroup a' instance is available, use 'mappend'; otherwise, use 'alignWith (mergeThese mappend)' instead" #-}
1168+appendEvents :: (Reflex t, Monoid a) => Event t a -> Event t a -> Event t a
1169+appendEvents = alignWith $ mergeThese mappend
1170+
1171+-- | Alias for 'headE'
1172+{-# DEPRECATED onceE "Use 'headE' instead" #-}
1173+onceE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
1174+onceE = headE
1175+
1176+-- | Run both sides of a 'These' monadically, combining the results.
1177+{-# DEPRECATED sequenceThese "Use bisequenceA or bisequence from the bifunctors package instead" #-}
1178+#ifdef USE_TEMPLATE_HASKELL
1179+{-# ANN sequenceThese "HLint: ignore Use fmap" #-}
1180+#endif
1181+sequenceThese :: Monad m => These (m a) (m b) -> m (These a b)
1182+sequenceThese t = case t of
1183+ This ma -> fmap This ma
1184+ These ma mb -> liftM2 These ma mb
1185+ That mb -> fmap That mb
1186+
1187+{-# 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'. " #-}
1188+switchPromptly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)
1189+switchPromptly = switchHoldPromptly
1190+{-# 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'. " #-}
1191+switchPromptOnly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)
1192+switchPromptOnly = switchHoldPromptOnly
src/Reflex/Collection.hsnew file+120
@@ -0,0 +1,120 @@
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+module Reflex.Collection
14+ (
15+ -- * Widgets on Collections
16+ listHoldWithKey
17+ , listWithKey
18+ , listWithKey'
19+ , listWithKeyShallowDiff
20+ , listViewWithKey
21+ , selectViewListWithKey
22+ , selectViewListWithKey_
23+ -- * List Utils
24+ , list
25+ , simpleList
26+ ) where
27+
28+import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
29+import Data.Align
30+import Data.Functor.Misc
31+import Data.Map (Map)
32+import qualified Data.Map as Map
33+import Data.Map.Misc
34+import Data.These
35+
36+import Reflex.Class
37+import Reflex.Dynamic
38+import Reflex.PostBuild.Class
39+
40+listHoldWithKey :: forall t m k v a. (Ord k, Adjustable t m, MonadHold t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a))
41+listHoldWithKey m0 m' f = do
42+ let dm0 = mapWithFunctorToDMap $ Map.mapWithKey f m0
43+ dm' = fmap (PatchDMap . mapWithFunctorToDMap . Map.mapWithKey (\k v -> ComposeMaybe $ fmap (f k) v)) m'
44+ (a0, a') <- sequenceDMapWithAdjust dm0 dm'
45+ fmap dmapToMap . incrementalToDynamic <$> holdIncremental a0 a' --TODO: Move the dmapToMap to the righthand side so it doesn't get fully redone every time
46+
47+--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
48+listWithKey :: forall t k v m a. (Ord k, Adjustable t m, PostBuild t m, MonadFix m, MonadHold t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a))
49+listWithKey vals mkChild = do
50+ postBuild <- getPostBuild
51+ let childValChangedSelector = fanMap $ updated vals
52+ -- We keep track of changes to children values in the mkChild function we pass to listHoldWithKey
53+ -- The other changes we need to keep track of are child insertions and deletions. diffOnlyKeyChanges
54+ -- keeps track of insertions and deletions but ignores value changes, since they're already accounted for.
55+ diffOnlyKeyChanges olds news = flip Map.mapMaybe (align olds news) $ \case
56+ This _ -> Just Nothing
57+ These _ _ -> Nothing
58+ That new -> Just $ Just new
59+ rec sentVals :: Dynamic t (Map k v) <- foldDyn applyMap Map.empty changeVals
60+ let changeVals :: Event t (Map k (Maybe v))
61+ changeVals = attachWith diffOnlyKeyChanges (current sentVals) $ leftmost
62+ [ updated vals
63+ , tag (current vals) postBuild --TODO: This should probably be added to the attachWith, not to the updated; if we were using diffMap instead of diffMapNoEq, I think it might not work
64+ ]
65+ listHoldWithKey Map.empty changeVals $ \k v ->
66+ mkChild k =<< holdDyn v (select childValChangedSelector $ Const2 k)
67+
68+{-# DEPRECATED listWithKey' "listWithKey' has been renamed to listWithKeyShallowDiff; also, its behavior has changed to fix a bug where children were always rebuilt (never updated)" #-}
69+listWithKey' :: (Ord k, Adjustable t m, MonadFix m, MonadHold t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))
70+listWithKey' = listWithKeyShallowDiff
71+
72+-- | Display the given map of items (in key order) using the builder function provided, and update it with the given event. 'Nothing' update entries will delete the corresponding children, and 'Just' entries will create them if they do not exist or send an update event to them if they do.
73+listWithKeyShallowDiff :: (Ord k, Adjustable t m, MonadFix m, MonadHold t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))
74+listWithKeyShallowDiff initialVals valsChanged mkChild = do
75+ let childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged
76+ sentVals <- foldDyn applyMap (void initialVals) $ fmap (fmap void) valsChanged
77+ let relevantPatch patch _ = case patch of
78+ Nothing -> Just Nothing -- Even if we let a Nothing through when the element doesn't already exist, this doesn't cause a problem because it is ignored
79+ Just _ -> Nothing -- We don't want to let spurious re-creations of items through
80+ listHoldWithKey initialVals (attachWith (flip (Map.differenceWith relevantPatch)) (current sentVals) valsChanged) $ \k v ->
81+ mkChild k v $ select childValChangedSelector $ Const2 k
82+
83+--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
84+-- | Create a dynamically-changing set of Event-valued widgets.
85+-- This is like listWithKey, specialized for widgets returning (Event t a). listWithKey would return 'Dynamic t (Map k (Event t a))' in this scenario, but listViewWithKey flattens this to 'Event t (Map k a)' via 'switch'.
86+listViewWithKey :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m (Event t a)) -> m (Event t (Map k a))
87+listViewWithKey vals mkChild = switch . fmap mergeMap <$> listViewWithKey' vals mkChild
88+
89+listViewWithKey' :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Behavior t (Map k a))
90+listViewWithKey' vals mkChild = current <$> listWithKey vals mkChild
91+
92+-- | Create a dynamically-changing set of widgets, one of which is selected at any time.
93+selectViewListWithKey :: forall t m k v a. (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)
94+ => Dynamic t k -- ^ Current selection key
95+ -> Dynamic t (Map k v) -- ^ Dynamic key/value map
96+ -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -- ^ Function to create a widget for a given key from Dynamic value and Dynamic Bool indicating if this widget is currently selected
97+ -> m (Event t (k, a)) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.
98+selectViewListWithKey selection vals mkChild = do
99+ let selectionDemux = demux selection -- For good performance, this value must be shared across all children
100+ selectChild <- listWithKey vals $ \k v -> do
101+ let selected = demuxed selectionDemux k
102+ selectSelf <- mkChild k v selected
103+ return $ fmap ((,) k) selectSelf
104+ return $ switchPromptlyDyn $ leftmost . Map.elems <$> selectChild
105+
106+selectViewListWithKey_ :: forall t m k v a. (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)
107+ => Dynamic t k -- ^ Current selection key
108+ -> Dynamic t (Map k v) -- ^ Dynamic key/value map
109+ -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -- ^ Function to create a widget for a given key from Dynamic value and Dynamic Bool indicating if this widget is currently selected
110+ -> m (Event t k) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.
111+selectViewListWithKey_ selection vals mkChild = fmap fst <$> selectViewListWithKey selection vals mkChild
112+
113+-- | Create a dynamically-changing set of widgets from a Dynamic key/value map.
114+-- Unlike the 'withKey' variants, the child widgets are insensitive to which key they're associated with.
115+list :: (Ord k, Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m) => Dynamic t (Map k v) -> (Dynamic t v -> m a) -> m (Dynamic t (Map k a))
116+list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
117+
118+-- | Create a dynamically-changing set of widgets from a Dynamic list.
119+simpleList :: (Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m) => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])
120+simpleList xs mkChild = fmap (fmap (map snd . Map.toList)) $ flip list mkChild $ fmap (Map.fromList . zip [(1::Int)..]) xs
src/Reflex/Dynamic.hsnew file+686
@@ -0,0 +1,686 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE GADTs #-}
6+{-# LANGUAGE LambdaCase #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE NoMonomorphismRestriction #-}
9+{-# LANGUAGE PolyKinds #-}
10+{-# LANGUAGE RankNTypes #-}
11+{-# LANGUAGE RecursiveDo #-}
12+{-# LANGUAGE ScopedTypeVariables #-}
13+{-# LANGUAGE StandaloneDeriving #-}
14+{-# LANGUAGE TypeFamilies #-}
15+{-# LANGUAGE TypeOperators #-}
16+{-# LANGUAGE UndecidableInstances #-}
17+#ifdef USE_REFLEX_OPTIMIZER
18+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
19+#endif
20+-- | This module contains various functions for working with 'Dynamic' values.
21+-- 'Dynamic' and its primitives have been moved to the 'Reflex' class.
22+module Reflex.Dynamic
23+ ( -- * Basics
24+ Dynamic -- Abstract so we can preserve the law that the current value is always equal to the most recent update
25+ , current
26+ , updated
27+ , holdDyn
28+ , mapDynM
29+ , forDynM
30+ , constDyn
31+ , count
32+ , toggle
33+ , switchDyn
34+ , switchPromptlyDyn
35+ , tagPromptlyDyn
36+ , attachPromptlyDyn
37+ , attachPromptlyDynWith
38+ , attachPromptlyDynWithMaybe
39+ , maybeDyn
40+ , eitherDyn
41+ , factorDyn
42+ , scanDyn
43+ , scanDynMaybe
44+ , holdUniqDyn
45+ , holdUniqDynBy
46+ , improvingMaybe
47+ , foldDyn
48+ , foldDynM
49+ , foldDynMaybe
50+ , foldDynMaybeM
51+ , joinDynThroughMap
52+ , traceDyn
53+ , traceDynWith
54+ , splitDynPure
55+ , distributeMapOverDynPure
56+ , distributeDMapOverDynPure
57+ , distributeListOverDynPure
58+ , Demux
59+ , demux
60+ , demuxed
61+ -- Things that probably aren't very useful:
62+ , HList (..)
63+ , FHList (..)
64+ , collectDynPure
65+ , RebuildSortedHList (..)
66+ , IsHList (..)
67+ , AllAreFunctors (..)
68+ , HListPtr (..)
69+ , distributeFHListOverDynPure
70+ -- Unsafe
71+ , unsafeDynamic
72+ -- * Deprecated functions
73+ , apDyn
74+ , attachDyn
75+ , attachDynWith
76+ , attachDynWithMaybe
77+ , collectDyn
78+ , combineDyn
79+ , distributeDMapOverDyn
80+ , distributeFHListOverDyn
81+ , forDyn
82+ , getDemuxed
83+ , joinDyn
84+ , mapDyn
85+ , mconcatDyn
86+ , nubDyn
87+ , splitDyn
88+ , tagDyn
89+ , uniqDyn
90+ , uniqDynBy
91+ ) where
92+
93+import Data.Functor.Compose
94+import Data.Functor.Misc
95+import Reflex.Class
96+
97+import Control.Applicative ((<*>))
98+import Control.Monad
99+import Control.Monad.Fix
100+import Control.Monad.Identity
101+import Data.Align
102+import Data.Dependent.Map (DMap)
103+import qualified Data.Dependent.Map as DMap
104+import Data.Dependent.Sum (DSum (..))
105+import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), GOrdering (..))
106+import Data.Map (Map)
107+import Data.Maybe
108+import Data.Monoid
109+import Data.These
110+
111+import Debug.Trace
112+
113+-- | Map a sampling function over a 'Dynamic'.
114+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)
115+mapDynM f d = buildDynamic (f =<< sample (current d)) $ pushAlways f (updated d)
116+
117+-- | Flipped version of 'mapDynM'
118+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)
119+forDynM d f = mapDynM f d
120+
121+-- | Create a new 'Dynamic' that only signals changes if the values actually
122+-- changed.
123+holdUniqDyn :: (Reflex t, MonadHold t m, MonadFix m, Eq a) => Dynamic t a -> m (Dynamic t a)
124+holdUniqDyn = holdUniqDynBy (==)
125+
126+-- | Create a new 'Dynamic' that changes only when the underlying 'Dynamic'
127+-- changes and the given function returns 'False' when given both the old and
128+-- the new values.
129+holdUniqDynBy :: (Reflex t, MonadHold t m, MonadFix m) => (a -> a -> Bool) -> Dynamic t a -> m (Dynamic t a)
130+holdUniqDynBy eq = scanDynMaybe id (\new old -> if new `eq` old then Nothing else Just new)
131+
132+-- | Dynamic Maybe that can only update from Nothing to Just or Just to Just (i.e., cannot revert to Nothing)
133+improvingMaybe :: (Reflex t, MonadHold t m, MonadFix m) => Dynamic t (Maybe a) -> m (Dynamic t (Maybe a))
134+improvingMaybe = scanDynMaybe id (\new _ -> if isJust new then Just new else Nothing)
135+
136+-- | Create a 'Dynamic' that accumulates values from another 'Dynamic'. This
137+-- function does not force its input 'Dynamic' until the output 'Dynamic' is
138+-- forced.
139+scanDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b) -> (a -> b -> b) -> Dynamic t a -> m (Dynamic t b)
140+scanDyn z f = scanDynMaybe z (\a b -> Just $ f a b)
141+
142+-- | Like 'scanDyn', but the the accumulator function may decline to update the
143+-- result 'Dynamic''s value.
144+scanDynMaybe :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b) -> (a -> b -> Maybe b) -> Dynamic t a -> m (Dynamic t b)
145+scanDynMaybe z f d = do
146+ rec d' <- buildDynamic (z <$> sample (current d)) $ flip push (updated d) $ \a -> do
147+ b <- sample $ current d'
148+ return $ f a b
149+ return d'
150+
151+-- | Create a 'Dynamic' using the initial value and change it each time the
152+-- 'Event' occurs using a folding function on the previous value and the value
153+-- of the 'Event'.
154+foldDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> b) -> b -> Event t a -> m (Dynamic t b)
155+foldDyn = accumDyn . flip
156+
157+-- | Like 'foldDyn', but the combining function is a 'PushM' action, so it
158+-- can 'sample' existing 'Behaviors' and 'hold' new ones.
159+foldDynM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t b) -> b -> Event t a -> m (Dynamic t b)
160+foldDynM = accumMDyn . flip
161+
162+-- | Create a 'Dynamic' using the provided initial value and change it each time
163+-- the provided 'Event' occurs, using a function to combine the old value with
164+-- the 'Event''s value. If the function returns 'Nothing', the value is not
165+-- changed; this is distinct from returning 'Just' the old value, since the
166+-- 'Dynamic''s 'updated' 'Event' will fire in the 'Just' case, and will not fire
167+-- in the 'Nothing' case.
168+foldDynMaybe :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe b) -> b -> Event t a -> m (Dynamic t b)
169+foldDynMaybe = accumMaybeDyn . flip
170+
171+-- | Like 'foldDynMaybe', but the combining function is a 'PushM' action, so it
172+-- can 'sample' existing 'Behaviors' and 'hold' new ones.
173+foldDynMaybeM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe b)) -> b -> Event t a -> m (Dynamic t b)
174+foldDynMaybeM = accumMaybeMDyn . flip
175+
176+-- | Create a new 'Dynamic' that counts the occurences of the 'Event'.
177+count :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Dynamic t b)
178+count e = holdDyn 0 =<< zipListWithEvent const (iterate (+1) 1) e
179+
180+-- | Create a new 'Dynamic' using the initial value that flips its
181+-- value every time the 'Event' occurs.
182+toggle :: (Reflex t, MonadHold t m, MonadFix m) => Bool -> Event t a -> m (Dynamic t Bool)
183+toggle = foldDyn (const not)
184+
185+-- | Switches to the new 'Event' whenever it receives one. Only the old event is
186+-- considered the moment a new one is switched in; the output event will fire at
187+-- that moment if only if the old event does.
188+--
189+-- Prefer this to 'switchPromptlyDyn' where possible. The lack of doing double
190+-- work when the outer and (new) inner fires means this imposes fewer "timing
191+-- requirements" and thus is far more easy to use without introducing fresh
192+-- failure cases. 'switchDyn' is also more performant.
193+switchDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a
194+switchDyn d = switch (current d)
195+
196+-- | Switches to the new 'Event' whenever it receives one. Switching occurs
197+-- *before* the inner 'Event' fires - so if the 'Dynamic' changes and both the
198+-- old and new inner Events fire simultaneously, the output will fire with the
199+-- value of the *new* 'Event'.
200+--
201+-- Prefer 'switchDyn' to this where possible. The timing requirements that
202+-- switching before imposes are likely to bring down your app unless you are
203+-- very careful. 'switchDyn' is also more performant.
204+switchPromptlyDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a
205+switchPromptlyDyn de =
206+ let eLag = switch $ current de
207+ eCoincidences = coincidence $ updated de
208+ in leftmost [eCoincidences, eLag]
209+
210+-- | Split a 'Dynamic' pair into a pair of 'Dynamic's
211+splitDynPure :: Reflex t => Dynamic t (a, b) -> (Dynamic t a, Dynamic t b)
212+splitDynPure d = (fmap fst d, fmap snd d)
213+
214+-- | Convert a 'Map' with 'Dynamic' elements into a 'Dynamic' of a 'Map' with
215+-- non-'Dynamic' elements.
216+distributeMapOverDynPure :: (Reflex t, Ord k) => Map k (Dynamic t v) -> Dynamic t (Map k v)
217+distributeMapOverDynPure = fmap dmapToMap . distributeDMapOverDynPure . mapWithFunctorToDMap
218+
219+-- | Convert a list with 'Dynamic' elements into a 'Dynamic' of a list with
220+-- non-'Dynamic' elements, preserving the order of the elements.
221+distributeListOverDynPure :: Reflex t => [Dynamic t v] -> Dynamic t [v]
222+distributeListOverDynPure =
223+ fmap (map fromDSum . DMap.toAscList) .
224+ distributeDMapOverDynPure .
225+ DMap.fromDistinctAscList .
226+ zipWith toDSum [0..]
227+ where
228+ toDSum :: Int -> Dynamic t a -> DSum (Const2 Int a) (Dynamic t)
229+ toDSum k v = Const2 k :=> v
230+ fromDSum :: DSum (Const2 Int a) Identity -> a
231+ fromDSum (Const2 _ :=> Identity v) = v
232+
233+--TODO: Generalize this to functors other than Maps
234+-- | Combine a 'Dynamic' of a 'Map' of 'Dynamic's into a 'Dynamic'
235+-- with the current values of the 'Dynamic's in a map.
236+joinDynThroughMap :: forall t k a. (Reflex t, Ord k) => Dynamic t (Map k (Dynamic t a)) -> Dynamic t (Map k a)
237+joinDynThroughMap = joinDyn . fmap distributeMapOverDynPure
238+
239+-- | Print the value of the 'Dynamic' when it is first read and on each
240+-- subsequent change that is observed (as traceEvent), prefixed with the
241+-- provided string. This should /only/ be used for debugging.
242+--
243+-- Note: Just like Debug.Trace.trace, the value will only be shown if something
244+-- else in the system is depending on it.
245+traceDyn :: (Reflex t, Show a) => String -> Dynamic t a -> Dynamic t a
246+traceDyn s = traceDynWith $ \x -> s <> ": " <> show x
247+
248+-- | Print the result of applying the provided function to the value
249+-- of the 'Dynamic' when it is first read and on each subsequent change
250+-- that is observed (as traceEvent). This should /only/ be used for
251+-- debugging.
252+--
253+-- Note: Just like Debug.Trace.trace, the value will only be shown if something
254+-- else in the system is depending on it.
255+traceDynWith :: Reflex t => (a -> String) -> Dynamic t a -> Dynamic t a
256+traceDynWith f d =
257+ let e' = traceEventWith f $ updated d
258+ getV0 = do
259+ x <- sample $ current d
260+ trace (f x) $ return x
261+ in unsafeBuildDynamic getV0 e'
262+
263+-- | Replace the value of the 'Event' with the current value of the 'Dynamic'
264+-- each time the 'Event' occurs.
265+--
266+-- Note: `tagPromptlyDyn d e` differs from `tag (current d) e` in the case that `e` is firing
267+-- at the same time that `d` is changing. With `tagPromptlyDyn d e`, the *new* value of `d`
268+-- will replace the value of `e`, whereas with `tag (current d) e`, the *old* value
269+-- will be used, since the 'Behavior' won't be updated until the end of the frame.
270+-- Additionally, this means that the output 'Event' may not be used to directly change
271+-- the input 'Dynamic', because that would mean its value depends on itself. When creating
272+-- cyclic data flows, generally `tag (current d) e` is preferred.
273+tagPromptlyDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a
274+tagPromptlyDyn = attachPromptlyDynWith const
275+
276+-- | Attach the current value of the 'Dynamic' to the value of the
277+-- 'Event' each time it occurs.
278+--
279+-- Note: `attachPromptlyDyn d` is not the same as `attach (current d)`. See 'tagPromptlyDyn' for details.
280+attachPromptlyDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b)
281+attachPromptlyDyn = attachPromptlyDynWith (,)
282+
283+-- | Combine the current value of the 'Dynamic' with the value of the
284+-- 'Event' each time it occurs.
285+--
286+-- Note: `attachPromptlyDynWith f d` is not the same as `attachWith f (current d)`. See 'tagPromptlyDyn' for details.
287+attachPromptlyDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c
288+attachPromptlyDynWith f = attachPromptlyDynWithMaybe $ \a b -> Just $ f a b
289+
290+-- | Create a new 'Event' by combining the value at each occurence with the
291+-- current value of the 'Dynamic' value and possibly filtering if the combining
292+-- function returns 'Nothing'.
293+--
294+-- Note: `attachPromptlyDynWithMaybe f d` is not the same as `attachWithMaybe f
295+-- (current d)`. See 'tagPromptlyDyn' for details.
296+attachPromptlyDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c
297+attachPromptlyDynWithMaybe f d e =
298+ let e' = attach (current d) e
299+ in fforMaybe (align e' $ updated d) $ \case
300+ This (a, b) -> f a b -- Only the tagging event is firing, so use that
301+ These (_, b) a -> f a b -- Both events are firing, so use the newer value
302+ That _ -> Nothing -- The tagging event isn't firing, so don't fire
303+
304+-- | Factor a @Dynamic t (Maybe a)@ into a @Dynamic t (Maybe (Dynamic t a))@,
305+-- such that the outer 'Dynamic' is updated only when the 'Maybe''s constructor
306+-- chages from 'Nothing' to 'Just' or vice-versa. Whenever the constructor
307+-- becomes 'Just', an inner 'Dynamic' will be provided, whose value will track
308+-- the 'a' inside the 'Just'; when the constructor becomes 'Nothing', the
309+-- existing inner 'Dynamic' will become constant, and will not change when the
310+-- outer constructor changes back to 'Nothing'.
311+maybeDyn :: forall t a m. (Reflex t, MonadFix m, MonadHold t m) => Dynamic t (Maybe a) -> m (Dynamic t (Maybe (Dynamic t a)))
312+maybeDyn = fmap (fmap unpack) . eitherDyn . fmap pack
313+ where pack = \case
314+ Nothing -> Left ()
315+ Just a -> Right a
316+ unpack = \case
317+ Left _ -> Nothing
318+ Right a -> Just a
319+
320+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)))
321+eitherDyn = fmap (fmap unpack) . factorDyn . fmap eitherToDSum
322+ where unpack :: DSum (EitherTag a b) (Compose (Dynamic t) Identity) -> Either (Dynamic t a) (Dynamic t b)
323+ unpack = \case
324+ LeftTag :=> Compose a -> Left $ coerceDynamic a
325+ RightTag :=> Compose b -> Right $ coerceDynamic b
326+
327+factorDyn :: forall t m k v. (Reflex t, MonadFix m, MonadHold t m, GEq k) => Dynamic t (DSum k v) -> m (Dynamic t (DSum k (Compose (Dynamic t) v)))
328+factorDyn d = do
329+ let inner :: forall m' a. (MonadFix m', MonadHold t m') => k a -> v a -> m' (Dynamic t (v a))
330+ inner k v0 = holdDyn v0 . fmapMaybe id =<< takeWhileE isJust newVal
331+ where newVal = ffor (updated d) $ \(newK :=> newV) -> case newK `geq` k of
332+ Just Refl -> Just newV
333+ Nothing -> Nothing
334+ getInitial = do
335+ k0 :=> (v0 :: v a) <- sample $ current d
336+ i0 <- inner k0 v0
337+ return $ k0 :=> Compose i0
338+ update = flip push (updated d) $ \(newKey :=> newVal) -> do
339+ (oldKey :=> _) <- sample $ current d
340+ case newKey `geq` oldKey of
341+ Just Refl -> return Nothing
342+ Nothing -> do
343+ newInner <- inner newKey newVal
344+ return $ Just $ newKey :=> Compose newInner
345+ o0 <- getInitial --TODO: Figure out how to get this to run inside something like the first argument to buildDynamic
346+ holdDyn o0 update
347+
348+--------------------------------------------------------------------------------
349+-- Demux
350+--------------------------------------------------------------------------------
351+
352+-- | Represents a time changing value together with an 'EventSelector' that can
353+-- efficiently detect when the underlying 'Dynamic' has a particular value.
354+-- This is useful for representing data like the current selection of a long
355+-- list.
356+--
357+-- Semantically,
358+--
359+-- > demuxed (demux d) k === fmap (== k) d
360+--
361+-- However, the when getDemuxed is used multiple times, the complexity is only
362+-- /O(log(n))/, rather than /O(n)/ for fmap.
363+data Demux t k = Demux { demuxValue :: Behavior t k
364+ , demuxSelector :: EventSelector t (Const2 k Bool)
365+ }
366+
367+-- | Demultiplex an input value to a 'Demux' with many outputs. At any given
368+-- time, whichever output is indicated by the given 'Dynamic' will be 'True'.
369+demux :: (Reflex t, Ord k) => Dynamic t k -> Demux t k
370+demux k = Demux (current k)
371+ (fan $ attachWith (\k0 k1 -> if k0 == k1
372+ then DMap.empty
373+ else DMap.fromList [Const2 k0 :=> Identity False,
374+ Const2 k1 :=> Identity True])
375+ (current k) (updated k))
376+
377+-- | Select a particular output of the 'Demux'; this is equivalent to (but much
378+-- faster than) mapping over the original 'Dynamic' and checking whether it is
379+-- equal to the given key.
380+demuxed :: (Reflex t, Eq k) => Demux t k -> k -> Dynamic t Bool
381+demuxed d k =
382+ let e = select (demuxSelector d) (Const2 k)
383+ in unsafeBuildDynamic (fmap (==k) $ sample $ demuxValue d) e
384+
385+--------------------------------------------------------------------------------
386+-- collectDyn
387+--------------------------------------------------------------------------------
388+
389+--TODO: This whole section is badly in need of cleanup
390+
391+-- | A heterogeneous list whose type and length are fixed statically. This is
392+-- reproduced from the 'HList' package due to integration issues, and because
393+-- very little other functionality from that library is needed.
394+data HList (l::[*]) where
395+ HNil :: HList '[]
396+ HCons :: e -> HList l -> HList (e ': l)
397+
398+infixr 2 `HCons`
399+
400+type family HRevApp (l1 :: [k]) (l2 :: [k]) :: [k]
401+type instance HRevApp '[] l = l
402+type instance HRevApp (e ': l) l' = HRevApp l (e ': l')
403+
404+hRevApp :: HList l1 -> HList l2 -> HList (HRevApp l1 l2)
405+hRevApp HNil l = l
406+hRevApp (HCons x l) l' = hRevApp l (HCons x l')
407+
408+hReverse :: HList l -> HList (HRevApp l '[])
409+hReverse l = hRevApp l HNil
410+
411+hBuild :: (HBuild' '[] r) => r
412+hBuild = hBuild' HNil
413+
414+class HBuild' l r where
415+ hBuild' :: HList l -> r
416+
417+instance (l' ~ HRevApp l '[])
418+ => HBuild' l (HList l') where
419+ hBuild' = hReverse
420+
421+instance HBuild' (a ': l) r
422+ => HBuild' l (a->r) where
423+ hBuild' l x = hBuild' (HCons x l)
424+
425+-- | Like 'HList', but with a functor wrapping each element.
426+data FHList f l where
427+ FHNil :: FHList f '[]
428+ FHCons :: f e -> FHList f l -> FHList f (e ': l)
429+
430+instance GEq (HListPtr l) where
431+ HHeadPtr `geq` HHeadPtr = Just Refl
432+ HHeadPtr `geq` HTailPtr _ = Nothing
433+ HTailPtr _ `geq` HHeadPtr = Nothing
434+ HTailPtr a `geq` HTailPtr b = a `geq` b
435+
436+instance GCompare (HListPtr l) where -- Warning: This ordering can't change, dmapTo*HList will break
437+ HHeadPtr `gcompare` HHeadPtr = GEQ
438+ HHeadPtr `gcompare` HTailPtr _ = GLT
439+ HTailPtr _ `gcompare` HHeadPtr = GGT
440+ HTailPtr a `gcompare` HTailPtr b = a `gcompare` b
441+
442+-- | A typed index into a typed heterogeneous list.
443+data HListPtr l a where
444+ HHeadPtr :: HListPtr (h ': t) h
445+ HTailPtr :: HListPtr t a -> HListPtr (h ': t) a
446+
447+deriving instance Eq (HListPtr l a)
448+deriving instance Ord (HListPtr l a)
449+
450+fhlistToDMap :: forall (f :: * -> *) l. FHList f l -> DMap (HListPtr l) f
451+fhlistToDMap = DMap.fromList . go
452+ where go :: forall l'. FHList f l' -> [DSum (HListPtr l') f]
453+ go = \case
454+ FHNil -> []
455+ FHCons h t -> (HHeadPtr :=> h) : map (\(p :=> v) -> HTailPtr p :=> v) (go t)
456+
457+-- | This class allows 'HList's and 'FHlist's to be built from regular lists;
458+-- they must be contiguous and sorted.
459+class RebuildSortedHList l where
460+ rebuildSortedFHList :: [DSum (HListPtr l) f] -> FHList f l
461+ rebuildSortedHList :: [DSum (HListPtr l) Identity] -> HList l
462+
463+instance RebuildSortedHList '[] where
464+ rebuildSortedFHList l = case l of
465+ [] -> FHNil
466+ _ : _ -> error "rebuildSortedFHList{'[]}: empty list expected"
467+ rebuildSortedHList l = case l of
468+ [] -> HNil
469+ _ : _ -> error "rebuildSortedHList{'[]}: empty list expected"
470+
471+instance RebuildSortedHList t => RebuildSortedHList (h ': t) where
472+ rebuildSortedFHList l = case l of
473+ ((HHeadPtr :=> h) : t) -> FHCons h . rebuildSortedFHList . map (\(HTailPtr p :=> v) -> p :=> v) $ t
474+ _ -> error "rebuildSortedFHList{h':t}: non-empty list with HHeadPtr expected"
475+ rebuildSortedHList l = case l of
476+ ((HHeadPtr :=> Identity h) : t) -> HCons h . rebuildSortedHList . map (\(HTailPtr p :=> v) -> p :=> v) $ t
477+ _ -> error "rebuildSortedHList{h':t}: non-empty list with HHeadPtr expected"
478+
479+dmapToHList :: forall l. RebuildSortedHList l => DMap (HListPtr l) Identity -> HList l
480+dmapToHList = rebuildSortedHList . DMap.toList
481+
482+-- | Collect a hetereogeneous list whose elements are all 'Dynamic's into a
483+-- single 'Dynamic' whose value represents the current values of all of the
484+-- input 'Dynamic's.
485+distributeFHListOverDynPure :: (Reflex t, RebuildSortedHList l) => FHList (Dynamic t) l -> Dynamic t (HList l)
486+distributeFHListOverDynPure l = fmap dmapToHList $ distributeDMapOverDynPure $ fhlistToDMap l
487+
488+-- | Indicates that all elements in a type-level list are applications of the
489+-- same functor.
490+class AllAreFunctors (f :: a -> *) (l :: [a]) where
491+ type FunctorList f l :: [*]
492+ toFHList :: HList (FunctorList f l) -> FHList f l
493+ fromFHList :: FHList f l -> HList (FunctorList f l)
494+
495+instance AllAreFunctors f '[] where
496+ type FunctorList f '[] = '[]
497+ toFHList l = case l of
498+ HNil -> FHNil
499+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800
500+ _ -> error "toFHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
501+#endif
502+ fromFHList FHNil = HNil
503+
504+instance AllAreFunctors f t => AllAreFunctors f (h ': t) where
505+ type FunctorList f (h ': t) = f h ': FunctorList f t
506+ toFHList l = case l of
507+ a `HCons` b -> a `FHCons` toFHList b
508+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800
509+ _ -> error "toFHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
510+#endif
511+ fromFHList (a `FHCons` b) = a `HCons` fromFHList b
512+
513+-- | Convert a datastructure whose constituent parts are all 'Dynamic's into a
514+-- single 'Dynamic' whose value represents all the current values of the input's
515+-- consitutent 'Dynamic's.
516+collectDynPure :: ( RebuildSortedHList (HListElems b)
517+ , IsHList a, IsHList b
518+ , AllAreFunctors (Dynamic t) (HListElems b)
519+ , Reflex t
520+ , HListElems a ~ FunctorList (Dynamic t) (HListElems b)
521+ ) => a -> Dynamic t b
522+collectDynPure ds = fmap fromHList $ distributeFHListOverDynPure $ toFHList $ toHList ds
523+
524+-- | Poor man's 'Generic's for product types only.
525+class IsHList a where
526+ type HListElems a :: [*]
527+ toHList :: a -> HList (HListElems a)
528+ fromHList :: HList (HListElems a) -> a
529+
530+instance IsHList (a, b) where
531+ type HListElems (a, b) = [a, b]
532+ toHList (a, b) = hBuild a b
533+ fromHList l = case l of
534+ a `HCons` b `HCons` HNil -> (a, b)
535+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800
536+ _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
537+#endif
538+
539+instance IsHList (a, b, c, d) where
540+ type HListElems (a, b, c, d) = [a, b, c, d]
541+ toHList (a, b, c, d) = hBuild a b c d
542+ fromHList l = case l of
543+ a `HCons` b `HCons` c `HCons` d `HCons` HNil -> (a, b, c, d)
544+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800
545+ _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
546+#endif
547+
548+instance IsHList (a, b, c, d, e, f) where
549+ type HListElems (a, b, c, d, e, f) = [a, b, c, d, e, f]
550+ toHList (a, b, c, d, e, f) = hBuild a b c d e f
551+ fromHList l = case l of
552+ a `HCons` b `HCons` c `HCons` d `HCons` e `HCons` f `HCons` HNil -> (a, b, c, d, e, f)
553+#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800
554+ _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139
555+#endif
556+
557+--------------------------------------------------------------------------------
558+-- Deprecated functions
559+--------------------------------------------------------------------------------
560+
561+-- | Map a function over a 'Dynamic'.
562+{-# DEPRECATED mapDyn "Use 'return . fmap f' instead of 'mapDyn f'; consider eliminating monadic style" #-}
563+mapDyn :: (Reflex t, Monad m) => (a -> b) -> Dynamic t a -> m (Dynamic t b)
564+mapDyn f = return . fmap f
565+
566+-- | Flipped version of 'mapDyn'.
567+{-# DEPRECATED forDyn "Use 'return . ffor a' instead of 'forDyn a'; consider eliminating monadic style" #-}
568+forDyn :: (Reflex t, Monad m) => Dynamic t a -> (a -> b) -> m (Dynamic t b)
569+forDyn a = return . ffor a
570+
571+-- | Split the 'Dynamic' into two 'Dynamic's, each taking the respective value
572+-- of the tuple.
573+{-# DEPRECATED splitDyn "Use 'return . splitDynPure' instead; consider eliminating monadic style" #-}
574+splitDyn :: (Reflex t, Monad m) => Dynamic t (a, b) -> m (Dynamic t a, Dynamic t b)
575+splitDyn = return . splitDynPure
576+
577+-- | Merge the 'Dynamic' values using their 'Monoid' instance.
578+{-# DEPRECATED mconcatDyn "Use 'return . mconcat' instead; consider eliminating monadic style" #-}
579+mconcatDyn :: forall t m a. (Reflex t, Monad m, Monoid a) => [Dynamic t a] -> m (Dynamic t a)
580+mconcatDyn = return . mconcat
581+
582+-- | This function no longer needs to be monadic; see 'distributeMapOverDynPure'.
583+{-# DEPRECATED distributeDMapOverDyn "Use 'return . distributeDMapOverDynPure' instead; consider eliminating monadic style" #-}
584+distributeDMapOverDyn :: (Reflex t, Monad m, GCompare k) => DMap k (Dynamic t) -> m (Dynamic t (DMap k Identity))
585+distributeDMapOverDyn = return . distributeDMapOverDynPure
586+
587+-- | Merge two 'Dynamic's into a new one using the provided function. The new
588+-- 'Dynamic' changes its value each time one of the original 'Dynamic's changes
589+-- its value.
590+{-# DEPRECATED combineDyn "Use 'return (zipDynWith f a b)' instead of 'combineDyn f a b'; consider eliminating monadic style" #-}
591+combineDyn :: forall t m a b c. (Reflex t, Monad m) => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> m (Dynamic t c)
592+combineDyn f a b = return $ zipDynWith f a b
593+
594+-- | A psuedo applicative version of ap for 'Dynamic'. Example useage:
595+--
596+-- > do
597+-- > person <- Person `mapDyn` dynFirstName
598+-- > `apDyn` dynListName
599+-- > `apDyn` dynAge
600+-- > `apDyn` dynAddress
601+{-# 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" #-}
602+#ifdef USE_TEMPLATE_HASKELL
603+{-# ANN apDyn "HLint: ignore Use fmap" #-}
604+#endif
605+apDyn :: forall t m a b. (Reflex t, Monad m)
606+ => m (Dynamic t (a -> b))
607+ -> Dynamic t a
608+ -> m (Dynamic t b)
609+apDyn m a = fmap (<*> a) m
610+
611+--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
612+-- | This function no longer needs to be monadic, so it has been replaced by
613+-- 'demuxed', which is pure.
614+{-# DEPRECATED getDemuxed "Use 'return . demuxed d' instead of 'getDemuxed d'; consider eliminating monadic style" #-}
615+getDemuxed :: (Reflex t, Monad m, Eq k) => Demux t k -> k -> m (Dynamic t Bool)
616+getDemuxed d = return . demuxed d
617+
618+-- | This function no longer needs to be monadic, so it has been replaced by
619+-- 'distributeFHListOverDynPure', which is pure.
620+{-# DEPRECATED distributeFHListOverDyn "Use 'return . distributeFHListOverDynPure' instead; consider eliminating monadic style" #-}
621+distributeFHListOverDyn :: forall t m l. (Reflex t, Monad m, RebuildSortedHList l) => FHList (Dynamic t) l -> m (Dynamic t (HList l))
622+distributeFHListOverDyn = return . distributeFHListOverDynPure
623+
624+-- | This function no longer needs to be monadic, so it has been replaced by
625+-- 'collectDynPure', which is pure.
626+{-# DEPRECATED collectDyn "Use 'return . collectDynPure' instead; consider eliminating monadic style" #-}
627+collectDyn :: ( RebuildSortedHList (HListElems b)
628+ , IsHList a, IsHList b
629+ , AllAreFunctors (Dynamic t) (HListElems b)
630+ , Reflex t, Monad m
631+ , HListElems a ~ FunctorList (Dynamic t) (HListElems b)
632+ ) => a -> m (Dynamic t b)
633+collectDyn = return . collectDynPure
634+
635+-- | This function has been renamed to 'tagPromptlyDyn' to clarify its
636+-- semantics.
637+{-# DEPRECATED tagDyn "Use 'tagPromptlyDyn' instead" #-}
638+tagDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a
639+tagDyn = tagPromptlyDyn
640+
641+-- | This function has been renamed to 'attachPromptlyDyn' to clarify its
642+-- semantics.
643+{-# DEPRECATED attachDyn "Use 'attachPromptlyDyn' instead" #-}
644+attachDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b)
645+attachDyn = attachPromptlyDyn
646+
647+-- | This function has been renamed to 'attachPromptlyDynWith' to clarify its
648+-- semantics.
649+{-# DEPRECATED attachDynWith "Use 'attachPromptlyDynWith' instead" #-}
650+attachDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c
651+attachDynWith = attachPromptlyDynWith
652+
653+-- | This function has been renamed to 'attachPromptlyDynWithMaybe' to clarify
654+-- its semantics.
655+{-# DEPRECATED attachDynWithMaybe "Use 'attachPromptlyDynWithMaybe' instead" #-}
656+attachDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c
657+attachDynWithMaybe = attachPromptlyDynWithMaybe
658+
659+-- | Combine an inner and outer 'Dynamic' such that the resulting 'Dynamic''s
660+-- current value will always be equal to the current value's current value, and
661+-- will change whenever either the inner or the outer (or both) values change.
662+{-# DEPRECATED joinDyn "Use 'join' instead" #-}
663+joinDyn :: Reflex t => Dynamic t (Dynamic t a) -> Dynamic t a
664+joinDyn = join
665+
666+-- | WARNING: This function is only pure if @a@'s 'Eq' instance tests
667+-- representational equality. Use 'holdUniqDyn' instead, which is pure in all
668+-- circumstances. Also, note that, unlike 'nub', this function does not prevent
669+-- all recurrences of a value, only consecutive recurrences.
670+{-# DEPRECATED nubDyn "Use 'holdUniqDyn' instead; note that it returns a MonadHold action rather than a pure Dynamic" #-}
671+nubDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a
672+nubDyn = uniqDyn
673+
674+-- | WARNING: This function is only pure if @a@'s 'Eq' instance tests
675+-- representational equality. Use 'holdUniqDyn' instead, which is pure in all
676+-- circumstances.
677+{-# DEPRECATED uniqDyn "Use 'holdUniqDyn' instead; note that it returns a MonadHold action rather than a pure Dynamic" #-}
678+uniqDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a
679+uniqDyn = uniqDynBy (==)
680+
681+-- | WARNING: This function is impure. Use 'holdUniqDynBy' instead.
682+{-# DEPRECATED uniqDynBy "Use 'holdUniqDynBy' instead; note that it returns a MonadHold action rather than a pure Dynamic" #-}
683+uniqDynBy :: Reflex t => (a -> a -> Bool) -> Dynamic t a -> Dynamic t a
684+uniqDynBy eq d =
685+ let e' = attachWithMaybe (\x x' -> if x' `eq` x then Nothing else Just x') (current d) (updated d)
686+ in unsafeDynamic (current d) e'
src/Reflex/Dynamic/TH.hsnew file+130
@@ -0,0 +1,130 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE EmptyDataDecls #-}
3+{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE PatternGuards #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TemplateHaskell #-}
7+{-# LANGUAGE TypeOperators #-}
8+#ifdef USE_REFLEX_OPTIMIZER
9+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
10+#endif
11+-- | Template Haskell helper functions for building complex 'Dynamic' values.
12+module Reflex.Dynamic.TH
13+ ( qDynPure
14+ , unqDyn
15+ , mkDynPure
16+ -- * Deprecated functions
17+ , qDyn
18+ , mkDyn
19+ ) where
20+
21+import Reflex.Dynamic
22+
23+import Control.Monad.State
24+import Data.Data
25+import Data.Generics
26+import Data.Monoid
27+import qualified Language.Haskell.Exts as Hs
28+import qualified Language.Haskell.Meta.Syntax.Translate as Hs
29+import Language.Haskell.TH
30+import Language.Haskell.TH.Quote
31+import qualified Language.Haskell.TH.Syntax as TH
32+
33+-- | Quote a 'Dynamic' expression. Within the quoted expression, you can use
34+-- @$(unqDyn [| x |])@ to refer to any expression @x@ of type @Dynamic t a@; the
35+-- unquoted result will be of type @a@
36+qDynPure :: Q Exp -> Q Exp
37+qDynPure qe = do
38+ e <- qe
39+ let f :: forall d. Data d => d -> StateT [(Name, Exp)] Q d
40+ f d = case eqT of
41+ Just (Refl :: d :~: Exp)
42+ | AppE (VarE m) eInner <- d
43+ , m == 'unqMarker
44+ -> do n <- lift $ newName "dynamicQuotedExpressionVariable"
45+ modify ((n, eInner):)
46+ return $ VarE n
47+ _ -> gmapM f d
48+ (e', exprsReversed) <- runStateT (gmapM f e) []
49+ let exprs = reverse exprsReversed
50+ arg = foldr (\a b -> ConE 'FHCons `AppE` a `AppE` b) (ConE 'FHNil) $ map snd exprs
51+ param = foldr (\a b -> ConP 'HCons [VarP a, b]) (ConP 'HNil []) $ map fst exprs
52+ [| $(return $ LamE [param] e') <$> distributeFHListOverDynPure $(return arg) |]
53+
54+-- | Antiquote a 'Dynamic' expression. This can /only/ be used inside of a
55+-- 'qDyn' quotation.
56+unqDyn :: Q Exp -> Q Exp
57+unqDyn e = [| unqMarker $e |]
58+
59+-- | This type represents an occurrence of unqDyn before it has been processed
60+-- by qDyn. If you see it in a type error, it probably means that unqDyn has
61+-- been used outside of a qDyn context.
62+data UnqDyn
63+
64+-- unqMarker must not be exported; it is used only as a way of smuggling data
65+-- from unqDyn to qDyn
66+
67+--TODO: It would be much nicer if the TH AST was extensible to support this kind of thing without trickery
68+unqMarker :: a -> UnqDyn
69+unqMarker = error "An unqDyn expression was used outside of a qDyn expression"
70+
71+-- | Create a 'Dynamic' value using other 'Dynamic's as inputs. The result is
72+-- sometimes more concise and readable than the equivalent 'Applicative'-based
73+-- expression. For example:
74+--
75+-- > [mkDyn| $x + $v * $t + 1/2 * $a * $t ^ 2 |]
76+--
77+-- would have a very cumbersome 'Applicative' encoding.
78+mkDynPure :: QuasiQuoter
79+mkDynPure = QuasiQuoter
80+ { quoteExp = mkDynExp
81+ , quotePat = error "mkDyn: pattern splices are not supported"
82+ , quoteType = error "mkDyn: type splices are not supported"
83+ , quoteDec = error "mkDyn: declaration splices are not supported"
84+ }
85+
86+mkDynExp :: String -> Q Exp
87+mkDynExp s = case Hs.parseExpWithMode (Hs.defaultParseMode { Hs.extensions = [ Hs.EnableExtension Hs.TemplateHaskell ] }) s of
88+ Hs.ParseFailed (Hs.SrcLoc _ l c) err -> fail $ "mkDyn:" <> show l <> ":" <> show c <> ": " <> err
89+ Hs.ParseOk e -> qDynPure $ return $ everywhere (id `extT` reinstateUnqDyn) $ Hs.toExp $ everywhere (id `extT` antiE) e
90+ where TH.Name (TH.OccName occName) (TH.NameG _ _ (TH.ModName modName)) = 'unqMarker
91+#if MIN_VERSION_haskell_src_exts(1,18,0)
92+ antiE :: Hs.Exp Hs.SrcSpanInfo -> Hs.Exp Hs.SrcSpanInfo
93+ antiE x = case x of
94+ Hs.SpliceExp l se ->
95+ Hs.App l (Hs.Var l $ Hs.Qual l (Hs.ModuleName l modName) (Hs.Ident l occName)) $ case se of
96+ Hs.IdSplice l2 v -> Hs.Var l2 $ Hs.UnQual l2 $ Hs.Ident l2 v
97+ Hs.ParenSplice _ ps -> ps
98+ _ -> x
99+#else
100+ antiE x = case x of
101+ Hs.SpliceExp se ->
102+ Hs.App (Hs.Var $ Hs.Qual (Hs.ModuleName modName) (Hs.Ident occName)) $ case se of
103+ Hs.IdSplice v -> Hs.Var $ Hs.UnQual $ Hs.Ident v
104+ Hs.ParenSplice ps -> ps
105+ _ -> x
106+#endif
107+ reinstateUnqDyn (TH.Name (TH.OccName occName') (TH.NameQ (TH.ModName modName')))
108+ | modName == modName' && occName == occName' = 'unqMarker
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.hsnew file+105
@@ -0,0 +1,105 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE MagicHash #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
5+#ifdef USE_REFLEX_OPTIMIZER
6+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
7+#endif
8+-- | This module provides a variation of 'Dynamic' values that uses cheap
9+-- pointer equality checks to reduce the amount of signal propagation needed.
10+module Reflex.Dynamic.Uniq
11+ ( UniqDynamic
12+ , uniqDynamic
13+ , fromUniqDynamic
14+ , alreadyUniqDynamic
15+ ) where
16+
17+import Control.Applicative (Applicative (..))
18+import GHC.Exts
19+import Reflex.Class
20+
21+-- | A 'Dynamic' whose 'updated' 'Event' will never fire with the same value as
22+-- the 'current' 'Behavior''s contents. In order to maintain this constraint,
23+-- the value inside a 'UniqDynamic' is always evaluated to
24+-- <https://wiki.haskell.org/Weak_head_normal_form weak head normal form>.
25+--
26+-- Internally, 'UniqDynamic' uses pointer equality as a heuristic to avoid
27+-- unnecessary update propagation; this is much more efficient than performing
28+-- full comparisons. However, when the 'UniqDynamic' is converted back into a
29+-- regular 'Dynamic', a full comparison is performed.
30+newtype UniqDynamic t a = UniqDynamic { unUniqDynamic :: Dynamic t a }
31+
32+-- | Construct a 'UniqDynamic' by eliminating redundant updates from a 'Dynamic'.
33+uniqDynamic :: Reflex t => Dynamic t a -> UniqDynamic t a
34+uniqDynamic d = UniqDynamic $ unsafeBuildDynamic (sample $ current d) $ flip pushCheap (updated d) $ \new -> do
35+ old <- sample $ current d --TODO: Is it better to sample ourselves here?
36+ return $ unsafeJustChanged old new
37+
38+-- | Retrieve a normal 'Dynamic' from a 'UniqDynamic'. This will perform a
39+-- final check using the output type's 'Eq' instance to ensure deterministic
40+-- behavior.
41+--
42+-- WARNING: If used with a type whose 'Eq' instance is not law-abiding -
43+-- specifically, if there are cases where @x /= x@, 'fromUniqDynamic' may
44+-- eliminate more 'updated' occurrences than it should. For example, NaN values
45+-- of 'Double' and 'Float' are considered unequal to themselves by the 'Eq'
46+-- instance, but can be equal by pointer equality. This may cause 'UniqDynamic'
47+-- to lose changes from NaN to NaN.
48+fromUniqDynamic :: (Reflex t, Eq a) => UniqDynamic t a -> Dynamic t a
49+fromUniqDynamic (UniqDynamic d) = unsafeDynamic (current d) e'
50+ where
51+ -- Only consider values different if they fail both pointer equality /and/
52+ -- 'Eq' equality. This is to make things a bit more deterministic in the
53+ -- case of unlawful 'Eq' instances. However, it is still possible to
54+ -- achieve nondeterminism by constructing elements that are identical in
55+ -- value, unequal according to 'Eq', and nondeterministically equal or
56+ -- nonequal by pointer quality. I suspect that it is impossible to make the
57+ -- behavior deterministic in this case.
58+ superEq a b = a `unsafePtrEq` b || a == b
59+ e' = attachWithMaybe (\x x' -> if x' `superEq` x then Nothing else Just x') (current d) (updated d)
60+
61+-- | Create a UniqDynamic without uniqing it on creation. This will be slightly
62+-- faster than uniqDynamic when used with a Dynamic whose values are always (or
63+-- nearly always) different from its previous values; if used with a Dynamic
64+-- whose values do not change frequently, it may be much slower than uniqDynamic
65+alreadyUniqDynamic :: Dynamic t a -> UniqDynamic t a
66+alreadyUniqDynamic = UniqDynamic
67+
68+unsafePtrEq :: a -> a -> Bool
69+unsafePtrEq a b = case a `seq` b `seq` reallyUnsafePtrEquality# a b of
70+ 0# -> False
71+ _ -> True
72+
73+unsafeJustChanged :: a -> a -> Maybe a
74+unsafeJustChanged old new =
75+ if old `unsafePtrEq` new
76+ then Nothing
77+ else Just new
78+
79+instance Reflex t => Accumulator t (UniqDynamic t) where
80+ accumMaybeM f z e = do
81+ let f' old change = do
82+ mNew <- f old change
83+ return $ unsafeJustChanged old =<< mNew
84+ d <- accumMaybeMDyn 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
91+ return (UniqDynamic d, out)
92+
93+instance Reflex t => Functor (UniqDynamic t) where
94+ fmap f (UniqDynamic d) = uniqDynamic $ fmap f d
95+
96+instance Reflex t => Applicative (UniqDynamic t) where
97+ pure = UniqDynamic . constDyn
98+ UniqDynamic a <*> UniqDynamic b = uniqDynamic $ a <*> b
99+ _ *> b = b
100+ a <* _ = a
101+
102+instance Reflex t => Monad (UniqDynamic t) where
103+ UniqDynamic x >>= f = uniqDynamic $ x >>= unUniqDynamic . f
104+ _ >> b = b
105+ return = pure
src/Reflex/DynamicWriter.hsnew file+7
@@ -0,0 +1,7 @@
1+module Reflex.DynamicWriter
2+ {-# DEPRECATED "Use 'Reflex.DynamicWriter.Class' and 'Reflex.DynamicWrite.Base' instead, or just import 'Reflex'" #-}
3+ ( module X
4+ ) where
5+
6+import Reflex.DynamicWriter.Base as X
7+import Reflex.DynamicWriter.Class as X
src/Reflex/DynamicWriter/Base.hsnew file+213
@@ -0,0 +1,213 @@
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 TypeFamilies #-}
10+{-# LANGUAGE UndecidableInstances #-}
11+#ifdef USE_REFLEX_OPTIMIZER
12+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
13+#endif
14+module Reflex.DynamicWriter.Base
15+ ( DynamicWriterT (..)
16+ , runDynamicWriterT
17+ , withDynamicWriterT
18+ ) where
19+
20+import Control.Monad.Exception
21+import Control.Monad.Identity
22+import Control.Monad.IO.Class
23+import Control.Monad.Reader
24+import Control.Monad.Ref
25+import Control.Monad.State.Strict
26+import Data.Align
27+import Data.Dependent.Map (DMap)
28+import qualified Data.Dependent.Map as DMap
29+import Data.FastMutableIntMap
30+import Data.Functor.Misc
31+import Data.IntMap (IntMap)
32+import qualified Data.IntMap as IntMap
33+import Data.Map (Map)
34+import qualified Data.Map as Map
35+import Data.Semigroup
36+import Data.Some (Some)
37+import Data.These
38+import Reflex.Class
39+import Reflex.DynamicWriter.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+mergeIntMapDynIncremental :: Reflex t => Incremental t (PatchIntMap (Dynamic t v)) -> Incremental t (PatchIntMap v)
59+mergeIntMapDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues
60+ where changedValues = fmap (PatchIntMap . fmap Just) $ mergeIntMapIncremental $ mapIncrementalMapValues updated a
61+ addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchIntMap m) -> PatchIntMap <$> mapM (mapM (sample . current)) m
62+
63+mergeDynIncrementalWithMove :: forall t k v. (Reflex t, Ord k) => Incremental t (PatchMapWithMove k (Dynamic t v)) -> Incremental t (PatchMapWithMove k v)
64+mergeDynIncrementalWithMove a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ alignWith f addedAndRemovedValues changedValues
65+ where changedValues = mergeMapIncrementalWithMove $ mapIncrementalMapValues updated a
66+ addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ fmap unsafePatchMapWithMove . mapM (mapM (sample . current)) . unPatchMapWithMove
67+ f :: These (PatchMapWithMove k v) (Map k v) -> PatchMapWithMove k v
68+ f x = unsafePatchMapWithMove $
69+ let (p, changed) = case x of
70+ This p_ -> (unPatchMapWithMove p_, mempty)
71+ That c -> (mempty, c)
72+ These p_ c -> (unPatchMapWithMove p_, c)
73+ (pWithNewVals, noLongerMoved) = flip runState [] $ forM p $ MapWithMove.nodeInfoMapMFrom $ \case
74+ MapWithMove.From_Insert v -> return $ MapWithMove.From_Insert v
75+ MapWithMove.From_Delete -> return MapWithMove.From_Delete
76+ MapWithMove.From_Move k -> case Map.lookup k changed of
77+ Nothing -> return $ MapWithMove.From_Move k
78+ Just v -> do
79+ modify (k:)
80+ return $ MapWithMove.From_Insert v
81+ noLongerMovedMap = Map.fromList $ fmap (\k -> (k, ())) noLongerMoved
82+ in Map.differenceWith (\e _ -> Just $ MapWithMove.nodeInfoSetTo Nothing e) pWithNewVals noLongerMovedMap --TODO: Check if any in the second map are not covered?
83+
84+-- | A basic implementation of 'MonadDynamicWriter'.
85+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
86+
87+instance MonadRef m => MonadRef (DynamicWriterT t w m) where
88+ type Ref (DynamicWriterT t w m) = Ref m
89+ newRef = lift . newRef
90+ readRef = lift . readRef
91+ writeRef r = lift . writeRef r
92+
93+instance MonadAtomicRef m => MonadAtomicRef (DynamicWriterT t w m) where
94+ atomicModifyRef r = lift . atomicModifyRef r
95+
96+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWriterT t w m) where
97+ newEventWithTrigger = lift . newEventWithTrigger
98+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
99+
100+-- | Run a 'DynamicWriterT' action. The dynamic writer output will be provided
101+-- along with the result of the action.
102+runDynamicWriterT :: (MonadFix m, Reflex t, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)
103+runDynamicWriterT (DynamicWriterT a) = do
104+ (result, ws) <- runStateT a []
105+ return (result, mconcat $ reverse ws)
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 MonadState s m => MonadState s (DynamicWriterT t w m) where
129+ get = lift get
130+ put = lift . put
131+
132+newtype DynamicWriterTLoweredResult t w v a = DynamicWriterTLoweredResult (v a, Dynamic t w)
133+
134+-- | When the execution of a 'DynamicWriterT' action is adjusted using
135+-- 'Adjustable', the 'Dynamic' output of that action will also be updated to
136+-- match.
137+instance (Adjustable t m, MonadFix m, Monoid w, MonadHold t m, Reflex t) => Adjustable t (DynamicWriterT t w m) where
138+ runWithReplace a0 a' = do
139+ (result0, result') <- lift $ runWithReplace (runDynamicWriterT a0) $ runDynamicWriterT <$> a'
140+ tellDyn . join =<< holdDyn (snd result0) (snd <$> result')
141+ return (fst result0, fst <$> result')
142+ traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustImpl traverseIntMapWithKeyWithAdjust mergeIntMapDynIncremental
143+ traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap weakenPatchDMapWith mergeDynIncremental
144+ traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove weakenPatchDMapWithMoveWith mergeDynIncrementalWithMove
145+
146+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)
147+ => ( (forall a. k a -> v a -> m (DynamicWriterTLoweredResult t w v' a))
148+ -> DMap k v
149+ -> Event t (p k v)
150+ -> m (DMap k (DynamicWriterTLoweredResult t w v'), Event t (p k (DynamicWriterTLoweredResult t w v')))
151+ )
152+ -> ((forall a. DynamicWriterTLoweredResult t w v' a -> v' a) -> p k (DynamicWriterTLoweredResult t w v') -> p k v')
153+ -> ((forall a. DynamicWriterTLoweredResult t w v' a -> Dynamic t w) -> p k (DynamicWriterTLoweredResult t w v') -> p' (Some k) (Dynamic t w))
154+ -> (Incremental t (p' (Some k) (Dynamic t w)) -> Incremental t (p' (Some k) w))
155+ -> (forall a. k a -> v a -> DynamicWriterT t w m (v' a))
156+ -> DMap k v
157+ -> Event t (p k v)
158+ -> DynamicWriterT t w m (DMap k v', Event t (p k v'))
159+traverseDMapWithKeyWithAdjustImpl base mapPatch weakenPatchWith mergeMyDynIncremental f (dm0 :: DMap k v) dm' = do
160+ (result0, result') <- lift $ base (\k v -> fmap DynamicWriterTLoweredResult $ runDynamicWriterT $ f k v) dm0 dm'
161+ let getValue (DynamicWriterTLoweredResult (v, _)) = v
162+ getWritten (DynamicWriterTLoweredResult (_, w)) = w
163+ liftedResult0 = DMap.map getValue result0
164+ liftedResult' = ffor result' $ mapPatch getValue
165+ liftedWritten0 :: Map (Some k) (Dynamic t w)
166+ liftedWritten0 = weakenDMapWith getWritten result0
167+ liftedWritten' = ffor result' $ weakenPatchWith getWritten
168+ --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics
169+ i <- holdIncremental liftedWritten0 liftedWritten'
170+ tellDyn $ fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeMyDynIncremental i
171+ return (liftedResult0, liftedResult')
172+
173+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')
174+ => ( (IntMap.Key -> v -> m (v', Dynamic t w))
175+ -> IntMap v
176+ -> Event t (p v)
177+ -> m (IntMap (v', Dynamic t w), Event t (p (v', Dynamic t w)))
178+ )
179+ -> (Incremental t (p' (Dynamic t w)) -> Incremental t (p' w))
180+ -> (IntMap.Key -> v -> DynamicWriterT t w m v')
181+ -> IntMap v
182+ -> Event t (p v)
183+ -> DynamicWriterT t w m (IntMap v', Event t (p v'))
184+traverseIntMapWithKeyWithAdjustImpl base mergeMyDynIncremental f (dm0 :: IntMap v) dm' = do
185+ (result0, result') <- lift $ base (\k v -> runDynamicWriterT $ f k v) dm0 dm'
186+ let liftedResult0 = fmap fst result0
187+ liftedResult' = fmap (fmap fst) result'
188+ liftedWritten0 :: IntMap (Dynamic t w)
189+ liftedWritten0 = fmap snd result0
190+ liftedWritten' = fmap (fmap snd) result'
191+ --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics
192+ i <- holdIncremental liftedWritten0 liftedWritten'
193+ tellDyn $ fmap (mconcat . IntMap.elems) $ incrementalToDynamic $ mergeMyDynIncremental i
194+ return (liftedResult0, liftedResult')
195+
196+-- | Map a function over the output of a 'DynamicWriterT'.
197+withDynamicWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m, MonadFix m)
198+ => (w -> w')
199+ -> DynamicWriterT t w m a
200+ -> DynamicWriterT t w' m a
201+withDynamicWriterT f dw = do
202+ (r, d) <- lift $ do
203+ (r, d) <- runDynamicWriterT dw
204+ let d' = fmap f d
205+ return (r, d')
206+ tellDyn d
207+ return r
208+
209+instance Requester t m => Requester t (DynamicWriterT t w m) where
210+ type Request (DynamicWriterT t w m) = Request m
211+ type Response (DynamicWriterT t w m) = Response m
212+ requesting = lift . requesting
213+ requesting_ = lift . requesting_
src/Reflex/DynamicWriter/Class.hsnew file+24
@@ -0,0 +1,24 @@
1+-- | This module defines the 'MonadDynamicWriter' class.
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE UndecidableInstances #-}
7+#ifdef USE_REFLEX_OPTIMIZER
8+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
9+#endif
10+module Reflex.DynamicWriter.Class
11+ ( MonadDynamicWriter (..)
12+ ) where
13+
14+import Control.Monad.Reader (ReaderT, lift)
15+import Reflex.Class (Dynamic)
16+
17+-- | 'MonadDynamicWriter' efficiently collects 'Dynamic' values using 'tellDyn'
18+-- and combines them monoidally to provide a 'Dynamic' result.
19+class (Monad m, Monoid w) => MonadDynamicWriter t w m | m -> t w where
20+ tellDyn :: Dynamic t w -> m ()
21+
22+instance MonadDynamicWriter t w m => MonadDynamicWriter t w (ReaderT r m) where
23+ tellDyn = lift . tellDyn
24+
src/Reflex/EventWriter.hsnew file+7
@@ -0,0 +1,7 @@
1+module Reflex.EventWriter
2+ {-# DEPRECATED "Use 'Reflex.EventWriter.Class' and 'Reflex.EventWriter.Base' instead, or just import 'Reflex'" #-}
3+ ( module X
4+ ) where
5+
6+import Reflex.EventWriter.Base as X
7+import Reflex.EventWriter.Class as X
src/Reflex/EventWriter/Base.hsnew file+281
@@ -0,0 +1,281 @@
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+ , withEventWriterT
22+ ) where
23+
24+import Reflex.Class
25+import Reflex.EventWriter.Class (EventWriter, tellEvent)
26+import Reflex.Host.Class
27+import Reflex.PerformEvent.Class
28+import Reflex.PostBuild.Class
29+import Reflex.Query.Class
30+import Reflex.Requester.Class
31+import Reflex.TriggerEvent.Class
32+
33+import Control.Monad.Exception
34+import Control.Monad.Identity
35+import Control.Monad.Reader
36+import Control.Monad.Ref
37+import Control.Monad.State.Strict
38+import Data.Dependent.Map (DMap, DSum (..))
39+import qualified Data.Dependent.Map as DMap
40+import Data.Foldable
41+import Data.Functor.Compose
42+import Data.Functor.Misc
43+import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))
44+import Data.IntMap.Strict (IntMap)
45+import qualified Data.IntMap.Strict as IntMap
46+import Data.List.NonEmpty (NonEmpty (..))
47+import Data.Map (Map)
48+import Data.Semigroup
49+import Data.Some (Some)
50+import Data.Tuple
51+import Data.Type.Equality
52+
53+import Unsafe.Coerce
54+
55+{-# DEPRECATED TellId "Do not construct this directly; use tellId instead" #-}
56+newtype TellId w x
57+ = TellId Int -- ^ WARNING: Do not construct this directly; use 'TellId' instead
58+ deriving (Show, Eq, Ord, Enum)
59+
60+tellId :: Int -> TellId w w
61+tellId = TellId
62+{-# INLINE tellId #-}
63+
64+tellIdRefl :: TellId w x -> w :~: x
65+tellIdRefl _ = unsafeCoerce Refl
66+
67+withTellIdRefl :: TellId w x -> (w ~ x => r) -> r
68+withTellIdRefl tid r = case tellIdRefl tid of
69+ Refl -> r
70+
71+instance GEq (TellId w) where
72+ a `geq` b =
73+ withTellIdRefl a $
74+ withTellIdRefl b $
75+ if a == b
76+ then Just Refl
77+ else Nothing
78+
79+instance GCompare (TellId w) where
80+ a `gcompare` b =
81+ withTellIdRefl a $
82+ withTellIdRefl b $
83+ case a `compare` b of
84+ LT -> GLT
85+ EQ -> GEQ
86+ GT -> GGT
87+
88+data EventWriterState t w = EventWriterState
89+ { _eventWriterState_nextId :: {-# UNPACK #-} !Int -- Always negative (and decreasing over time)
90+ , _eventWriterState_told :: ![DSum (TellId w) (Event t)] -- In increasing order
91+ }
92+
93+-- | A basic implementation of 'EventWriter'.
94+newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (EventWriterState t w) m a }
95+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
96+
97+-- | Run a 'EventWriterT' action.
98+runEventWriterT :: forall t m w a. (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)
99+runEventWriterT (EventWriterT a) = do
100+ (result, requests) <- runStateT a $ EventWriterState (-1) []
101+ let combineResults :: DMap (TellId w) Identity -> w
102+ combineResults = sconcat
103+ . (\(h : t) -> h :| t) -- Unconditional; 'merge' guarantees that it will only fire with non-empty DMaps
104+ . 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
105+ 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
106+
107+instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m) where
108+ tellEvent w = EventWriterT $ modify $ \old ->
109+ let myId = _eventWriterState_nextId old
110+ in EventWriterState
111+ { _eventWriterState_nextId = pred myId
112+ , _eventWriterState_told = (tellId myId :=> w) : _eventWriterState_told old
113+ }
114+
115+instance MonadTrans (EventWriterT t w) where
116+ lift = EventWriterT . lift
117+
118+instance MonadSample t m => MonadSample t (EventWriterT t w m) where
119+ sample = lift . sample
120+
121+instance MonadHold t m => MonadHold t (EventWriterT t w m) where
122+ {-# INLINABLE hold #-}
123+ hold v0 = lift . hold v0
124+ {-# INLINABLE holdDyn #-}
125+ holdDyn v0 = lift . holdDyn v0
126+ {-# INLINABLE holdIncremental #-}
127+ holdIncremental v0 = lift . holdIncremental v0
128+ {-# INLINABLE buildDynamic #-}
129+ buildDynamic a0 = lift . buildDynamic a0
130+ {-# INLINABLE headE #-}
131+ headE = lift . headE
132+
133+instance (Reflex t, Adjustable t m, MonadHold t m, Semigroup w) => Adjustable t (EventWriterT t w m) where
134+ runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
135+ traverseIntMapWithKeyWithAdjust = sequenceIntMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElements mergeIntIncremental
136+ traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElements mergeMapIncremental
137+ traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElements mergeMapIncrementalWithMove
138+
139+instance Requester t m => Requester t (EventWriterT t w m) where
140+ type Request (EventWriterT t w m) = Request m
141+ type Response (EventWriterT t w m) = Response m
142+ requesting = lift . requesting
143+ requesting_ = lift . requesting_
144+
145+-- | Given a function like 'runWithReplace' for the underlying monad, implement
146+-- 'runWithReplace' for 'EventWriterT'. This is necessary when the underlying
147+-- monad doesn't have a 'Adjustable' instance or to override the default
148+-- 'Adjustable' behavior.
149+runWithReplaceEventWriterTWith :: forall m t w a b. (Reflex t, MonadHold t m, Semigroup w)
150+ => (forall a' b'. m a' -> Event t (m b') -> EventWriterT t w m (a', Event t b'))
151+ -> EventWriterT t w m a
152+ -> Event t (EventWriterT t w m b)
153+ -> EventWriterT t w m (a, Event t b)
154+runWithReplaceEventWriterTWith f a0 a' = do
155+ (result0, result') <- f (runEventWriterT a0) $ fmapCheap runEventWriterT a'
156+ request <- holdDyn (snd result0) $ fmapCheap snd result'
157+ -- 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.)
158+ tellEvent $ coincidence $ updated request
159+ tellEvent $ switch $ current request
160+ return (fst result0, fmapCheap fst result')
161+
162+-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceIntMapWithAdjust'.
163+sequenceIntMapWithAdjustEventWriterTWith :: forall t m p w v v'. (Reflex t, MonadHold t m, Semigroup w, Semigroup w, Functor p, Patch (p (Event t w)), PatchTarget (p (Event t w)) ~ IntMap (Event t w))
164+ => ( (IntMap.Key -> v -> m (Event t w, v'))
165+ -> IntMap v
166+ -> Event t (p v)
167+ -> EventWriterT t w m (IntMap (Event t w, v'), Event t (p (Event t w, v')))
168+ )
169+ -> (p (Event t w) -> [Event t w])
170+ -> (Incremental t (p (Event t w)) -> Event t (IntMap w))
171+ -> (IntMap.Key -> v -> EventWriterT t w m v')
172+ -> IntMap v
173+ -> Event t (p v)
174+ -> EventWriterT t w m (IntMap v', Event t (p v'))
175+sequenceIntMapWithAdjustEventWriterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do
176+ let f' :: IntMap.Key -> v -> m (Event t w, v')
177+ f' k v = swap <$> runEventWriterT (f k v)
178+ (children0, children') <- base f' dm0 dm'
179+ let result0 = fmap snd children0
180+ result' = fmapCheap (fmap snd) children'
181+ requests0 :: IntMap (Event t w)
182+ requests0 = fmap fst children0
183+ requests' :: Event t (p (Event t w))
184+ requests' = fmapCheap (fmap fst) children'
185+ childRequestMap :: Incremental t (p (Event t w)) <- holdIncremental requests0 requests'
186+ tellEventsPromptly requests' patchNewElements $ mergePatchIncremental childRequestMap
187+ return (result0, result')
188+
189+-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.
190+sequenceDMapWithAdjustEventWriterTWith :: forall t m p p' w k v v'. (Reflex t, MonadHold t m, Semigroup w, Patch (p' (Some k) (Event t w)), PatchTarget (p' (Some k) (Event t w)) ~ Map (Some k) (Event t w))
191+ => ( (forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a))
192+ -> DMap k v
193+ -> Event t (p k v)
194+ -> EventWriterT t w m (DMap k (Compose ((,) (Event t w)) v'), Event t (p k (Compose ((,) (Event t w)) v')))
195+ )
196+ -> ((forall a. Compose ((,) (Event t w)) v' a -> v' a) -> p k (Compose ((,) (Event t w)) v') -> p k v')
197+ -> ((forall a. Compose ((,) (Event t w)) v' a -> Event t w) -> p k (Compose ((,) (Event t w)) v') -> p' (Some k) (Event t w))
198+ -> (p' (Some k) (Event t w) -> [Event t w])
199+ -> (Incremental t (p' (Some k) (Event t w)) -> Event t (Map (Some k) w))
200+ -> (forall a. k a -> v a -> EventWriterT t w m (v' a))
201+ -> DMap k v
202+ -> Event t (p k v)
203+ -> EventWriterT t w m (DMap k v', Event t (p k v'))
204+sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do
205+ let f' :: forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a)
206+ f' k v = Compose . swap <$> runEventWriterT (f k v)
207+ (children0, children') <- base f' dm0 dm'
208+ let result0 = DMap.map (snd . getCompose) children0
209+ result' = fforCheap children' $ mapPatch $ snd . getCompose
210+ requests0 :: Map (Some k) (Event t w)
211+ requests0 = weakenDMapWith (fst . getCompose) children0
212+ requests' :: Event t (p' (Some k) (Event t w))
213+ requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose
214+ childRequestMap :: Incremental t (p' (Some k) (Event t w)) <- holdIncremental requests0 requests'
215+ tellEventsPromptly requests' patchNewElements $ mergePatchIncremental childRequestMap
216+ return (result0, result')
217+
218+tellEventsPromptly
219+ :: ( Foldable f
220+ , Reflex t
221+ , EventWriter t w m
222+ )
223+ => Event t a
224+ -> (a -> [Event t w])
225+ -> Event t (f w)
226+ -> m ()
227+tellEventsPromptly requests' patchNewElements mergedChildRequestMap = do
228+ -- 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.)
229+ tellEvent $ coincidence $ fmapCheap (mconcat . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
230+ tellEvent $ fforMaybeCheap mergedChildRequestMap $ \m -> case toList m of
231+ [] -> Nothing
232+ h : t -> Just $ sconcat $ h :| t
233+
234+instance PerformEvent t m => PerformEvent t (EventWriterT t w m) where
235+ type Performable (EventWriterT t w m) = Performable m
236+ performEvent_ = lift . performEvent_
237+ performEvent = lift . performEvent
238+
239+instance PostBuild t m => PostBuild t (EventWriterT t w m) where
240+ getPostBuild = lift getPostBuild
241+
242+instance TriggerEvent t m => TriggerEvent t (EventWriterT t w m) where
243+ newTriggerEvent = lift newTriggerEvent
244+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
245+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
246+
247+instance MonadReader r m => MonadReader r (EventWriterT t w m) where
248+ ask = lift ask
249+ local f (EventWriterT a) = EventWriterT $ mapStateT (local f) a
250+ reader = lift . reader
251+
252+instance MonadRef m => MonadRef (EventWriterT t w m) where
253+ type Ref (EventWriterT t w m) = Ref m
254+ newRef = lift . newRef
255+ readRef = lift . readRef
256+ writeRef r = lift . writeRef r
257+
258+instance MonadAtomicRef m => MonadAtomicRef (EventWriterT t w m) where
259+ atomicModifyRef r = lift . atomicModifyRef r
260+
261+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (EventWriterT t w m) where
262+ newEventWithTrigger = lift . newEventWithTrigger
263+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
264+
265+instance (MonadQuery t q m, Monad m) => MonadQuery t q (EventWriterT t w m) where
266+ tellQueryIncremental = lift . tellQueryIncremental
267+ askQueryResult = lift askQueryResult
268+ queryIncremental = lift . queryIncremental
269+
270+-- | Map a function over the output of a 'EventWriterT'.
271+withEventWriterT :: (Semigroup w, Semigroup w', Reflex t, MonadHold t m, MonadFix m)
272+ => (w -> w')
273+ -> EventWriterT t w m a
274+ -> EventWriterT t w' m a
275+withEventWriterT f ew = do
276+ (r, e) <- lift $ do
277+ (r, e) <- runEventWriterT ew
278+ let e' = fmap f e
279+ return (r, e')
280+ tellEvent e
281+ return r
src/Reflex/EventWriter/Class.hsnew file+27
@@ -0,0 +1,27 @@
1+-- | This module defines the 'EventWriter' class.
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE UndecidableInstances #-}
7+#ifdef USE_REFLEX_OPTIMIZER
8+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
9+#endif
10+module Reflex.EventWriter.Class
11+ ( EventWriter (..)
12+ ) where
13+
14+import Control.Monad.Reader (ReaderT, lift)
15+import Data.Semigroup (Semigroup)
16+
17+import Reflex.Class (Event)
18+
19+
20+-- | 'EventWriter' efficiently collects 'Event' values using 'tellEvent'
21+-- and combines them via 'Semigroup' to provide an 'Event' result.
22+class (Monad m, Semigroup w) => EventWriter t w m | m -> t w where
23+ tellEvent :: Event t w -> m ()
24+
25+
26+instance EventWriter t w m => EventWriter t w (ReaderT r m) where
27+ tellEvent = lift . tellEvent
src/Reflex/FastWeak.hsnew file+146
@@ -0,0 +1,146 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE LambdaCase #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+#if GHCJS_FAST_WEAK
5+{-# LANGUAGE ForeignFunctionInterface #-}
6+{-# LANGUAGE JavaScriptFFI #-}
7+#endif
8+module Reflex.FastWeak
9+ ( FastWeakTicket
10+ , FastWeak
11+ , mkFastWeakTicket
12+ , getFastWeakTicketValue
13+ , getFastWeakTicketWeak
14+ , getFastWeakValue
15+ , getFastWeakTicket
16+ , emptyFastWeak
17+#ifdef GHCJS_FAST_WEAK
18+ --TODO: Move these elsewhere
19+ , unsafeFromRawJSVal
20+ , unsafeToRawJSVal
21+ , js_isNull
22+#endif
23+ ) where
24+
25+import GHC.Exts (Any)
26+import Unsafe.Coerce
27+
28+#ifdef GHCJS_FAST_WEAK
29+import GHCJS.Types
30+#else
31+import Control.Exception (evaluate)
32+import System.IO.Unsafe
33+import System.Mem.Weak
34+#endif
35+
36+
37+#ifdef GHCJS_FAST_WEAK
38+newtype FastWeakTicket a = FastWeakTicket JSVal
39+
40+newtype FastWeak a = FastWeak JSVal
41+
42+-- Just designed to mirror JSVal, so that we can unsafeCoerce between the two
43+data Val a = Val { unVal :: a }
44+
45+-- | Coerce a JSVal that represents the heap object of a value of type 'a' into a value of type 'a'
46+unsafeFromRawJSVal :: JSVal -> a
47+unsafeFromRawJSVal v = unVal (unsafeCoerce v)
48+
49+unsafeToRawJSVal :: a -> JSVal
50+unsafeToRawJSVal v = unsafeCoerce (Val v)
51+#else
52+data FastWeakTicket a = FastWeakTicket
53+ { _fastWeakTicket_val :: !a
54+ , _fastWeakTicket_weak :: {-# UNPACK #-} !(Weak a)
55+ }
56+
57+type FastWeak a = Weak a
58+#endif
59+
60+-- This needs to be in IO so we know that we've relinquished the ticket
61+getFastWeakTicketValue :: FastWeakTicket a -> IO a
62+#ifdef GHCJS_FAST_WEAK
63+getFastWeakTicketValue t = do
64+ v <- js_ticketVal t
65+ return $ unsafeFromRawJSVal v
66+
67+foreign import javascript unsafe "$r = $1.val;" js_ticketVal :: FastWeakTicket a -> IO JSVal
68+#else
69+getFastWeakTicketValue = return . _fastWeakTicket_val
70+#endif
71+
72+getFastWeakValue :: FastWeak a -> IO (Maybe a)
73+#ifdef GHCJS_FAST_WEAK
74+getFastWeakValue w = do
75+ r <- js_weakVal w
76+ case js_isNull r of
77+ True -> return Nothing
78+ False -> return $ Just $ unsafeFromRawJSVal r
79+
80+foreign import javascript unsafe "$1 === null" js_isNull :: JSVal -> Bool
81+
82+foreign import javascript unsafe "$r = ($1.ticket === null) ? null : $1.ticket.val;" js_weakVal :: FastWeak a -> IO JSVal
83+#else
84+getFastWeakValue = deRefWeak
85+#endif
86+
87+getFastWeakTicket :: forall a. FastWeak a -> IO (Maybe (FastWeakTicket a))
88+#ifdef GHCJS_FAST_WEAK
89+getFastWeakTicket w = do
90+ r <- js_weakTicket w
91+ case js_isNull r of
92+ True -> return Nothing
93+ False -> return $ Just $ FastWeakTicket r
94+
95+foreign import javascript unsafe "$r = $1.ticket;" js_weakTicket :: FastWeak a -> IO JSVal
96+#else
97+getFastWeakTicket w = do
98+ deRefWeak w >>= \case
99+ Nothing -> return Nothing
100+ Just v -> return $ Just $ FastWeakTicket
101+ { _fastWeakTicket_val = v
102+ , _fastWeakTicket_weak = w
103+ }
104+#endif
105+
106+-- 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
107+mkFastWeakTicket :: a -> IO (FastWeakTicket a)
108+#ifdef GHCJS_FAST_WEAK
109+mkFastWeakTicket v = js_fastWeakTicket (unsafeToRawJSVal v)
110+
111+foreign import javascript unsafe "$r = new h$FastWeakTicket($1);" js_fastWeakTicket :: JSVal -> IO (FastWeakTicket a)
112+#else
113+mkFastWeakTicket v = do
114+ v' <- evaluate v
115+ w <- mkWeakPtr v' Nothing
116+ return $ FastWeakTicket
117+ { _fastWeakTicket_val = v'
118+ , _fastWeakTicket_weak = w
119+ }
120+#endif
121+
122+-- Needs IO so that it can force the value - otherwise, could end up with a reference to the Ticket, which would retain the value
123+#ifdef GHCJS_FAST_WEAK
124+foreign import javascript unsafe "$r = $1.weak;" getFastWeakTicketWeak :: FastWeakTicket a -> IO (FastWeak a)
125+#else
126+getFastWeakTicketWeak :: FastWeakTicket a -> IO (FastWeak a)
127+getFastWeakTicketWeak = return . _fastWeakTicket_weak
128+#endif
129+
130+-- | A weak reference that is always empty
131+emptyFastWeak :: FastWeak a
132+emptyFastWeak = unsafeCoerce w
133+ where w :: FastWeak Any
134+#ifdef GHCJS_FAST_WEAK
135+ w = js_emptyWeak
136+#else
137+ w = unsafePerformIO $ do
138+ w' <- mkWeakPtr undefined Nothing
139+ finalize w'
140+ return w'
141+#endif
142+{-# NOINLINE emptyFastWeak #-}
143+
144+#ifdef GHCJS_FAST_WEAK
145+foreign import javascript unsafe "$r = new h$FastWeak(null);" js_emptyWeak :: FastWeak Any
146+#endif
src/Reflex/FunctorMaybe.hsnew file+33
@@ -0,0 +1,33 @@
1+-- | This module defines the FunctorMaybe class, which extends Functors with the
2+-- ability to delete values.
3+module Reflex.FunctorMaybe
4+ ( FunctorMaybe (..)
5+ ) where
6+
7+import Data.Maybe
8+
9+--TODO: See if there's a better class in the standard libraries already
10+
11+-- | A class for values that combines filtering and mapping using 'Maybe'.
12+-- Morally, @'FunctorMaybe' ~ KleisliFunctor 'Maybe'@. Also similar is the
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@
23+class FunctorMaybe f where
24+ -- | Combined mapping and filtering function.
25+ fmapMaybe :: (a -> Maybe b) -> f a -> f b
26+
27+-- | @fmapMaybe = (=<<)
28+instance FunctorMaybe Maybe where
29+ fmapMaybe = (=<<)
30+
31+-- | @fmapMaybe f = catMaybes . fmap f@
32+instance FunctorMaybe [] where
33+ fmapMaybe f = catMaybes . fmap f
src/Reflex/Host/Class.hsnew file+286
@@ -0,0 +1,286 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ExistentialQuantification #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE FunctionalDependencies #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE RankNTypes #-}
9+{-# LANGUAGE RoleAnnotations #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE UndecidableInstances #-}
13+#ifdef USE_REFLEX_OPTIMIZER
14+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
15+#endif
16+-- | This module provides the interface for hosting 'Reflex' engines. This
17+-- should only be necessary if you're writing a binding or some other library
18+-- that provides a core event loop.
19+module Reflex.Host.Class
20+ ( ReflexHost (..)
21+ , MonadSubscribeEvent (..)
22+ , MonadReadEvent (..)
23+ , MonadReflexCreateTrigger (..)
24+ , MonadReflexHost (..)
25+ , fireEvents
26+ , newEventWithTriggerRef
27+ , fireEventRef
28+ , fireEventRefAndRead
29+ ) where
30+
31+import Reflex.Class
32+
33+import Control.Applicative
34+import Control.Monad
35+import Control.Monad.Fix
36+import Control.Monad.Identity
37+import Control.Monad.Ref
38+import Control.Monad.Trans
39+import Control.Monad.Trans.Cont (ContT)
40+import Control.Monad.Trans.Except (ExceptT)
41+import Control.Monad.Trans.Reader (ReaderT)
42+import Control.Monad.Trans.RWS (RWST)
43+import Control.Monad.Trans.State (StateT)
44+import qualified Control.Monad.Trans.State.Strict as Strict
45+import Control.Monad.Trans.Writer (WriterT)
46+import Data.Dependent.Sum (DSum (..))
47+import Data.GADT.Compare
48+import Data.Monoid
49+
50+-- Note: this import must come last to silence warnings from AMP
51+import Prelude hiding (foldl, mapM, mapM_, sequence, sequence_)
52+
53+-- | Framework implementation support class for the reflex implementation
54+-- represented by @t@.
55+class ( Reflex t
56+ , MonadReflexCreateTrigger t (HostFrame t)
57+ , MonadSample t (HostFrame t)
58+ , MonadHold t (HostFrame t)
59+ , MonadFix (HostFrame t)
60+ , MonadSubscribeEvent t (HostFrame t)
61+ ) => ReflexHost t where
62+ type EventTrigger t :: * -> *
63+ type EventHandle t :: * -> *
64+ type HostFrame t :: * -> *
65+
66+-- | Monad in which Events can be 'subscribed'. This forces all underlying
67+-- event sources to be initialized, so that the event will fire whenever it
68+-- ought to. Events must be subscribed before they are read using readEvent
69+class (Reflex t, Monad m) => MonadSubscribeEvent t m | m -> t where
70+ -- | Subscribe to an event and set it up if needed.
71+ --
72+ -- This function will create a new 'EventHandle' from an 'Event'. This handle
73+ -- may then be used via 'readEvent' in the read callback of
74+ -- 'fireEventsAndRead'.
75+ --
76+ -- If the event wasn't subscribed to before (either manually or through a
77+ -- dependent event or behavior) then this function will cause the event and
78+ -- all dependencies of this event to be set up. For example, if the event was
79+ -- created by 'newEventWithTrigger', then it's callback will be executed.
80+ --
81+ -- It's safe to call this function multiple times.
82+ subscribeEvent :: Event t a -> m (EventHandle t a)
83+
84+-- | Monad that allows to read events' values.
85+class (ReflexHost t, Applicative m, Monad m) => MonadReadEvent t m | m -> t where
86+ -- | Read the value of an 'Event' from an 'EventHandle' (created by calling
87+ -- 'subscribeEvent').
88+ --
89+ -- After event propagation is done, all events can be in two states: either
90+ -- they are firing with some value or they are not firing. In the former
91+ -- case, this function returns @Just act@, where @act@ in an action to read
92+ -- the current value of the event. In the latter case, the function returns
93+ -- @Nothing@.
94+ --
95+ -- This function is normally used in the calllback for 'fireEventsAndRead'.
96+ readEvent :: EventHandle t a -> m (Maybe (m a))
97+
98+-- | A monad where new events feed from external sources can be created.
99+class (Applicative m, Monad m) => MonadReflexCreateTrigger t m | m -> t where
100+ -- | Creates a root 'Event' (one that is not based on any other event).
101+ --
102+ -- When a subscriber first subscribes to an event (building another event that
103+ -- depends on the subscription) the given callback function is run and passed
104+ -- a trigger. The callback function can then set up the event source in IO.
105+ -- After this is done, the callback function must return an accompanying
106+ -- teardown action.
107+ --
108+ -- Any time between setup and teardown the trigger can be used to fire the
109+ -- event, by passing it to 'fireEventsAndRead'.
110+ --
111+ -- Note: An event may be set up multiple times. So after the teardown action
112+ -- is executed, the event may still be set up again in the future.
113+ newEventWithTrigger :: (EventTrigger t a -> IO (IO ())) -> m (Event t a)
114+ newFanEventWithTrigger :: GCompare k => (forall a. k a -> EventTrigger t a -> IO (IO ())) -> m (EventSelector t k)
115+
116+-- | 'MonadReflexHost' designates monads that can run reflex frames.
117+class ( ReflexHost t
118+ , MonadReflexCreateTrigger t m
119+ , MonadSubscribeEvent t m
120+ , MonadReadEvent t (ReadPhase m)
121+ , MonadSample t (ReadPhase m)
122+ , MonadHold t (ReadPhase m)
123+ ) => MonadReflexHost t m | m -> t where
124+ type ReadPhase m :: * -> *
125+ -- | Propagate some events firings and read the values of events afterwards.
126+ --
127+ -- This function will create a new frame to fire the given events. It will
128+ -- then update all dependent events and behaviors. After that is done, the
129+ -- given callback is executed which allows to read the final values of events
130+ -- and check whether they have fired in this frame or not.
131+ --
132+ -- All events that are given are fired at the same time.
133+ --
134+ -- This function is typically used in the main loop of a reflex framework
135+ -- implementation. The main loop waits for external events to happen (such as
136+ -- keyboard input or a mouse click) and then fires the corresponding events
137+ -- using this function. The read callback can be used to read output events
138+ -- and perform a corresponding response action to the external event.
139+ fireEventsAndRead :: [DSum (EventTrigger t) Identity] -> ReadPhase m a -> m a
140+
141+ -- | Run a frame without any events firing.
142+ --
143+ -- This function should be used when you want to use 'sample' and 'hold' when
144+ -- no events are currently firing. Using this function in that case can
145+ -- improve performance, since the implementation can assume that no events are
146+ -- firing when 'sample' or 'hold' are called.
147+ --
148+ -- This function is commonly used to set up the basic event network when the
149+ -- application starts up.
150+ runHostFrame :: HostFrame t a -> m a
151+
152+-- | Like 'fireEventsAndRead', but without reading any events.
153+fireEvents :: MonadReflexHost t m => [DSum (EventTrigger t) Identity] -> m ()
154+fireEvents dm = fireEventsAndRead dm $ return ()
155+{-# INLINE fireEvents #-}
156+
157+-- | Create a new event and store its trigger in an 'IORef' while it's active.
158+--
159+-- An event is only active between the set up (when it's first subscribed to)
160+-- and the teardown phases (when noboby is subscribing the event anymore). This
161+-- function returns an Event and an 'IORef'. As long as the event is active, the
162+-- 'IORef' will contain 'Just' the event trigger to trigger this event. When the
163+-- event is not active, the 'IORef' will contain 'Nothing'. This allows event
164+-- sources to be more efficient, since they don't need to produce events when
165+-- nobody is listening.
166+newEventWithTriggerRef :: (MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO) => m (Event t a, Ref m (Maybe (EventTrigger t a)))
167+newEventWithTriggerRef = do
168+ rt <- newRef Nothing
169+ e <- newEventWithTrigger $ \t -> do
170+ writeRef rt $ Just t
171+ return $ writeRef rt Nothing
172+ return (e, rt)
173+{-# INLINE newEventWithTriggerRef #-}
174+
175+-- | Fire the given trigger if it is not 'Nothing'.
176+fireEventRef :: (MonadReflexHost t m, MonadRef m, Ref m ~ Ref IO) => Ref m (Maybe (EventTrigger t a)) -> a -> m ()
177+fireEventRef mtRef input = do
178+ mt <- readRef mtRef
179+ case mt of
180+ Nothing -> return ()
181+ Just trigger -> fireEvents [trigger :=> Identity input]
182+
183+-- | Fire the given trigger if it is not 'Nothing', and read from the given
184+-- 'EventHandle'.
185+fireEventRefAndRead :: (MonadReflexHost t m, MonadRef m, Ref m ~ Ref IO) => Ref m (Maybe (EventTrigger t a)) -> a -> EventHandle t b -> m (Maybe b)
186+fireEventRefAndRead mtRef input e = do
187+ mt <- readRef mtRef
188+ case mt of
189+ Nothing -> return Nothing -- Since we aren't firing the input, the output can't fire
190+ Just trigger -> fireEventsAndRead [trigger :=> Identity input] $ do
191+ mGetValue <- readEvent e
192+ case mGetValue of
193+ Nothing -> return Nothing
194+ Just getValue -> fmap Just getValue
195+
196+
197+--------------------------------------------------------------------------------
198+-- Instances
199+--------------------------------------------------------------------------------
200+
201+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ReaderT r m) where
202+ newEventWithTrigger = lift . newEventWithTrigger
203+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
204+
205+instance MonadSubscribeEvent t m => MonadSubscribeEvent t (ReaderT r m) where
206+ subscribeEvent = lift . subscribeEvent
207+
208+instance MonadReflexHost t m => MonadReflexHost t (ReaderT r m) where
209+ type ReadPhase (ReaderT r m) = ReadPhase m
210+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
211+ runHostFrame = lift . runHostFrame
212+
213+instance (MonadReflexCreateTrigger t m, Monoid w) => MonadReflexCreateTrigger t (WriterT w m) where
214+ newEventWithTrigger = lift . newEventWithTrigger
215+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
216+
217+instance (MonadSubscribeEvent t m, Monoid w) => MonadSubscribeEvent t (WriterT w m) where
218+ subscribeEvent = lift . subscribeEvent
219+
220+instance (MonadReflexHost t m, Monoid w) => MonadReflexHost t (WriterT w m) where
221+ type ReadPhase (WriterT w m) = ReadPhase m
222+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
223+ runHostFrame = lift . runHostFrame
224+
225+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (StateT s m) where
226+ newEventWithTrigger = lift . newEventWithTrigger
227+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
228+
229+instance MonadSubscribeEvent t m => MonadSubscribeEvent t (StateT r m) where
230+ subscribeEvent = lift . subscribeEvent
231+
232+instance MonadReflexHost t m => MonadReflexHost t (StateT s m) where
233+ type ReadPhase (StateT s m) = ReadPhase m
234+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
235+ runHostFrame = lift . runHostFrame
236+
237+
238+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (Strict.StateT s m) where
239+ newEventWithTrigger = lift . newEventWithTrigger
240+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
241+
242+instance MonadSubscribeEvent t m => MonadSubscribeEvent t (Strict.StateT r m) where
243+ subscribeEvent = lift . subscribeEvent
244+
245+instance MonadReflexHost t m => MonadReflexHost t (Strict.StateT s m) where
246+ type ReadPhase (Strict.StateT s m) = ReadPhase m
247+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
248+ runHostFrame = lift . runHostFrame
249+
250+
251+
252+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ContT r m) where
253+ newEventWithTrigger = lift . newEventWithTrigger
254+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
255+
256+instance MonadSubscribeEvent t m => MonadSubscribeEvent t (ContT r m) where
257+ subscribeEvent = lift . subscribeEvent
258+
259+instance MonadReflexHost t m => MonadReflexHost t (ContT r m) where
260+ type ReadPhase (ContT r m) = ReadPhase m
261+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
262+ runHostFrame = lift . runHostFrame
263+
264+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ExceptT e m) where
265+ newEventWithTrigger = lift . newEventWithTrigger
266+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
267+
268+instance MonadSubscribeEvent t m => MonadSubscribeEvent t (ExceptT r m) where
269+ subscribeEvent = lift . subscribeEvent
270+
271+instance MonadReflexHost t m => MonadReflexHost t (ExceptT e m) where
272+ type ReadPhase (ExceptT e m) = ReadPhase m
273+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
274+ runHostFrame = lift . runHostFrame
275+
276+instance (MonadReflexCreateTrigger t m, Monoid w) => MonadReflexCreateTrigger t (RWST r w s m) where
277+ newEventWithTrigger = lift . newEventWithTrigger
278+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
279+
280+instance (MonadSubscribeEvent t m, Monoid w) => MonadSubscribeEvent t (RWST r w s m) where
281+ subscribeEvent = lift . subscribeEvent
282+
283+instance (MonadReflexHost t m, Monoid w) => MonadReflexHost t (RWST r w s m) where
284+ type ReadPhase (RWST r w s m) = ReadPhase m
285+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
286+ runHostFrame = lift . runHostFrame
src/Reflex/Network.hsnew file+38
@@ -0,0 +1,38 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE MultiParamTypeClasses #-}
3+#ifdef USE_REFLEX_OPTIMIZER
4+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
5+#endif
6+module Reflex.Network
7+ ( networkView
8+ , networkHold
9+ , untilReady
10+ ) where
11+
12+import Reflex.Class
13+import Reflex.NotReady.Class
14+import Reflex.PostBuild.Class
15+
16+-- | Given a Dynamic of network-creating actions, create a network that is recreated whenever the Dynamic updates.
17+-- The returned Event of network results occurs when the Dynamic does.
18+-- Note: Often, the type 'a' is an Event, in which case the return value is an Event-of-Events that would typically be flattened (via 'switchPromptly').
19+networkView :: (Reflex t, NotReady t m, Adjustable t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)
20+networkView child = do
21+ postBuild <- getPostBuild
22+ let newChild = leftmost [updated child, tagCheap (current child) postBuild]
23+ snd <$> runWithReplace notReady newChild
24+
25+-- | Given an initial network and an Event of network-creating actions, create a network that is recreated whenever the Event fires.
26+-- The returned Dynamic of network results occurs when the Event does.
27+-- Note: Often, the type 'a' is an Event, in which case the return value is a Dynamic-of-Events that would typically be flattened.
28+networkHold :: (Reflex t, Adjustable t m, MonadHold t m) => m a -> Event t (m a) -> m (Dynamic t a)
29+networkHold child0 newChild = do
30+ (result0, newResult) <- runWithReplace child0 newChild
31+ holdDyn result0 newResult
32+
33+-- | Render a placeholder network to be shown while another network is not yet
34+-- done building
35+untilReady :: (Reflex t, Adjustable t m, PostBuild t m) => m a -> m b -> m (a, Event t b)
36+untilReady a b = do
37+ postBuild <- getPostBuild
38+ runWithReplace a $ b <$ postBuild
src/Reflex/NotReady/Class.hsnew file+68
@@ -0,0 +1,68 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DefaultSignatures #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE FunctionalDependencies #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE UndecidableInstances #-}
9+#ifdef USE_REFLEX_OPTIMIZER
10+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
11+#endif
12+module Reflex.NotReady.Class
13+ ( NotReady(..)
14+ ) where
15+
16+import Control.Monad.Reader (ReaderT)
17+import Control.Monad.Trans
18+
19+import Reflex.Class
20+import Reflex.DynamicWriter.Base (DynamicWriterT)
21+import Reflex.EventWriter.Base (EventWriterT)
22+import Reflex.Host.Class
23+import Reflex.PerformEvent.Base (PerformEventT (..))
24+import Reflex.PostBuild.Base (PostBuildT)
25+import Reflex.Query.Base (QueryT)
26+import Reflex.Requester.Base (RequesterT)
27+import Reflex.TriggerEvent.Base (TriggerEventT)
28+
29+class Monad m => NotReady t m | m -> t where
30+ notReadyUntil :: Event t a -> m ()
31+ default notReadyUntil :: (MonadTrans f, m ~ f m', NotReady t m') => Event t a -> m ()
32+ notReadyUntil = lift . notReadyUntil
33+
34+ notReady :: m ()
35+ default notReady :: (MonadTrans f, m ~ f m', NotReady t m') => m ()
36+ notReady = lift notReady
37+
38+instance NotReady t m => NotReady t (ReaderT r m) where
39+ notReadyUntil = lift . notReadyUntil
40+ notReady = lift notReady
41+
42+instance NotReady t m => NotReady t (PostBuildT t m) where
43+ notReadyUntil = lift . notReadyUntil
44+ notReady = lift notReady
45+
46+instance NotReady t m => NotReady t (EventWriterT t w m) where
47+ notReadyUntil = lift . notReadyUntil
48+ notReady = lift notReady
49+
50+instance NotReady t m => NotReady t (DynamicWriterT t w m) where
51+ notReadyUntil = lift . notReadyUntil
52+ notReady = lift notReady
53+
54+instance NotReady t m => NotReady t (QueryT t q m) where
55+ notReadyUntil = lift . notReadyUntil
56+ notReady = lift notReady
57+
58+instance (ReflexHost t, NotReady t (HostFrame t)) => NotReady t (PerformEventT t m) where
59+ notReadyUntil = PerformEventT . notReadyUntil
60+ notReady = PerformEventT notReady
61+
62+instance NotReady t m => NotReady t (RequesterT t request response m) where
63+ notReadyUntil = lift . notReadyUntil
64+ notReady = lift notReady
65+
66+instance NotReady t m => NotReady t (TriggerEventT t m) where
67+ notReadyUntil = lift . notReadyUntil
68+ notReady = lift notReady
src/Reflex/Optimizer.hsnew file+56
@@ -0,0 +1,56 @@
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.
5+{-# LANGUAGE CPP #-}
6+{-# LANGUAGE LambdaCase #-}
7+{-# LANGUAGE OverloadedStrings #-}
8+module Reflex.Optimizer
9+ ( plugin
10+ ) where
11+
12+#ifdef ghcjs_HOST_OS
13+import Plugins
14+#else
15+import Control.Arrow
16+import CoreMonad
17+import Data.String
18+import GhcPlugins
19+#endif
20+
21+#ifdef ghcjs_HOST_OS
22+
23+-- | The GHCJS build of Reflex.Optimizer just throws an error; instead, the version built with GHC should be used.
24+plugin :: Plugin
25+plugin = error "The GHCJS build of Reflex.Optimizer cannot be used. Instead, build with GHC and use the result with GHCJS."
26+
27+#else
28+
29+-- | The GHC plugin itself. See "GhcPlugins" for more details.
30+plugin :: Plugin
31+plugin = defaultPlugin { installCoreToDos = install }
32+
33+install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
34+install [] p = do
35+ liftIO $ putStrLn $ showSDocUnsafe $ ppr p
36+ let f = \case
37+ simpl@(CoreDoSimplify _ _) -> [CoreDoSpecialising, simpl]
38+ x -> [x]
39+ return $ makeInlinable : concatMap f p
40+install options@(_:_) p = do
41+ warnMsg $ "Reflex.Optimizer: ignoring " <> fromString (show $ length options) <> " command-line options"
42+ install [] p
43+
44+makeInlinable :: CoreToDo
45+makeInlinable = CoreDoPluginPass "MakeInlinable" $ \modGuts -> do
46+ let f v = setIdInfo v $ let i = idInfo v in
47+ setInlinePragInfo i $ let p = inlinePragInfo i in
48+ if isDefaultInlinePragma p
49+ then defaultInlinePragma { inl_inline = Inlinable }
50+ else p
51+ newBinds = flip map (mg_binds modGuts) $ \case
52+ NonRec b e -> NonRec (f b) e
53+ Rec bes -> Rec $ map (first f) bes
54+ return $ modGuts { mg_binds = newBinds }
55+
56+#endif
src/Reflex/Patch.hsnew file+39
@@ -0,0 +1,39 @@
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
8+
9+import Reflex.Patch.Class as X
10+import Reflex.Patch.DMap as X hiding (getDeletions)
11+import Reflex.Patch.DMapWithMove as X (PatchDMapWithMove, const2PatchDMapWithMoveWith, mapPatchDMapWithMove,
12+ patchDMapWithMoveToPatchMapWithMoveWith,
13+ traversePatchDMapWithMoveWithKey, unPatchDMapWithMove,
14+ unsafePatchDMapWithMove, weakenPatchDMapWithMoveWith)
15+import Reflex.Patch.IntMap as X hiding (getDeletions)
16+import Reflex.Patch.Map as X
17+import Reflex.Patch.MapWithMove as X (PatchMapWithMove, patchMapWithMoveNewElements,
18+ patchMapWithMoveNewElementsMap, unPatchMapWithMove,
19+ unsafePatchMapWithMove)
20+
21+import Data.Semigroup (Semigroup (..), (<>))
22+
23+---- Patches based on commutative groups
24+
25+-- | A 'Group' is a 'Monoid' where every element has an inverse.
26+class (Semigroup q, Monoid q) => Group q where
27+ negateG :: q -> q
28+ (~~) :: q -> q -> q
29+ r ~~ s = r <> negateG s
30+
31+-- | An 'Additive' 'Semigroup' is one where (<>) is commutative
32+class Semigroup q => Additive q where
33+
34+-- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type.
35+newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }
36+
37+instance Additive p => Patch (AdditivePatch p) where
38+ type PatchTarget (AdditivePatch p) = p
39+ apply (AdditivePatch p) q = Just $ p <> q
src/Reflex/Patch/Class.hsnew file+22
@@ -0,0 +1,22 @@
1+{-# LANGUAGE TypeFamilies #-}
2+-- | The interface for types which represent changes made to other types
3+module Reflex.Patch.Class where
4+
5+import Control.Monad.Identity
6+import Data.Maybe
7+
8+-- | A 'Patch' type represents a kind of change made to a datastructure.
9+class Patch p where
10+ type PatchTarget p :: *
11+ -- | Apply the patch @p a@ to the value @a@. If no change is needed, return
12+ -- 'Nothing'.
13+ apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
14+
15+-- | Apply a 'Patch'; if it does nothing, return the original value
16+applyAlways :: Patch p => p -> PatchTarget p -> PatchTarget p
17+applyAlways p t = fromMaybe t $ apply p t
18+
19+-- | 'Identity' can be used as a 'Patch' that always fully replaces the value
20+instance Patch (Identity a) where
21+ type PatchTarget (Identity a) = a
22+ apply (Identity a) _ = Just a
src/Data/Patch/DMap.hs → src/Reflex/Patch/DMap.hsrenamed+13−38
@@ -1,4 +1,3 @@
1−{-# LANGUAGE CPP #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
1{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE PolyKinds #-}
3{-# LANGUAGE PolyKinds #-}
@@ -6,42 +5,29 @@
6{-# LANGUAGE ScopedTypeVariables #-}
5{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE StandaloneDeriving #-}
6{-# LANGUAGE StandaloneDeriving #-}
8{-# LANGUAGE TypeFamilies #-}
7{-# LANGUAGE TypeFamilies #-}
8+module Reflex.Patch.DMap where
9
9
10−-- | 'Patch'es on 'DMap' that consist only of insertions (or overwrites) and deletions.
10+import Reflex.Patch.Class
11−module Data.Patch.DMap where
11+import Reflex.Patch.IntMap
12+import Reflex.Patch.Map
12
13
13−import Data.Patch.Class
14−import Data.Patch.IntMap
15−import Data.Patch.Map
16−
17−import Data.Dependent.Map (DMap)
14+import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
18−import Data.Dependent.Sum (DSum (..))
19−import Data.GADT.Compare (GCompare (..))
20import qualified Data.Dependent.Map as DMap
15import qualified Data.Dependent.Map as DMap
21import Data.Functor.Constant
16import Data.Functor.Constant
22import Data.Functor.Misc
17import Data.Functor.Misc
23import qualified Data.IntMap as IntMap
18import qualified Data.IntMap as IntMap
24import qualified Data.Map as Map
19import qualified Data.Map as Map
25−import Data.Monoid.DecidablyEmpty
26−#if !MIN_VERSION_base(4,11,0)
27import Data.Semigroup (Semigroup (..))
20import Data.Semigroup (Semigroup (..))
28−#endif
29import Data.Some (Some)
21import Data.Some (Some)
30
22
31−-- | A set of changes to a 'DMap'. Any element may be inserted/updated or deleted.
23+-- | A set of changes to a 'DMap'. Any element may be inserted/updated or
32−-- Insertions are represented as @'ComposeMaybe' (Just value)@,
24+-- deleted.
33−-- while deletions are represented as @'ComposeMaybe' Nothing@.
34newtype PatchDMap k v = PatchDMap { unPatchDMap :: DMap k (ComposeMaybe v) }
25newtype PatchDMap k v = PatchDMap { unPatchDMap :: DMap k (ComposeMaybe v) }
35
26
36deriving instance GCompare k => Semigroup (PatchDMap k v)
27deriving instance GCompare k => Semigroup (PatchDMap k v)
37
28
38deriving instance GCompare k => Monoid (PatchDMap k v)
29deriving instance GCompare k => Monoid (PatchDMap k v)
39
30
40−-- It won't let me derive for some reason
41−instance GCompare k => DecidablyEmpty (PatchDMap k v) where
42− isEmpty (PatchDMap m) = DMap.null m
43−
44−-- | Apply the insertions or deletions to a given 'DMap'.
45instance GCompare k => Patch (PatchDMap k v) where
31instance GCompare k => Patch (PatchDMap k v) where
46 type PatchTarget (PatchDMap k v) = DMap k v
32 type PatchTarget (PatchDMap k v) = DMap k v
47 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?
33 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?
@@ -51,43 +37,32 @@ instance GCompare k => Patch (PatchDMap k v) where
51 Nothing -> Just $ Constant ()
37 Nothing -> Just $ Constant ()
52 Just _ -> Nothing
38 Just _ -> Nothing
53
39
54−-- | Map a function @v a -> v' a@ over any inserts/updates in the given
55−-- @'PatchDMap' k v@ to produce a @'PatchDMap' k v'@.
56mapPatchDMap :: (forall a. v a -> v' a) -> PatchDMap k v -> PatchDMap k v'
40mapPatchDMap :: (forall a. v a -> v' a) -> PatchDMap k v -> PatchDMap k v'
57mapPatchDMap f (PatchDMap p) = PatchDMap $ DMap.map (ComposeMaybe . fmap f . getComposeMaybe) p
41mapPatchDMap f (PatchDMap p) = PatchDMap $ DMap.map (ComposeMaybe . fmap f . getComposeMaybe) p
58
42
59−-- | Map an effectful function @v a -> f (v' a)@ over any inserts/updates in the given
60−-- @'PatchDMap' k v@ to produce a @'PatchDMap' k v'@.
61−traversePatchDMap :: Applicative f => (forall a. v a -> f (v' a)) -> PatchDMap k v -> f (PatchDMap k v')
43+traversePatchDMap :: Applicative m => (forall a. v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v')
62traversePatchDMap f = traversePatchDMapWithKey $ const f
44traversePatchDMap f = traversePatchDMapWithKey $ const f
63
45
64−-- | Map an effectful function @k a -> v a -> f (v' a)@ over any inserts/updates
65−-- in the given @'PatchDMap' k v@ to produce a @'PatchDMap' k v'@.
66traversePatchDMapWithKey :: Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v')
46traversePatchDMapWithKey :: Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v')
67traversePatchDMapWithKey f (PatchDMap p) = PatchDMap <$> DMap.traverseWithKey (\k (ComposeMaybe v) -> ComposeMaybe <$> traverse (f k) v) p
47traversePatchDMapWithKey f (PatchDMap p) = PatchDMap <$> DMap.traverseWithKey (\k (ComposeMaybe v) -> ComposeMaybe <$> traverse (f k) v) p
68
48
69−-- | Weaken a @'PatchDMap' k v@ to a @'PatchMap' (Some k) v'@ using a function
70−-- @v a -> v'@ to weaken each value contained in the patch.
71weakenPatchDMapWith :: (forall a. v a -> v') -> PatchDMap k v -> PatchMap (Some k) v'
49weakenPatchDMapWith :: (forall a. v a -> v') -> PatchDMap k v -> PatchMap (Some k) v'
72weakenPatchDMapWith f (PatchDMap p) = PatchMap $ weakenDMapWith (fmap f . getComposeMaybe) p
50weakenPatchDMapWith f (PatchDMap p) = PatchMap $ weakenDMapWith (fmap f . getComposeMaybe) p
73
51
74−-- | Convert a weak @'PatchDMap' ('Const2' k a) v@ where the @a@ is known by way of
75−-- the @Const2@ into a @'PatchMap' k v'@ using a rank 1 function @v a -> v'@.
76−patchDMapToPatchMapWith :: (v a -> v') -> PatchDMap (Const2 k a) v -> PatchMap k v'
52+patchDMapToPatchMapWith :: (f v -> v') -> PatchDMap (Const2 k v) f -> PatchMap k v'
77patchDMapToPatchMapWith f (PatchDMap p) = PatchMap $ dmapToMapWith (fmap f . getComposeMaybe) p
53patchDMapToPatchMapWith f (PatchDMap p) = PatchMap $ dmapToMapWith (fmap f . getComposeMaybe) p
78
54
79−-- | Convert a @'PatchMap' k v@ into a @'PatchDMap' ('Const2' k a) v'@ using a function @v -> v' a@.
80−const2PatchDMapWith :: forall k v v' a. (v -> v' a) -> PatchMap k v -> PatchDMap (Const2 k a) v'
55+const2PatchDMapWith :: forall k v f a. (v -> f a) -> PatchMap k v -> PatchDMap (Const2 k a) f
81const2PatchDMapWith f (PatchMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
56const2PatchDMapWith f (PatchMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
82− where g :: (k, Maybe v) -> DSum (Const2 k a) (ComposeMaybe v')
57+ where g :: (k, Maybe v) -> DSum (Const2 k a) (ComposeMaybe f)
83 g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)
58 g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)
84
59
85−-- | Convert a @'PatchIntMap' v@ into a @'PatchDMap' ('Const2' Int a) v'@ using a function @v -> v' a@.
86const2IntPatchDMapWith :: forall v f a. (v -> f a) -> PatchIntMap v -> PatchDMap (Const2 IntMap.Key a) f
60const2IntPatchDMapWith :: forall v f a. (v -> f a) -> PatchIntMap v -> PatchDMap (Const2 IntMap.Key a) f
87const2IntPatchDMapWith f (PatchIntMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> IntMap.toAscList p
61const2IntPatchDMapWith f (PatchIntMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> IntMap.toAscList p
88 where g :: (IntMap.Key, Maybe v) -> DSum (Const2 IntMap.Key a) (ComposeMaybe f)
62 where g :: (IntMap.Key, Maybe v) -> DSum (Const2 IntMap.Key a) (ComposeMaybe f)
89 g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)
63 g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)
90
64
91−-- | Get the values that will be replaced or deleted if the given patch is applied to the given 'DMap'.
65+-- | Get the values that will be deleted if the given patch is applied to the
66+-- given 'DMap'. Includes values that will be replaced.
92getDeletions :: GCompare k => PatchDMap k v -> DMap k v' -> DMap k v'
67getDeletions :: GCompare k => PatchDMap k v -> DMap k v' -> DMap k v'
93getDeletions (PatchDMap p) m = DMap.intersectionWithKey (\_ v _ -> v) m p
68getDeletions (PatchDMap p) m = DMap.intersectionWithKey (\_ v _ -> v) m p
src/Data/Patch/DMapWithMove.hs → src/Reflex/Patch/DMapWithMove.hsrenamed+41−45
@@ -13,28 +13,25 @@
13
13
14-- |Module containing @'PatchDMapWithMove' k v@ and associated functions, which represents a 'Patch' to a @'DMap' k v@ which can insert, update, delete, and
14-- |Module containing @'PatchDMapWithMove' k v@ and associated functions, which represents a 'Patch' to a @'DMap' k v@ which can insert, update, delete, and
15-- move values between keys.
15-- move values between keys.
16−module Data.Patch.DMapWithMove where
16+module Reflex.Patch.DMapWithMove where
17
17
18−import Data.Patch.Class
18+import Reflex.Patch.Class
19−import Data.Patch.MapWithMove (PatchMapWithMove (..))
19+import Reflex.Patch.MapWithMove (PatchMapWithMove (..))
20−import qualified Data.Patch.MapWithMove as MapWithMove
20+import qualified Reflex.Patch.MapWithMove as MapWithMove
21
21
22−import Data.Constraint.Extras
23−import Data.Dependent.Map (DMap)
22+import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
24−import Data.Dependent.Sum (DSum (..))
25import qualified Data.Dependent.Map as DMap
23import qualified Data.Dependent.Map as DMap
24+import Data.Dependent.Sum (EqTag (..))
26import Data.Functor.Constant
25import Data.Functor.Constant
27import Data.Functor.Misc
26import Data.Functor.Misc
28import Data.Functor.Product
27import Data.Functor.Product
29−import Data.GADT.Compare (GEq (..), GCompare (..))
28+import Data.GADT.Compare (GEq (..))
30import Data.GADT.Show (GShow, gshow)
29import Data.GADT.Show (GShow, gshow)
31import qualified Data.Map as Map
30import qualified Data.Map as Map
32import Data.Maybe
31import Data.Maybe
33−import Data.Monoid.DecidablyEmpty
32+import Data.Semigroup (Semigroup (..), (<>))
34−#if !MIN_VERSION_base(4,11,0)
35−import Data.Semigroup (Semigroup (..))
33+import Data.Some (Some)
36−#endif
37−import Data.Some (Some, mkSome)
34+import qualified Data.Some as Some
38import Data.These
35import Data.These
39
36
40-- | Like 'PatchMapWithMove', but for 'DMap'. Each key carries a 'NodeInfo' which describes how it will be changed by the patch and connects move sources and
37-- | Like 'PatchMapWithMove', but for 'DMap'. Each key carries a 'NodeInfo' which describes how it will be changed by the patch and connects move sources and
@@ -46,10 +43,6 @@ import Data.These
46-- * A move should always be represented with both the destination key (as a 'From_Move') and the source key (as a @'ComposeMaybe' ('Just' destination)@)
43-- * A move should always be represented with both the destination key (as a 'From_Move') and the source key (as a @'ComposeMaybe' ('Just' destination)@)
47newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
44newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
48
45
49−-- It won't let me derive for some reason
50−instance GCompare k => DecidablyEmpty (PatchDMapWithMove k v) where
51− isEmpty (PatchDMapWithMove m) = DMap.null m
52−
53-- |Structure which represents what changes apply to a particular key. @_nodeInfo_from@ specifies what happens to this key, and in particular what other key
46-- |Structure which represents what changes apply to a particular key. @_nodeInfo_from@ specifies what happens to this key, and in particular what other key
54-- the current key is moving from, while @_nodeInfo_to@ specifies what key the current key is moving to if involved in a move.
47-- the current key is moving from, while @_nodeInfo_to@ specifies what key the current key is moving to if involved in a move.
55data NodeInfo k v a = NodeInfo
48data NodeInfo k v a = NodeInfo
@@ -77,11 +70,11 @@ data From (k :: a -> *) (v :: a -> *) :: a -> * where
77type To = ComposeMaybe
70type To = ComposeMaybe
78
71
79-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
72-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
80−validPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Bool
73+validPatchDMapWithMove :: forall k v. (GCompare k, GEq k, GShow k) => DMap k (NodeInfo k v) -> Bool
81validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove
74validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove
82
75
83-- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid.
76-- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid.
84−validationErrorsForPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> [String]
77+validationErrorsForPatchDMapWithMove :: forall k v. (GCompare k, GEq k, GShow k) => DMap k (NodeInfo k v) -> [String]
85validationErrorsForPatchDMapWithMove m =
78validationErrorsForPatchDMapWithMove m =
86 noSelfMoves <> movesBalanced
79 noSelfMoves <> movesBalanced
87 where
80 where
@@ -111,21 +104,25 @@ validationErrorsForPatchDMapWithMove m =
111 Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
104 Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
112 unbalancedMove _ = Nothing
105 unbalancedMove _ = Nothing
113
106
114−-- |Test whether two @'PatchDMapWithMove' k v@ contain the same patch operations.
115−instance (GEq k, Has' Eq k (NodeInfo k v)) => Eq (PatchDMapWithMove k v) where
107+instance EqTag k (NodeInfo k v) => Eq (PatchDMapWithMove k v) where
116− PatchDMapWithMove a == PatchDMapWithMove b = a == b
108+ PatchDMapWithMove a == PatchDMapWithMove b = a == b
117
109
118-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
110-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
119data Pair1 f g a = Pair1 (f a) (g a)
111data Pair1 f g a = Pair1 (f a) (g a)
120
112
113+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
114+instance GCompare k => Semigroup (PatchDMapWithMove k v) where
115+ (<>) = mappend
116+
121-- |Helper data structure used for composing patches using the monoid instance.
117-- |Helper data structure used for composing patches using the monoid instance.
122data Fixup k v a
118data Fixup k v a
123 = Fixup_Delete
119 = Fixup_Delete
124 | Fixup_Update (These (From k v a) (To k a))
120 | Fixup_Update (These (From k v a) (To k a))
125
121
126-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
122-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
127−instance GCompare k => Semigroup (PatchDMapWithMove k v) where
123+instance GCompare k => Monoid (PatchDMapWithMove k v) where
124+ mempty = PatchDMapWithMove mempty
128− PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m
125+ PatchDMapWithMove ma `mappend` PatchDMapWithMove mb = PatchDMapWithMove m
129 where
126 where
130 connections = DMap.toList $ DMap.intersectionWithKey (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b)) ma mb
127 connections = DMap.toList $ DMap.intersectionWithKey (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b)) ma mb
131 h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)]
128 h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)]
@@ -159,21 +156,20 @@ instance GCompare k => Semigroup (PatchDMapWithMove k v) where
159 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
156 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
160 }
157 }
161 m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups
158 m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups
162− getHere :: These a b -> Maybe a
163− getHere = \case
164− This a -> Just a
165− These a _ -> Just a
166− That _ -> Nothing
167− getThere :: These a b -> Maybe b
168− getThere = \case
169− This _ -> Nothing
170− These _ b -> Just b
171− That b -> Just b
172
159
173−-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
160+-- |Project the @a@ from a @'These' a b@, identical to @preview '_Here'@ but without using preview
174−instance GCompare k => Monoid (PatchDMapWithMove k v) where
161+getHere :: These a b -> Maybe a
175− mempty = PatchDMapWithMove mempty
162+getHere = \case
176− mappend = (<>)
163+ This a -> Just a
164+ These a _ -> Just a
165+ That _ -> Nothing
166+
167+-- |Project the @b@ from a @'These' a b@, identical to @preview '_There'@ but without using preview
168+getThere :: These a b -> Maybe b
169+getThere = \case
170+ This _ -> Nothing
171+ These _ b -> Just b
172+ That b -> Just b
177
173
178{-
174{-
179mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
175mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
@@ -220,8 +216,8 @@ moveDMapKey src dst = case src `geq` dst of
220-- @
216-- @
221-- let aMay = DMap.lookup a dmap
217-- let aMay = DMap.lookup a dmap
222-- bMay = DMap.lookup b dmap
218-- bMay = DMap.lookup b dmap
223−-- in maybe id (DMap.insert a) (bMay <> aMay)
219+-- in maybe id (DMap.insert a) (bMay `mplus` aMay)
224−-- . maybe id (DMap.insert b) (aMay <> bMay)
220+-- . maybe id (DMap.insert b) (aMay `mplus` bMay)
225-- . DMap.delete a . DMap.delete b $ dmap
221-- . DMap.delete a . DMap.delete b $ dmap
226-- @
222-- @
227swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
223swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
@@ -272,7 +268,7 @@ unsafePatchDMapWithMove = PatchDMapWithMove
272
268
273-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while checking invariants. If the invariants are satisfied, @Right p@ is returned
269-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while checking invariants. If the invariants are satisfied, @Right p@ is returned
274-- otherwise @Left errors@.
270-- otherwise @Left errors@.
275−patchDMapWithMove :: (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)
271+patchDMapWithMove :: (GCompare k, GEq k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)
276patchDMapWithMove dm =
272patchDMapWithMove dm =
277 case validationErrorsForPatchDMapWithMove dm of
273 case validationErrorsForPatchDMapWithMove dm of
278 [] -> Right $ unsafePatchDMapWithMove dm
274 [] -> Right $ unsafePatchDMapWithMove dm
@@ -318,8 +314,8 @@ weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenD
318 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
314 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
319 From_Insert v -> MapWithMove.From_Insert $ f v
315 From_Insert v -> MapWithMove.From_Insert $ f v
320 From_Delete -> MapWithMove.From_Delete
316 From_Delete -> MapWithMove.From_Delete
321− From_Move k -> MapWithMove.From_Move $ mkSome k
317+ From_Move k -> MapWithMove.From_Move $ Some.This k
322− , MapWithMove._nodeInfo_to = mkSome <$> getComposeMaybe (_nodeInfo_to ni)
318+ , MapWithMove._nodeInfo_to = Some.This <$> getComposeMaybe (_nodeInfo_to ni)
323 }
319 }
324
320
325-- |"Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k v'@. Weaken is in scare quotes because the 'Const2' has already disabled any
321-- |"Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k v'@. Weaken is in scare quotes because the 'Const2' has already disabled any
@@ -349,7 +345,6 @@ const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fr
349 , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni
345 , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni
350 }
346 }
351
347
352−-- | Apply the insertions, deletions, and moves to a given 'DMap'.
353instance GCompare k => Patch (PatchDMapWithMove k v) where
348instance GCompare k => Patch (PatchDMapWithMove k v) where
354 type PatchTarget (PatchDMapWithMove k v) = DMap k v
349 type PatchTarget (PatchDMapWithMove k v) = DMap k v
355 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?
350 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?
@@ -365,7 +360,8 @@ instance GCompare k => Patch (PatchDMapWithMove k v) where
365 From_Delete -> Just $ Constant ()
360 From_Delete -> Just $ Constant ()
366 _ -> Nothing
361 _ -> Nothing
367
362
368−-- | Get the values that will be replaced, deleted, or moved if the given patch is applied to the given 'DMap'.
363+-- | Get the values that will be deleted or moved if the given patch is applied
364+-- to the given 'DMap'.
369getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))
365getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))
370getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
366getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
371 where f _ v ni = Pair v $ _nodeInfo_to ni
367 where f _ v ni = Pair v $ _nodeInfo_to ni
src/Reflex/Patch/IntMap.hsnew file+50
@@ -0,0 +1,50 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveFoldable #-}
3+{-# LANGUAGE DeriveFunctor #-}
4+{-# LANGUAGE DeriveTraversable #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6+{-# LANGUAGE TypeFamilies #-}
7+module Reflex.Patch.IntMap where
8+
9+import Data.IntMap.Strict (IntMap)
10+import qualified Data.IntMap.Strict as IntMap
11+import Data.Maybe
12+import Data.Semigroup
13+import Prelude hiding (lookup)
14+import Reflex.Patch.Class
15+
16+newtype PatchIntMap a = PatchIntMap (IntMap (Maybe a)) deriving (Functor, Foldable, Traversable, Monoid)
17+
18+instance Patch (PatchIntMap a) where
19+ type PatchTarget (PatchIntMap a) = IntMap a
20+ apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $
21+ let removes = IntMap.filter isNothing p
22+ adds = IntMap.mapMaybe id p
23+ in IntMap.union adds $ v `IntMap.difference` removes
24+
25+-- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@.
26+-- If the same key is modified by both patches, the one on the left will take
27+-- precedence.
28+instance Semigroup (PatchIntMap v) where
29+ PatchIntMap a <> PatchIntMap b = PatchIntMap $ a `mappend` b --TODO: Add a semigroup instance for Map
30+ -- PatchMap is idempotent, so stimes n is id for every n
31+#if MIN_VERSION_semigroups(0,17,0)
32+ stimes = stimesIdempotentMonoid
33+#else
34+ times1p n x = case compare n 0 of
35+ LT -> error "stimesIdempotentMonoid: negative multiplier"
36+ EQ -> mempty
37+ GT -> x
38+#endif
39+
40+traverseIntMapPatchWithKey :: Applicative t => (Int -> a -> t b) -> PatchIntMap a -> t (PatchIntMap b)
41+traverseIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap <$> IntMap.traverseWithKey (\k mv -> traverse (f k) mv) m
42+
43+patchIntMapNewElements :: PatchIntMap a -> [a]
44+patchIntMapNewElements (PatchIntMap m) = catMaybes $ IntMap.elems m
45+
46+patchIntMapNewElementsMap :: PatchIntMap a -> IntMap a
47+patchIntMapNewElementsMap (PatchIntMap m) = IntMap.mapMaybe id m
48+
49+getDeletions :: PatchIntMap v -> IntMap v' -> IntMap v'
50+getDeletions (PatchIntMap m) v = IntMap.intersection v m
src/Data/Patch/Map.hs → src/Reflex/Patch/Map.hsrenamed+30−38
@@ -1,50 +1,25 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DeriveTraversable #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE LambdaCase #-}
6−{-# LANGUAGE MultiParamTypeClasses #-}
7−{-# LANGUAGE StandaloneDeriving #-}
8−{-# LANGUAGE TemplateHaskell #-}
9{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE TypeFamilies #-}
10−
11-- | 'Patch'es on 'Map' that consist only of insertions (including overwrites)
4-- | 'Patch'es on 'Map' that consist only of insertions (including overwrites)
12-- and deletions
5-- and deletions
13−module Data.Patch.Map where
6+module Reflex.Patch.Map where
14
7
15−import Data.Patch.Class
8+import Reflex.Patch.Class
16
9
17−import Control.Lens
18import Data.Map (Map)
10import Data.Map (Map)
19import qualified Data.Map as Map
11import qualified Data.Map as Map
20import Data.Maybe
12import Data.Maybe
21−import Data.Monoid.DecidablyEmpty
13+import Data.Semigroup
22−import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid)
23
14
24-- | A set of changes to a 'Map'. Any element may be inserted/updated or
15-- | A set of changes to a 'Map'. Any element may be inserted/updated or
25-- deleted. Insertions are represented as values wrapped in 'Just', while
16-- deleted. Insertions are represented as values wrapped in 'Just', while
26-- deletions are represented as 'Nothing's
17-- deletions are represented as 'Nothing's
27newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }
18newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }
28− deriving ( Show, Read, Eq, Ord
19+ deriving (Show, Read, Eq, Ord)
29− , Foldable, Traversable
30− , DecidablyEmpty
31− )
32−
33−-- | 'fmap'ping a 'PatchMap' will alter all of the values it will insert.
34−-- Deletions are unaffected.
35−deriving instance Functor (PatchMap k)
36−-- | The empty 'PatchMap' contains no insertions or deletions
37−deriving instance Ord k => Monoid (PatchMap k v)
38−
39−-- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@.
40−-- If the same key is modified by both patches, the one on the left will take
41−-- precedence.
42−instance Ord k => Semigroup (PatchMap k v) where
43− PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map
44− -- PatchMap is idempotent, so stimes n is id for every n
45− stimes = stimesIdempotentMonoid
46
20
47−-- | Apply the insertions or deletions to a given 'Map'.
21+-- | Applying a 'PatchMap' will update the 'Map' by performing the insertions
22+-- and deletions specified
48instance Ord k => Patch (PatchMap k v) where
23instance Ord k => Patch (PatchMap k v) where
49 type PatchTarget (PatchMap k v) = Map k v
24 type PatchTarget (PatchMap k v) = Map k v
50 {-# INLINABLE apply #-}
25 {-# INLINABLE apply #-}
@@ -55,11 +30,30 @@ instance Ord k => Patch (PatchMap k v) where
55 Nothing -> Just ()
30 Nothing -> Just ()
56 Just _ -> Nothing
31 Just _ -> Nothing
57
32
33+-- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@.
34+-- If the same key is modified by both patches, the one on the left will take
35+-- precedence.
58−instance FunctorWithIndex k (PatchMap k)
36+instance Ord k => Semigroup (PatchMap k v) where
59−instance FoldableWithIndex k (PatchMap k)
37+ PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map
38+ -- PatchMap is idempotent, so stimes n is id for every n
39+#if MIN_VERSION_semigroups(0,17,0)
40+ stimes = stimesIdempotentMonoid
41+#else
42+ times1p n x = case compare n 0 of
43+ LT -> error "stimesIdempotentMonoid: negative multiplier"
44+ EQ -> mempty
45+ GT -> x
46+#endif
47+
48+-- | The empty 'PatchMap' contains no insertions or deletions
60−instance TraversableWithIndex k (PatchMap k) where
49+instance Ord k => Monoid (PatchMap k v) where
61− itraverse = itraversed . Indexed
50+ mempty = PatchMap mempty
62− itraversed = _Wrapped .> itraversed <. traversed
51+ mappend = (<>)
52+
53+-- | 'fmap'ping a 'PatchMap' will alter all of the values it will insert.
54+-- Deletions are unaffected.
55+instance Functor (PatchMap k) where
56+ fmap f = PatchMap . fmap (fmap f) . unPatchMap
63
57
64-- | Returns all the new elements that will be added to the 'Map'
58-- | Returns all the new elements that will be added to the 'Map'
65patchMapNewElements :: PatchMap k v -> [v]
59patchMapNewElements :: PatchMap k v -> [v]
@@ -68,5 +62,3 @@ patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p
68-- | Returns all the new elements that will be added to the 'Map'
62-- | Returns all the new elements that will be added to the 'Map'
69patchMapNewElementsMap :: PatchMap k v -> Map k v
63patchMapNewElementsMap :: PatchMap k v -> Map k v
70patchMapNewElementsMap (PatchMap p) = Map.mapMaybe id p
64patchMapNewElementsMap (PatchMap p) = Map.mapMaybe id p
71−
72−makeWrapped ''PatchMap
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+-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
9+-- another
10+module Reflex.Patch.MapWithMove where
11+
12+import Reflex.Patch.Class
13+
14+import Control.Arrow
15+import Control.Monad.State
16+import Data.Foldable
17+import Data.Function
18+import Data.List
19+import Data.Map (Map)
20+import qualified Data.Map as Map
21+import Data.Maybe
22+import qualified Data.Set as Set
23+import Data.Tuple
24+
25+-- | Patch a DMap with additions, deletions, and moves. Invariant: If key @k1@
26+-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
27+-- and vice versa. There should never be any unpaired From/To keys.
28+newtype PatchMapWithMove k v = PatchMapWithMove (Map k (NodeInfo k v)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
29+
30+-- | Holds the information about each key: where its new value should come from,
31+-- and where its old value should go to
32+data NodeInfo k v = NodeInfo
33+ { _nodeInfo_from :: !(From k v)
34+ -- ^ Where do we get the new value for this key?
35+ , _nodeInfo_to :: !(To k)
36+ -- ^ If the old value is being kept (i.e. moved rather than deleted or
37+ -- replaced), where is it going?
38+ }
39+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
40+
41+-- | Create a 'PatchMapWithMove', validating it
42+patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
43+patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing
44+ where valid = forwardLinks == backwardLinks
45+ forwardLinks = Map.mapMaybe _nodeInfo_to m
46+ backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, v) ->
47+ case _nodeInfo_from v of
48+ From_Move from -> Just (from, to)
49+ _ -> Nothing
50+
51+-- | Extract the internal representation of the 'PatchMapWithMove'
52+unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)
53+unPatchMapWithMove (PatchMapWithMove p) = p
54+
55+-- | Warning: when using this function, you must ensure that the invariants of
56+-- 'PatchMapWithMove' are preserved; they will not be checked.
57+unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
58+unsafePatchMapWithMove = PatchMapWithMove
59+
60+-- | Describe how a key's new value should be produced
61+data From k v
62+ = From_Insert v -- ^ Insert the given value here
63+ | From_Delete -- ^ Delete the existing value, if any, from here
64+ | From_Move !k -- ^ Move the value here from the given key
65+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
66+
67+-- | Describe where a key's old value will go. If this is 'Just', that means
68+-- the key's old value will be moved to the given other key; if it is 'Nothing',
69+-- that means it will be deleted.
70+type To = Maybe
71+
72+-- | Apply the insertions, deletions, and moves to a given 'Map'
73+instance Ord k => Patch (PatchMapWithMove k v) where
74+ type PatchTarget (PatchMapWithMove k v) = Map k v
75+ 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?
76+ where insertions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of
77+ From_Insert v -> Just v
78+ From_Move k -> Map.lookup k old
79+ From_Delete -> Nothing
80+ deletions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of
81+ From_Delete -> Just ()
82+ _ -> Nothing
83+
84+-- | Returns all the new elements that will be added to the 'Map'
85+patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
86+patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap
87+
88+patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v
89+patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p
90+ where f ni = case _nodeInfo_from ni of
91+ From_Insert v -> Just v
92+ From_Move _ -> Nothing
93+ From_Delete -> Nothing
94+
95+-- | Create a 'PatchMapWithMove' that, if applied to the given 'Map', will sort
96+-- its values using the given ordering function. The set keys of the 'Map' is
97+-- not changed.
98+patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v
99+patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted
100+ where unsorted = Map.toList m
101+ sorted = sortBy (cmp `on` snd) unsorted
102+ f (to, _) (from, _) = if to == from then Nothing else
103+ Just (from, to)
104+ reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
105+ g (to, _) (from, _) = if to == from then Nothing else
106+ let Just movingTo = Map.lookup from reverseMapping
107+ in Just (to, NodeInfo (From_Move from) $ Just movingTo)
108+
109+-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
110+-- will produce a 'Map' with the same values as the second 'Map' but with the
111+-- values sorted with the given ordering function.
112+patchThatChangesAndSortsMapWith :: forall k v. (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
113+patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patch
114+ where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
115+ newList = Map.toList newByIndexUnsorted
116+ newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
117+ insertsAndMoves :: Map k (NodeInfo k v)
118+ (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
119+ let f k v = do
120+ remainingValues <- get
121+ let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
122+ then Map.delete v remainingValues
123+ else Map.insert v remainingKeys remainingValues
124+ case Map.lookup v remainingValues of
125+ Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
126+ Just fromKs ->
127+ if k `Set.member` fromKs
128+ then do
129+ putRemainingKeys $ Set.delete k fromKs
130+ return $ NodeInfo (From_Move k) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
131+ else do
132+ Just (fromK, remainingKeys) <- return $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
133+ putRemainingKeys remainingKeys
134+ return $ NodeInfo (From_Move fromK) $ Just undefined
135+ Map.traverseWithKey f newByIndex
136+ unusedOldKeys = fold unusedValuesByValue
137+ pointlessMove k = \case
138+ From_Move k' | k == k' -> True
139+ _ -> False
140+ keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
141+ then Just undefined
142+ else Nothing
143+ 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
144+
145+-- | Change the 'From' value of a 'NodeInfo'
146+nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
147+nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
148+
149+-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
150+-- 'Applicative', 'Monad', etc.) action to get the new value
151+nodeInfoMapMFrom :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
152+nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
153+
154+-- | Set the 'To' field of a 'NodeInfo'
155+nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v
156+nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
src/Reflex/PerformEvent/Base.hsnew file+178
@@ -0,0 +1,178 @@
1+-- | This module provides 'PerformEventT', the standard implementation of
2+-- 'PerformEvent'.
3+{-# LANGUAGE CPP #-}
4+{-# LANGUAGE ExistentialQuantification #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE GADTs #-}
8+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9+{-# LANGUAGE MultiParamTypeClasses #-}
10+{-# LANGUAGE PartialTypeSignatures #-}
11+{-# LANGUAGE PolyKinds #-}
12+{-# LANGUAGE RankNTypes #-}
13+{-# LANGUAGE ScopedTypeVariables #-}
14+{-# LANGUAGE StandaloneDeriving #-}
15+{-# LANGUAGE TypeFamilies #-}
16+{-# LANGUAGE TypeOperators #-}
17+{-# LANGUAGE UndecidableInstances #-}
18+#ifdef USE_REFLEX_OPTIMIZER
19+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
20+#endif
21+module Reflex.PerformEvent.Base
22+ ( PerformEventT (..)
23+ , FireCommand (..)
24+ , hostPerformEventT
25+ ) where
26+
27+import Reflex.Class
28+import Reflex.Host.Class
29+import Reflex.PerformEvent.Class
30+import Reflex.Requester.Base
31+import Reflex.Requester.Class
32+
33+import Control.Lens
34+import Control.Monad.Exception
35+import Control.Monad.Identity
36+import Control.Monad.Primitive
37+import Control.Monad.Reader
38+import Control.Monad.Ref
39+import Data.Coerce
40+import Data.Dependent.Map (DMap)
41+import qualified Data.Dependent.Map as DMap
42+import Data.Dependent.Sum
43+import Data.IntMap.Strict (IntMap)
44+import qualified Data.IntMap.Strict as IntMap
45+import qualified Data.Semigroup as S
46+
47+-- | A function that fires events for the given 'EventTrigger's and then runs
48+-- any followup actions provided via 'PerformEvent'. The given 'ReadPhase'
49+-- action will be run once for the initial trigger execution as well as once for
50+-- each followup.
51+newtype FireCommand t m = FireCommand { runFireCommand :: forall a. [DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a] } --TODO: The handling of this ReadPhase seems wrong, or at least inelegant; how do we actually make the decision about what order frames run in?
52+
53+-- | Provides a basic implementation of 'PerformEvent'. Note that, despite the
54+-- name, 'PerformEventT' is not an instance of 'MonadTrans'.
55+newtype PerformEventT t m a = PerformEventT { unPerformEventT :: RequesterT t (HostFrame t) Identity (HostFrame t) a }
56+
57+deriving instance ReflexHost t => Functor (PerformEventT t m)
58+deriving instance ReflexHost t => Applicative (PerformEventT t m)
59+deriving instance ReflexHost t => Monad (PerformEventT t m)
60+deriving instance ReflexHost t => MonadFix (PerformEventT t m)
61+deriving instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (PerformEventT t m)
62+deriving instance (ReflexHost t, MonadException (HostFrame t)) => MonadException (PerformEventT t m)
63+deriving instance (ReflexHost t, Applicative m, Monoid a) => Monoid (PerformEventT t m a)
64+deriving instance (ReflexHost t, Applicative m, S.Semigroup a) => S.Semigroup (PerformEventT t m a)
65+
66+instance (PrimMonad (HostFrame t), ReflexHost t) => PrimMonad (PerformEventT t m) where
67+ type PrimState (PerformEventT t m) = PrimState (HostFrame t)
68+ primitive = PerformEventT . lift . primitive
69+
70+instance (ReflexHost t, Ref m ~ Ref IO, PrimMonad (HostFrame t)) => PerformEvent t (PerformEventT t m) where
71+ type Performable (PerformEventT t m) = HostFrame t
72+ {-# INLINABLE performEvent_ #-}
73+ performEvent_ = PerformEventT . requesting_
74+ {-# INLINABLE performEvent #-}
75+ performEvent = PerformEventT . requestingIdentity
76+
77+instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT t m) where
78+ runWithReplace outerA0 outerA' = PerformEventT $ runWithReplaceRequesterTWith f (coerce outerA0) (coerceEvent outerA')
79+ where f :: HostFrame t a -> Event t (HostFrame t b) -> RequesterT t (HostFrame t) Identity (HostFrame t) (a, Event t b)
80+ f a0 a' = do
81+ result0 <- lift a0
82+ result' <- requestingIdentity a'
83+ return (result0, result')
84+ traverseIntMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseIntMapWithKeyWithAdjustRequesterTWith (defaultAdjustIntBase traverseIntMapPatchWithKey) patchIntMapNewElementsMap mergeIntIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')
85+ traverseDMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithKey) mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')
86+ traverseDMapWithKeyWithAdjustWithMove f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithMoveWithKey) mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')
87+
88+defaultAdjustBase :: forall t v v2 k' p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t)
89+ => ((forall a. k' a -> v a -> HostFrame t (v2 a)) -> p k' v -> HostFrame t (p k' v2))
90+ -> (forall a. k' a -> v a -> HostFrame t (v2 a))
91+ -> DMap k' v
92+ -> Event t (p k' v)
93+ -> RequesterT t (HostFrame t) Identity (HostFrame t) (DMap k' v2, Event t (p k' v2))
94+defaultAdjustBase traversePatchWithKey f' dm0 dm' = do
95+ result0 <- lift $ DMap.traverseWithKey f' dm0
96+ result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f'
97+ return (result0, result')
98+
99+defaultAdjustIntBase :: forall t v v2 p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t)
100+ => ((IntMap.Key -> v -> HostFrame t v2) -> p v -> HostFrame t (p v2))
101+ -> (IntMap.Key -> v -> HostFrame t v2)
102+ -> IntMap v
103+ -> Event t (p v)
104+ -> RequesterT t (HostFrame t) Identity (HostFrame t) (IntMap v2, Event t (p v2))
105+defaultAdjustIntBase traversePatchWithKey f' dm0 dm' = do
106+ result0 <- lift $ IntMap.traverseWithKey f' dm0
107+ result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f'
108+ return (result0, result')
109+
110+instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where
111+ {-# INLINABLE newEventWithTrigger #-}
112+ newEventWithTrigger = PerformEventT . lift . newEventWithTrigger
113+ {-# INLINABLE newFanEventWithTrigger #-}
114+ newFanEventWithTrigger f = PerformEventT $ lift $ newFanEventWithTrigger f
115+
116+-- | Run a 'PerformEventT' action, returning a 'FireCommand' that allows the
117+-- caller to trigger 'Event's while ensuring that 'performEvent' actions are run
118+-- at the appropriate time.
119+{-# INLINABLE hostPerformEventT #-}
120+hostPerformEventT :: forall t m a.
121+ ( Monad m
122+ , MonadSubscribeEvent t m
123+ , MonadReflexHost t m
124+ , MonadRef m
125+ , Ref m ~ Ref IO
126+ )
127+ => PerformEventT t m a
128+ -> m (a, FireCommand t m)
129+hostPerformEventT a = do
130+ (response, responseTrigger) <- newEventWithTriggerRef
131+ (result, eventToPerform) <- runHostFrame $ runRequesterT (unPerformEventT a) response
132+ eventToPerformHandle <- subscribeEvent eventToPerform
133+ return $ (,) result $ FireCommand $ \triggers (readPhase :: ReadPhase m a') -> do
134+ let go :: [DSum (EventTrigger t) Identity] -> m [a']
135+ go ts = do
136+ (result', mToPerform) <- fireEventsAndRead ts $ do
137+ mToPerform <- sequence =<< readEvent eventToPerformHandle
138+ result' <- readPhase
139+ return (result', mToPerform)
140+ case mToPerform of
141+ Nothing -> return [result']
142+ Just toPerform -> do
143+ responses <- runHostFrame $ traverseRequesterData (\v -> Identity <$> v) toPerform
144+ mrt <- readRef responseTrigger
145+ let followupEventTriggers = case mrt of
146+ Just rt -> [rt :=> Identity responses]
147+ Nothing -> []
148+ (result':) <$> go followupEventTriggers
149+ go triggers
150+
151+instance ReflexHost t => MonadSample t (PerformEventT t m) where
152+ {-# INLINABLE sample #-}
153+ sample = PerformEventT . lift . sample
154+
155+instance (ReflexHost t, MonadHold t m) => MonadHold t (PerformEventT t m) where
156+ {-# INLINABLE hold #-}
157+ hold v0 v' = PerformEventT $ lift $ hold v0 v'
158+ {-# INLINABLE holdDyn #-}
159+ holdDyn v0 v' = PerformEventT $ lift $ holdDyn v0 v'
160+ {-# INLINABLE holdIncremental #-}
161+ holdIncremental v0 v' = PerformEventT $ lift $ holdIncremental v0 v'
162+ {-# INLINABLE buildDynamic #-}
163+ buildDynamic getV0 v' = PerformEventT $ lift $ buildDynamic getV0 v'
164+ {-# INLINABLE headE #-}
165+ headE = PerformEventT . lift . headE
166+
167+instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m) where
168+ type Ref (PerformEventT t m) = Ref (HostFrame t)
169+ {-# INLINABLE newRef #-}
170+ newRef = PerformEventT . lift . newRef
171+ {-# INLINABLE readRef #-}
172+ readRef = PerformEventT . lift . readRef
173+ {-# INLINABLE writeRef #-}
174+ writeRef r = PerformEventT . lift . writeRef r
175+
176+instance (MonadAtomicRef (HostFrame t), ReflexHost t) => MonadAtomicRef (PerformEventT t m) where
177+ {-# INLINABLE atomicModifyRef #-}
178+ atomicModifyRef r = PerformEventT . lift . atomicModifyRef r
src/Reflex/PerformEvent/Class.hsnew file+64
@@ -0,0 +1,64 @@
1+-- | This module defines 'PerformEvent' and 'TriggerEvent', which mediate the
2+-- interaction between a "Reflex"-based program and the external side-effecting
3+-- actions such as 'IO'.
4+{-# LANGUAGE CPP #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE FunctionalDependencies #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
9+{-# LANGUAGE RankNTypes #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE TypeOperators #-}
13+{-# LANGUAGE UndecidableInstances #-}
14+#ifdef USE_REFLEX_OPTIMIZER
15+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
16+#endif
17+module Reflex.PerformEvent.Class
18+ ( PerformEvent (..)
19+ , performEventAsync
20+ ) where
21+
22+import Reflex.Class
23+import Reflex.TriggerEvent.Class
24+
25+import Control.Monad.Reader
26+
27+-- | 'PerformEvent' represents actions that can trigger other actions based on
28+-- 'Event's.
29+class (Reflex t, Monad (Performable m), Monad m) => PerformEvent t m | m -> t where
30+ -- | The type of action to be triggered; this is often not the same type as
31+ -- the triggering action.
32+ type Performable m :: * -> *
33+ -- | Perform the action contained in the given 'Event' whenever the 'Event'
34+ -- fires. Return the result in another 'Event'. Note that the output 'Event'
35+ -- will generally occur later than the input 'Event', since most 'Performable'
36+ -- actions cannot be performed during 'Event' propagation.
37+ performEvent :: Event t (Performable m a) -> m (Event t a)
38+ -- | Like 'performEvent', but do not return the result. May have slightly
39+ -- better performance.
40+ performEvent_ :: Event t (Performable m ()) -> m ()
41+
42+-- | Like 'performEvent', but the resulting 'Event' occurs only when the
43+-- callback (@a -> IO ()@) is called, not when the included action finishes.
44+--
45+-- NOTE: Despite the name, 'performEventAsync' does not run its action in a
46+-- separate thread - although the action is free to invoke forkIO and then call
47+-- the callback whenever it is ready. This will work properly, even in GHCJS
48+-- (which fully implements concurrency even though JavaScript does not have
49+-- built in concurrency).
50+{-# INLINABLE performEventAsync #-}
51+performEventAsync :: (TriggerEvent t m, PerformEvent t m) => Event t ((a -> IO ()) -> Performable m ()) -> m (Event t a)
52+performEventAsync e = do
53+ (eOut, triggerEOut) <- newTriggerEvent
54+ performEvent_ $ fmap ($ triggerEOut) e
55+ return eOut
56+
57+instance PerformEvent t m => PerformEvent t (ReaderT r m) where
58+ type Performable (ReaderT r m) = ReaderT r (Performable m)
59+ performEvent_ e = do
60+ r <- ask
61+ lift $ performEvent_ $ flip runReaderT r <$> e
62+ performEvent e = do
63+ r <- ask
64+ lift $ performEvent $ flip runReaderT r <$> e
src/Reflex/PostBuild/Base.hsnew file+196
@@ -0,0 +1,196 @@
1+-- | This module defines 'PostBuildT', the standard implementation of
2+-- 'PostBuild'.
3+{-# LANGUAGE CPP #-}
4+{-# LANGUAGE DataKinds #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE RankNTypes #-}
9+{-# LANGUAGE RecursiveDo #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE TypeOperators #-}
13+{-# LANGUAGE UndecidableInstances #-}
14+#ifdef USE_REFLEX_OPTIMIZER
15+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
16+#endif
17+module Reflex.PostBuild.Base
18+ ( PostBuildT (..)
19+ , runPostBuildT
20+ -- * Internal
21+ , mapIntMapWithAdjustImpl
22+ , mapDMapWithAdjustImpl
23+ ) where
24+
25+import Reflex.Class
26+import Reflex.Host.Class
27+import Reflex.PerformEvent.Class
28+import Reflex.PostBuild.Class
29+import Reflex.TriggerEvent.Class
30+
31+import Control.Applicative (liftA2)
32+import Control.Monad.Exception
33+import Control.Monad.Identity
34+import Control.Monad.Primitive
35+import Control.Monad.Reader
36+import Control.Monad.Ref
37+import qualified Control.Monad.Trans.Control as TransControl
38+import Data.Dependent.Map (DMap)
39+import qualified Data.Dependent.Map as DMap
40+import Data.Functor.Compose
41+import Data.IntMap.Strict (IntMap)
42+import qualified Data.IntMap.Strict as IntMap
43+import qualified Data.Semigroup as S
44+
45+-- | Provides a basic implementation of 'PostBuild'.
46+newtype PostBuildT t m a = PostBuildT { unPostBuildT :: ReaderT (Event t ()) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadTrans, MonadException, MonadAsyncException)
47+
48+-- | Run a 'PostBuildT' action. An 'Event' should be provided that fires
49+-- immediately after the action is finished running; no other 'Event's should
50+-- fire first.
51+{-# INLINABLE runPostBuildT #-}
52+runPostBuildT :: PostBuildT t m a -> Event t () -> m a
53+runPostBuildT (PostBuildT a) = runReaderT a
54+
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+
63+instance PrimMonad m => PrimMonad (PostBuildT x m) where
64+ type PrimState (PostBuildT x m) = PrimState m
65+ primitive = lift . primitive
66+
67+instance (Reflex t, Monad m) => PostBuild t (PostBuildT t m) where
68+ {-# INLINABLE getPostBuild #-}
69+ getPostBuild = PostBuildT ask
70+
71+instance MonadSample t m => MonadSample t (PostBuildT t m) where
72+ {-# INLINABLE sample #-}
73+ sample = lift . sample
74+
75+instance MonadHold t m => MonadHold t (PostBuildT t m) where
76+ {-# INLINABLE hold #-}
77+ hold v0 = lift . hold v0
78+ {-# INLINABLE holdDyn #-}
79+ holdDyn v0 = lift . holdDyn v0
80+ {-# INLINABLE holdIncremental #-}
81+ holdIncremental v0 = lift . holdIncremental v0
82+ {-# INLINABLE buildDynamic #-}
83+ buildDynamic a0 = lift . buildDynamic a0
84+ {-# INLINABLE headE #-}
85+ headE = lift . headE
86+
87+instance PerformEvent t m => PerformEvent t (PostBuildT t m) where
88+ type Performable (PostBuildT t m) = Performable m
89+ {-# INLINABLE performEvent_ #-}
90+ performEvent_ = lift . performEvent_
91+ {-# INLINABLE performEvent #-}
92+ performEvent = lift . performEvent
93+
94+instance (ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (PostBuildT t m) where
95+ {-# INLINABLE newEventWithTrigger #-}
96+ newEventWithTrigger = PostBuildT . lift . newEventWithTrigger
97+ {-# INLINABLE newFanEventWithTrigger #-}
98+ newFanEventWithTrigger f = PostBuildT $ lift $ newFanEventWithTrigger f
99+
100+instance TriggerEvent t m => TriggerEvent t (PostBuildT t m) where
101+ {-# INLINABLE newTriggerEvent #-}
102+ newTriggerEvent = lift newTriggerEvent
103+ {-# INLINABLE newTriggerEventWithOnComplete #-}
104+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
105+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
106+
107+instance MonadRef m => MonadRef (PostBuildT t m) where
108+ type Ref (PostBuildT t m) = Ref m
109+ {-# INLINABLE newRef #-}
110+ newRef = lift . newRef
111+ {-# INLINABLE readRef #-}
112+ readRef = lift . readRef
113+ {-# INLINABLE writeRef #-}
114+ writeRef r = lift . writeRef r
115+
116+instance MonadAtomicRef m => MonadAtomicRef (PostBuildT t m) where
117+ {-# INLINABLE atomicModifyRef #-}
118+ atomicModifyRef r = lift . atomicModifyRef r
119+
120+instance (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, PerformEvent t m) => Adjustable t (PostBuildT t m) where
121+ runWithReplace a0 a' = do
122+ postBuild <- getPostBuild
123+ lift $ do
124+ rec result@(_, result') <- runWithReplace (runPostBuildT a0 postBuild) $ fmap (\v -> runPostBuildT v =<< headE voidResult') a'
125+ let voidResult' = fmapCheap (\_ -> ()) result'
126+ return result
127+ {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}
128+ traverseIntMapWithKeyWithAdjust = mapIntMapWithAdjustImpl traverseIntMapWithKeyWithAdjust
129+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
130+ traverseDMapWithKeyWithAdjust = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap
131+ traverseDMapWithKeyWithAdjustWithMove = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove
132+
133+{-# INLINABLE mapIntMapWithAdjustImpl #-}
134+mapIntMapWithAdjustImpl :: forall t m v v' p. (Reflex t, MonadFix m, MonadHold t m, Functor p)
135+ => ( (IntMap.Key -> (Event t (), v) -> m v')
136+ -> IntMap (Event t (), v)
137+ -> Event t (p (Event t (), v))
138+ -> m (IntMap v', Event t (p v'))
139+ )
140+ -> (IntMap.Key -> v -> PostBuildT t m v')
141+ -> IntMap v
142+ -> Event t (p v)
143+ -> PostBuildT t m (IntMap v', Event t (p v'))
144+mapIntMapWithAdjustImpl base f dm0 dm' = do
145+ postBuild <- getPostBuild
146+ let loweredDm0 = fmap ((,) postBuild) dm0
147+ f' :: IntMap.Key -> (Event t (), v) -> m v'
148+ f' k (e, v) = do
149+ runPostBuildT (f k v) e
150+ lift $ do
151+ rec (result0, result') <- base f' loweredDm0 loweredDm'
152+ cohortDone <- numberOccurrencesFrom_ 1 result'
153+ numberedDm' <- numberOccurrencesFrom 1 dm'
154+ let postBuild' = fanInt $ fmapCheap (`IntMap.singleton` ()) cohortDone
155+ loweredDm' = flip pushAlways numberedDm' $ \(n, p) -> do
156+ return $ fmap ((,) (selectInt postBuild' n)) p
157+ return (result0, result')
158+
159+{-# INLINABLE mapDMapWithAdjustImpl #-}
160+mapDMapWithAdjustImpl :: forall t m k v v' p. (Reflex t, MonadFix m, MonadHold t m)
161+ => ( (forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a))
162+ -> DMap k (Compose ((,) (Bool, Event t ())) v)
163+ -> Event t (p k (Compose ((,) (Bool, Event t ())) v))
164+ -> m (DMap k v', Event t (p k v'))
165+ )
166+ -> ((forall a. v a -> Compose ((,) (Bool, Event t ())) v a) -> p k v -> p k (Compose ((,) (Bool, Event t ())) v))
167+ -> (forall a. k a -> v a -> PostBuildT t m (v' a))
168+ -> DMap k v
169+ -> Event t (p k v)
170+ -> PostBuildT t m (DMap k v', Event t (p k v'))
171+mapDMapWithAdjustImpl base mapPatch f dm0 dm' = do
172+ postBuild <- getPostBuild
173+ let loweredDm0 = DMap.map (Compose . (,) (False, postBuild)) dm0
174+ f' :: forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a)
175+ f' k (Compose ((shouldHeadE, e), v)) = do
176+ eOnce <- if shouldHeadE
177+ then headE e --TODO: Avoid doing this headE so many times; once per loweredDm' firing ought to be OK, but it's not totally trivial to do because result' might be firing at the same time, and we don't want *that* to be the postBuild occurrence
178+ else return e
179+ runPostBuildT (f k v) eOnce
180+ lift $ do
181+ rec (result0, result') <- base f' loweredDm0 loweredDm'
182+ let voidResult' = fmapCheap (\_ -> ()) result'
183+ let loweredDm' = ffor dm' $ mapPatch (Compose . (,) (True, voidResult'))
184+ return (result0, result')
185+
186+--------------------------------------------------------------------------------
187+-- Deprecated functionality
188+--------------------------------------------------------------------------------
189+
190+-- | Deprecated
191+instance TransControl.MonadTransControl (PostBuildT t) where
192+ type StT (PostBuildT t) a = TransControl.StT (ReaderT (Event t ())) a
193+ {-# INLINABLE liftWith #-}
194+ liftWith = TransControl.defaultLiftWith PostBuildT unPostBuildT
195+ {-# INLINABLE restoreT #-}
196+ restoreT = TransControl.defaultRestoreT PostBuildT
src/Reflex/PostBuild/Class.hsnew file+42
@@ -0,0 +1,42 @@
1+-- | This module defines 'PostBuild', which indicates that an action will be
2+-- notified when it, and any action it's a part of, has finished executing.
3+{-# LANGUAGE CPP #-}
4+{-# LANGUAGE DataKinds #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE FunctionalDependencies #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE TypeOperators #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+#ifdef USE_REFLEX_OPTIMIZER
13+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
14+#endif
15+module Reflex.PostBuild.Class
16+ ( PostBuild (..)
17+ ) where
18+
19+import Reflex.Class
20+
21+import Control.Monad.Reader
22+import Control.Monad.State
23+import qualified Control.Monad.State.Strict as Strict
24+
25+-- | 'PostBuild' represents an action that is notified via an 'Event' when it
26+-- has finished executing. Note that the specific definition of "finished" is
27+-- determined by the instance of 'PostBuild', but the intent is to allow
28+-- 'Behavior's and 'Dynamic's to be safely sampled, regardless of where they
29+-- were created, when the post-build 'Event' fires. The post-build 'Event' will
30+-- fire exactly once for an given action.
31+class (Reflex t, Monad m) => PostBuild t m | m -> t where
32+ -- | Retrieve the post-build 'Event' for this action.
33+ getPostBuild :: m (Event t ())
34+
35+instance PostBuild t m => PostBuild t (ReaderT r m) where
36+ getPostBuild = lift getPostBuild
37+
38+instance PostBuild t m => PostBuild t (StateT s m) where
39+ getPostBuild = lift getPostBuild
40+
41+instance PostBuild t m => PostBuild t (Strict.StateT s m) where
42+ getPostBuild = lift getPostBuild
src/Reflex/Profiled.hsnew file+211
@@ -0,0 +1,211 @@
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+module Reflex.Profiled where
12+
13+import Control.Lens hiding (children)
14+import Control.Monad
15+import Control.Monad.Fix
16+import Control.Monad.Primitive
17+import Control.Monad.Reader
18+import Control.Monad.Ref
19+import Control.Monad.State.Strict (StateT, execStateT, modify)
20+import Data.Coerce
21+import Data.Dependent.Map (DMap, GCompare)
22+import Data.FastMutableIntMap
23+import Data.IORef
24+import Data.List
25+import Data.Map (Map)
26+import qualified Data.Map.Strict as Map
27+import Data.Monoid ((<>))
28+import Data.Ord
29+import qualified Data.Semigroup as S
30+import Data.Type.Coercion
31+import Foreign.Ptr
32+import GHC.Foreign
33+import GHC.IO.Encoding
34+import GHC.Stack
35+import Reflex.Class
36+import Reflex.Host.Class
37+import Reflex.PerformEvent.Class
38+
39+import System.IO.Unsafe
40+import Unsafe.Coerce
41+
42+data ProfiledTimeline t
43+
44+{-# NOINLINE profilingData #-}
45+profilingData :: IORef (Map (Ptr CostCentreStack) Int)
46+profilingData = unsafePerformIO $ newIORef Map.empty
47+
48+data CostCentreTree = CostCentreTree
49+ { _costCentreTree_ownEntries :: !Int
50+ , _costCentreTree_cumulativeEntries :: !Int
51+ , _costCentreTree_children :: !(Map (Ptr CostCentre) CostCentreTree)
52+ }
53+ deriving (Show, Eq, Ord)
54+
55+instance S.Semigroup CostCentreTree where
56+ (CostCentreTree oa ea ca) <> (CostCentreTree ob eb cb) =
57+ CostCentreTree (oa + ob) (ea + eb) $ Map.unionWith (S.<>) ca cb
58+
59+instance Monoid CostCentreTree where
60+ mempty = CostCentreTree 0 0 mempty
61+ mappend = (S.<>)
62+
63+getCostCentreStack :: Ptr CostCentreStack -> IO [Ptr CostCentre]
64+getCostCentreStack = go []
65+ where go l ccs = if ccs == nullPtr
66+ then return l
67+ else do
68+ cc <- ccsCC ccs
69+ parent <- ccsParent ccs
70+ go (cc : l) parent
71+
72+toCostCentreTree :: Ptr CostCentreStack -> Int -> IO CostCentreTree
73+toCostCentreTree ccs n = do
74+ ccList <- getCostCentreStack ccs
75+ return $ foldr (\cc child -> CostCentreTree 0 n $ Map.singleton cc child) (CostCentreTree n n mempty) ccList
76+
77+getCostCentreTree :: IO CostCentreTree
78+getCostCentreTree = do
79+ vals <- readIORef profilingData
80+ mconcat <$> mapM (uncurry toCostCentreTree) (Map.toList vals)
81+
82+formatCostCentreTree :: CostCentreTree -> IO String
83+formatCostCentreTree cct0 = unlines . reverse <$> execStateT (go 0 cct0) []
84+ where go :: Int -> CostCentreTree -> StateT [String] IO ()
85+ go depth cct = do
86+ let children = sortOn (Down . _costCentreTree_cumulativeEntries . snd) $ Map.toList $ _costCentreTree_children cct
87+ indent = mconcat $ replicate depth " "
88+ forM_ children $ \(cc, childCct) -> do
89+ lbl <- liftIO $ peekCString utf8 =<< ccLabel cc
90+ mdl <- liftIO $ peekCString utf8 =<< ccModule cc
91+ loc <- liftIO $ peekCString utf8 =<< ccSrcSpan cc
92+ let description = mdl <> "." <> lbl <> " (" <> loc <> ")"
93+ modify $ (:) $ indent <> description <> "\t" <> show (_costCentreTree_cumulativeEntries childCct) <> "\t" <> show (_costCentreTree_ownEntries childCct)
94+ go (succ depth) childCct
95+
96+showProfilingData :: IO ()
97+showProfilingData = do
98+ putStr =<< formatCostCentreTree =<< getCostCentreTree
99+
100+writeProfilingData :: FilePath -> IO ()
101+writeProfilingData p = do
102+ writeFile p =<< formatCostCentreTree =<< getCostCentreTree
103+
104+newtype ProfiledM m a = ProfiledM { runProfiledM :: m a } deriving (Functor, Applicative, Monad, MonadFix)
105+
106+profileEvent :: Reflex t => Event t a -> Event t a
107+profileEvent e = unsafePerformIO $ do
108+ stack <- getCurrentCCS e
109+ let f x = unsafePerformIO $ do
110+ modifyIORef' profilingData $ Map.insertWith (+) stack 1
111+ return $ return $ Just x
112+ return $ pushCheap f e
113+
114+--TODO: Instead of profiling just the input or output of each one, profile all the inputs and all the outputs
115+
116+instance Reflex t => Reflex (ProfiledTimeline t) where
117+ newtype Behavior (ProfiledTimeline t) a = Behavior_Profiled { unBehavior_Profiled :: Behavior t a }
118+ newtype Event (ProfiledTimeline t) a = Event_Profiled { unEvent_Profiled :: Event t a }
119+ newtype Dynamic (ProfiledTimeline t) a = Dynamic_Profiled { unDynamic_Profiled :: Dynamic t a }
120+ newtype Incremental (ProfiledTimeline t) p = Incremental_Profiled { unIncremental_Profiled :: Incremental t p }
121+ type PushM (ProfiledTimeline t) = ProfiledM (PushM t)
122+ type PullM (ProfiledTimeline t) = ProfiledM (PullM t)
123+ never = Event_Profiled never
124+ constant = Behavior_Profiled . constant
125+ push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us
126+ pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e
127+ pull = Behavior_Profiled . pull . coerce
128+ merge :: forall k. GCompare k => DMap k (Event (ProfiledTimeline t)) -> Event (ProfiledTimeline t) (DMap k Identity)
129+ merge = Event_Profiled . merge . (unsafeCoerce :: DMap k (Event (ProfiledTimeline t)) -> DMap k (Event t))
130+ fan (Event_Profiled e) = EventSelector $ coerce $ select (fan $ profileEvent e)
131+ switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b)
132+ coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e)
133+ current (Dynamic_Profiled d) = coerce $ current d
134+ updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d
135+ unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a'
136+ unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a'
137+ mergeIncremental = Event_Profiled . mergeIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMap k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMap k (Event t)))
138+ mergeIncrementalWithMove = Event_Profiled . mergeIncrementalWithMove . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMapWithMove k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMapWithMove k (Event t)))
139+ currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i
140+ updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i
141+ incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i
142+ behaviorCoercion (c :: Coercion a b) = case behaviorCoercion c :: Coercion (Behavior t a) (Behavior t b) of
143+ Coercion -> unsafeCoerce (Coercion :: Coercion (Behavior (ProfiledTimeline t) a) (Behavior (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
144+ eventCoercion (c :: Coercion a b) = case eventCoercion c :: Coercion (Event t a) (Event t b) of
145+ Coercion -> unsafeCoerce (Coercion :: Coercion (Event (ProfiledTimeline t) a) (Event (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
146+ dynamicCoercion (c :: Coercion a b) = case dynamicCoercion c :: Coercion (Dynamic t a) (Dynamic t b) of
147+ Coercion -> unsafeCoerce (Coercion :: Coercion (Dynamic (ProfiledTimeline t) a) (Dynamic (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
148+ mergeIntIncremental = Event_Profiled . mergeIntIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchIntMap (Event (ProfiledTimeline t) a)) -> Incremental t (PatchIntMap (Event t a)))
149+ fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e
150+
151+deriving instance Functor (Dynamic t) => Functor (Dynamic (ProfiledTimeline t))
152+deriving instance Applicative (Dynamic t) => Applicative (Dynamic (ProfiledTimeline t))
153+deriving instance Monad (Dynamic t) => Monad (Dynamic (ProfiledTimeline t))
154+
155+instance MonadHold t m => MonadHold (ProfiledTimeline t) (ProfiledM m) where
156+ hold v0 (Event_Profiled v') = ProfiledM $ Behavior_Profiled <$> hold v0 v'
157+ holdDyn v0 (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> holdDyn v0 v'
158+ holdIncremental v0 (Event_Profiled v') = ProfiledM $ Incremental_Profiled <$> holdIncremental v0 v'
159+ buildDynamic (ProfiledM v0) (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> buildDynamic v0 v'
160+ headE (Event_Profiled e) = ProfiledM $ Event_Profiled <$> headE e
161+
162+instance MonadSample t m => MonadSample (ProfiledTimeline t) (ProfiledM m) where
163+ sample (Behavior_Profiled b) = ProfiledM $ sample b
164+
165+instance MonadTrans ProfiledM where
166+ lift = ProfiledM
167+
168+instance MonadIO m => MonadIO (ProfiledM m) where
169+ liftIO = lift . liftIO
170+
171+instance PerformEvent t m => PerformEvent (ProfiledTimeline t) (ProfiledM m) where
172+ type Performable (ProfiledM m) = Performable m
173+ performEvent_ = lift . performEvent_ . coerce
174+ performEvent = lift . fmap coerce . performEvent . coerce
175+
176+instance MonadRef m => MonadRef (ProfiledM m) where
177+ type Ref (ProfiledM m) = Ref m
178+ newRef = lift . newRef
179+ readRef = lift . readRef
180+ writeRef r = lift . writeRef r
181+
182+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger (ProfiledTimeline t) (ProfiledM m) where
183+ newEventWithTrigger = lift . fmap coerce . newEventWithTrigger
184+ newFanEventWithTrigger f = do
185+ es <- lift $ newFanEventWithTrigger f
186+ return $ EventSelector $ \k -> coerce $ select es k
187+
188+instance MonadReader r m => MonadReader r (ProfiledM m) where
189+ ask = lift ask
190+ local f (ProfiledM a) = ProfiledM $ local f a
191+ reader = lift . reader
192+
193+instance ReflexHost t => ReflexHost (ProfiledTimeline t) where
194+ type EventTrigger (ProfiledTimeline t) = EventTrigger t
195+ type EventHandle (ProfiledTimeline t) = EventHandle t
196+ type HostFrame (ProfiledTimeline t) = ProfiledM (HostFrame t)
197+
198+instance MonadSubscribeEvent t m => MonadSubscribeEvent (ProfiledTimeline t) (ProfiledM m) where
199+ subscribeEvent = lift . subscribeEvent . coerce
200+
201+instance PrimMonad m => PrimMonad (ProfiledM m) where
202+ type PrimState (ProfiledM m) = PrimState m
203+ primitive = lift . primitive
204+
205+instance MonadReflexHost t m => MonadReflexHost (ProfiledTimeline t) (ProfiledM m) where
206+ type ReadPhase (ProfiledM m) = ProfiledM (ReadPhase m)
207+ fireEventsAndRead ts r = lift $ fireEventsAndRead ts $ coerce r
208+ runHostFrame = lift . runHostFrame . coerce
209+
210+instance MonadReadEvent t m => MonadReadEvent (ProfiledTimeline t) (ProfiledM m) where
211+ readEvent = lift . fmap coerce . readEvent
src/Reflex/Pure.hsnew file+206
@@ -0,0 +1,206 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE EmptyDataDecls #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE InstanceSigs #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE TypeFamilies #-}
8+#ifdef USE_REFLEX_OPTIMIZER
9+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
10+#endif
11+
12+-- There are two expected orphan instances in this module:
13+-- * MonadSample (Pure t) ((->) t)
14+-- * MonadHold (Pure t) ((->) t)
15+{-# OPTIONS_GHC -fno-warn-orphans #-}
16+
17+-- | This module provides a pure implementation of Reflex, which is intended to
18+-- serve as a reference for the semantics of the Reflex class. All
19+-- implementations of Reflex should produce the same results as this
20+-- implementation, although performance and laziness/strictness may differ.
21+module Reflex.Pure
22+ ( Pure
23+ , Behavior (..)
24+ , Event (..)
25+ , Dynamic (..)
26+ , Incremental (..)
27+ ) where
28+
29+#if !MIN_VERSION_base(4,8,0)
30+import Control.Applicative
31+#endif
32+
33+import Control.Monad
34+import Data.Dependent.Map (DMap, GCompare)
35+import qualified Data.Dependent.Map as DMap
36+import Data.Functor.Identity
37+import Data.IntMap (IntMap)
38+import qualified Data.IntMap as IntMap
39+import Data.Maybe
40+import Data.MemoTrie
41+import Data.Monoid
42+import Data.Type.Coercion
43+import Reflex.Class
44+
45+-- | A completely pure-functional 'Reflex' timeline, identifying moments in time
46+-- with the type @t@.
47+data Pure t
48+
49+-- | The Enum instance of t must be dense: for all x :: t, there must not exist
50+-- any y :: t such that pred x < y < x. The HasTrie instance will be used
51+-- exclusively to memoize functions of t, not for any of its other capabilities.
52+instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
53+
54+ newtype Behavior (Pure t) a = Behavior { unBehavior :: t -> a }
55+ newtype Event (Pure t) a = Event { unEvent :: t -> Maybe a }
56+ newtype Dynamic (Pure t) a = Dynamic { unDynamic :: t -> (a, Maybe a) }
57+ newtype Incremental (Pure t) p = Incremental { unIncremental :: t -> (PatchTarget p, Maybe p) }
58+
59+ type PushM (Pure t) = (->) t
60+ type PullM (Pure t) = (->) t
61+
62+ never :: Event (Pure t) a
63+ never = Event $ \_ -> Nothing
64+
65+ constant :: a -> Behavior (Pure t) a
66+ constant x = Behavior $ \_ -> x
67+
68+ push :: (a -> PushM (Pure t) (Maybe b)) -> Event (Pure t) a -> Event (Pure t) b
69+ push f e = Event $ memo $ \t -> unEvent e t >>= \o -> f o t
70+
71+ pushCheap :: (a -> PushM (Pure t) (Maybe b)) -> Event (Pure t) a -> Event (Pure t) b
72+ pushCheap = push
73+
74+ pull :: PullM (Pure t) a -> Behavior (Pure t) a
75+ pull = Behavior . memo
76+
77+ -- [UNUSED_CONSTRAINT]: The following type signature for merge will produce a
78+ -- warning because the GCompare instance is not used; however, removing the
79+ -- GCompare instance produces a different warning, due to that constraint
80+ -- being present in the original class definition
81+
82+ --merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity)
83+ merge events = Event $ memo $ \t ->
84+ let currentOccurrences = DMap.mapMaybeWithKey (\_ (Event a) -> Identity <$> a t) events
85+ in if DMap.null currentOccurrences
86+ then Nothing
87+ else Just currentOccurrences
88+
89+ fan :: GCompare k => Event (Pure t) (DMap k Identity) -> EventSelector (Pure t) k
90+ fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= fmap runIdentity . DMap.lookup k
91+
92+ switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a
93+ switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t
94+
95+ coincidence :: Event (Pure t) (Event (Pure t) a) -> Event (Pure t) a
96+ coincidence e = Event $ memo $ \t -> unEvent e t >>= \o -> unEvent o t
97+
98+ current :: Dynamic (Pure t) a -> Behavior (Pure t) a
99+ current d = Behavior $ \t -> fst $ unDynamic d t
100+
101+ updated :: Dynamic (Pure t) a -> Event (Pure t) a
102+ updated d = Event $ \t -> snd $ unDynamic d t
103+
104+ unsafeBuildDynamic :: PullM (Pure t) a -> Event (Pure t) a -> Dynamic (Pure t) a
105+ unsafeBuildDynamic readV0 v' = Dynamic $ \t -> (readV0 t, unEvent v' t)
106+
107+ -- See UNUSED_CONSTRAINT, above.
108+
109+ --unsafeBuildIncremental :: Patch p => PullM (Pure t) a -> Event (Pure t) (p
110+ --a) -> Incremental (Pure t) p a
111+ unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t)
112+
113+ mergeIncremental = mergeIncrementalImpl
114+ mergeIncrementalWithMove = mergeIncrementalImpl
115+
116+ currentIncremental i = Behavior $ \t -> fst $ unIncremental i t
117+
118+ updatedIncremental i = Event $ \t -> snd $ unIncremental i t
119+
120+ incrementalToDynamic i = Dynamic $ \t ->
121+ let (old, mPatch) = unIncremental i t
122+ e = case mPatch of
123+ Nothing -> Nothing
124+ Just patch -> apply patch old
125+ in (old, e)
126+ behaviorCoercion Coercion = Coercion
127+ eventCoercion Coercion = Coercion
128+ dynamicCoercion Coercion = Coercion
129+
130+ fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k
131+
132+ mergeIntIncremental = mergeIntIncrementalImpl
133+
134+mergeIncrementalImpl :: (PatchTarget p ~ DMap k (Event (Pure t)), GCompare k) => Incremental (Pure t) p -> Event (Pure t) (DMap k Identity)
135+mergeIncrementalImpl i = Event $ \t ->
136+ let results = DMap.mapMaybeWithKey (\_ (Event e) -> Identity <$> e t) $ fst $ unIncremental i t
137+ in if DMap.null results
138+ then Nothing
139+ else Just results
140+
141+mergeIntIncrementalImpl :: (PatchTarget p ~ IntMap (Event (Pure t) a)) => Incremental (Pure t) p -> Event (Pure t) (IntMap a)
142+mergeIntIncrementalImpl i = Event $ \t ->
143+ let results = IntMap.mapMaybeWithKey (\_ (Event e) -> e t) $ fst $ unIncremental i t
144+ in if IntMap.null results
145+ then Nothing
146+ else Just results
147+
148+instance Functor (Dynamic (Pure t)) where
149+ fmap f d = Dynamic $ \t -> let (cur, upd) = unDynamic d t
150+ in (f cur, fmap f upd)
151+
152+instance Applicative (Dynamic (Pure t)) where
153+ pure a = Dynamic $ \_ -> (a, Nothing)
154+ (<*>) = ap
155+
156+instance Monad (Dynamic (Pure t)) where
157+ return = pure
158+ (x :: Dynamic (Pure t) a) >>= (f :: a -> Dynamic (Pure t) b) = Dynamic $ \t ->
159+ let (curX :: a, updX :: Maybe a) = unDynamic x t
160+ (cur :: b, updOuter :: Maybe b) = unDynamic (f curX) t
161+ (updInner :: Maybe b, updBoth :: Maybe b) = case updX of
162+ Nothing -> (Nothing, Nothing)
163+ Just nextX -> let (c, u) = unDynamic (f nextX) t
164+ in (Just c, u)
165+ in (cur, getFirst $ mconcat $ map First [updBoth, updOuter, updInner])
166+
167+instance MonadSample (Pure t) ((->) t) where
168+
169+ sample :: Behavior (Pure t) a -> (t -> a)
170+ sample = unBehavior
171+
172+instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where
173+
174+ hold :: a -> Event (Pure t) a -> t -> Behavior (Pure t) a
175+ hold initialValue e initialTime = Behavior f
176+ where f = memo $ \sampleTime ->
177+ -- Really, the sampleTime should never be prior to the initialTime,
178+ -- because that would mean the Behavior is being sampled before
179+ -- being created.
180+ if sampleTime <= initialTime
181+ then initialValue
182+ else let lastTime = pred sampleTime
183+ in fromMaybe (f lastTime) $ unEvent e lastTime
184+
185+ holdDyn v0 = buildDynamic (return v0)
186+
187+ buildDynamic :: (t -> a) -> Event (Pure t) a -> t -> Dynamic (Pure t) a
188+ buildDynamic initialValue e initialTime =
189+ let Behavior f = hold (initialValue initialTime) e initialTime
190+ in Dynamic $ \t -> (f t, unEvent e t)
191+
192+ holdIncremental :: Patch p => PatchTarget p -> Event (Pure t) p -> t -> Incremental (Pure t) p
193+ holdIncremental initialValue e initialTime = Incremental $ \t -> (f t, unEvent e t)
194+ where f = memo $ \sampleTime ->
195+ -- Really, the sampleTime should never be prior to the initialTime,
196+ -- because that would mean the Behavior is being sampled before
197+ -- being created.
198+ if sampleTime <= initialTime
199+ then initialValue
200+ else let lastTime = pred sampleTime
201+ lastValue = f lastTime
202+ in case unEvent e lastTime of
203+ Nothing -> lastValue
204+ Just x -> fromMaybe lastValue $ apply x lastValue
205+
206+ headE = slowHeadE
src/Reflex/Query/Base.hsnew file+287
@@ -0,0 +1,287 @@
1+{-# LANGUAGE FlexibleInstances #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE InstanceSigs #-}
4+{-# LANGUAGE KindSignatures #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE RankNTypes #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeFamilies #-}
9+{-# LANGUAGE UndecidableInstances #-}
10+module Reflex.Query.Base
11+ ( QueryT (..)
12+ , runQueryT
13+ , mapQuery
14+ , mapQueryResult
15+ , dynWithQueryT
16+ , withQueryT
17+ ) where
18+
19+import Control.Applicative (liftA2)
20+import Control.Monad.Exception
21+import Control.Monad.Fix
22+import Control.Monad.Reader
23+import Control.Monad.Ref
24+import Control.Monad.State.Strict
25+import Data.Align
26+import Data.Dependent.Map (DMap, DSum (..))
27+import qualified Data.Dependent.Map as DMap
28+import Data.Foldable
29+import Data.Functor.Compose
30+import Data.Functor.Misc
31+import Data.Map (Map)
32+import qualified Data.Map as Map
33+import Data.Monoid ((<>))
34+import qualified Data.Semigroup as S
35+import Data.Some (Some)
36+import qualified Data.Some as Some
37+import Data.These
38+
39+import Reflex.Class
40+import Reflex.EventWriter.Base
41+import Reflex.EventWriter.Class
42+import Reflex.Host.Class
43+import qualified Reflex.Patch.MapWithMove as MapWithMove
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+newtype QueryT t q m a = QueryT { unQueryT :: StateT [Behavior t q] (EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m)) a }
51+ deriving (Functor, Applicative, Monad, MonadException, MonadFix, MonadIO, MonadHold t, MonadSample t, MonadAtomicRef)
52+
53+runQueryT :: (MonadFix m, Additive q, Group q, Reflex t) => QueryT t q m a -> Dynamic t (QueryResult q) -> m (a, Incremental t (AdditivePatch q))
54+runQueryT (QueryT a) qr = do
55+ ((r, bs), es) <- runReaderT (runEventWriterT (runStateT a mempty)) qr
56+ return (r, unsafeBuildIncremental (foldlM (\b c -> (b <>) <$> sample c) mempty bs) (fmapCheap AdditivePatch es))
57+
58+newtype QueryTLoweredResult t q v = QueryTLoweredResult (v, [Behavior t q])
59+
60+getQueryTLoweredResultValue :: QueryTLoweredResult t q v -> v
61+getQueryTLoweredResultValue (QueryTLoweredResult (v, _)) = v
62+
63+getQueryTLoweredResultWritten :: QueryTLoweredResult t q v -> [Behavior t q]
64+getQueryTLoweredResultWritten (QueryTLoweredResult (_, w)) = w
65+
66+{-
67+let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
68+ sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
69+ bs' = fmapCheap snd $ r'
70+ patches = unsafeBuildIncremental (sampleBs bs0) $
71+ flip pushCheap bs' $ \bs -> do
72+ p <- (~~) <$> sampleBs bs <*> sample (currentIncremental patches)
73+ return (Just (AdditivePatch p))
74+-}
75+
76+instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Adjustable t m) => Adjustable t (QueryT t q m) where
77+ runWithReplace (QueryT a0) a' = do
78+ ((r0, bs0), r') <- QueryT $ lift $ runWithReplace (runStateT a0 []) $ fmapCheap (flip runStateT [] . unQueryT) a'
79+ let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
80+ sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
81+ bs' = fmapCheap snd $ r'
82+ bbs <- hold bs0 bs'
83+ let patches = flip pushAlwaysCheap bs' $ \newBs -> do
84+ oldBs <- sample bbs
85+ (~~) <$> sampleBs newBs <*> sampleBs oldBs
86+ QueryT $ modify $ (:) $ pull $ sampleBs =<< sample bbs
87+ QueryT $ lift $ tellEvent patches
88+ return (r0, fmapCheap fst r')
89+ 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'))
90+ traverseDMapWithKeyWithAdjust f dm0 dm' = do
91+ let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
92+ f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
93+ (result0, result') <- QueryT $ lift $ traverseDMapWithKeyWithAdjust f' dm0 dm'
94+ let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0
95+ liftedResult' = fforCheap result' $ \(PatchDMap p) -> PatchDMap $
96+ mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mr) -> k :=> ComposeMaybe (fmap (getQueryTLoweredResultValue . getCompose) mr)) p
97+ liftedBs0 :: Map (Some k) [Behavior t q]
98+ liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0
99+ liftedBs' :: Event t (PatchMap (Some k) [Behavior t q])
100+ liftedBs' = fforCheap result' $ \(PatchDMap p) -> PatchMap $
101+ Map.fromDistinctAscList $ (\(k :=> ComposeMaybe mr) -> (Some.This k, fmap (getQueryTLoweredResultWritten . getCompose) mr)) <$> DMap.toList p
102+ sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
103+ sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
104+ accumBehaviors :: forall m'. MonadHold t m'
105+ => Map (Some k) [Behavior t q]
106+ -> PatchMap (Some k) [Behavior t q]
107+ -> m' ( Maybe (Map (Some k) [Behavior t q])
108+ , Maybe (AdditivePatch q))
109+ -- f accumulates the child behavior state we receive from running traverseDMapWithKeyWithAdjust for the underlying monad.
110+ -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.
111+ -- bs0 is a Map denoting the behaviors of the current children.
112+ -- pbs is a PatchMap denoting an update to the behaviors of the current children
113+ accumBehaviors bs0 pbs@(PatchMap bs') = do
114+ let p k bs = case Map.lookup k bs0 of
115+ Nothing -> case bs of
116+ -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
117+ Nothing -> return mempty
118+ -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.
119+ Just newBs -> sampleBs newBs
120+ Just oldBs -> case bs of
121+ -- 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
122+ Nothing -> negateG <$> sampleBs oldBs
123+ -- 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
124+ -- composed with the sampling the child's new state.
125+ Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
126+ -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
127+ -- child patches and wrap them in AdditivePatch.
128+ patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'
129+ return (apply pbs bs0, Just patch)
130+ (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'
131+ tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
132+ return (liftedResult0, liftedResult')
133+ 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'))
134+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do
135+ let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
136+ f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
137+ (result0, result') <- QueryT $ lift $ traverseDMapWithKeyWithAdjustWithMove f' dm0 dm'
138+ let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0
139+ liftedResult' = fforCheap result' $ mapPatchDMapWithMove (getQueryTLoweredResultValue . getCompose)
140+ liftedBs0 :: Map (Some k) [Behavior t q]
141+ liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0
142+ liftedBs' :: Event t (PatchMapWithMove (Some k) [Behavior t q])
143+ liftedBs' = fforCheap result' $ weakenPatchDMapWithMoveWith (getQueryTLoweredResultWritten . getCompose) {- \(PatchDMap p) -> PatchMapWithMove $
144+ Map.fromDistinctAscList $ (\(k :=> mr) -> (Some.This k, fmap (fmap (getQueryTLoweredResultWritten . getCompose)) mr)) <$> DMap.toList p -}
145+ sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
146+ sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
147+ accumBehaviors' :: forall m'. MonadHold t m'
148+ => Map (Some k) [Behavior t q]
149+ -> PatchMapWithMove (Some k) [Behavior t q]
150+ -> m' ( Maybe (Map (Some k) [Behavior t q])
151+ , Maybe (AdditivePatch q))
152+ -- f accumulates the child behavior state we receive from running traverseDMapWithKeyWithAdjustWithMove for the underlying monad.
153+ -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.
154+ -- bs0 is a Map denoting the behaviors of the current children.
155+ -- pbs is a PatchMapWithMove denoting an update to the behaviors of the current children
156+ accumBehaviors' bs0 pbs = do
157+ let bs' = unPatchMapWithMove pbs
158+ p k bs = case Map.lookup k bs0 of
159+ Nothing -> case MapWithMove._nodeInfo_from bs of
160+ -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
161+ MapWithMove.From_Delete -> return mempty
162+ -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.
163+ MapWithMove.From_Insert newBs -> sampleBs newBs
164+ MapWithMove.From_Move k' -> case Map.lookup k' bs0 of
165+ Nothing -> return mempty
166+ Just newBs -> sampleBs newBs
167+ Just oldBs -> case MapWithMove._nodeInfo_from bs of
168+ -- 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
169+ MapWithMove.From_Delete -> negateG <$> sampleBs oldBs
170+ -- 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
171+ -- composed with the sampling the child's new state.
172+ MapWithMove.From_Insert newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
173+ MapWithMove.From_Move k'
174+ | k' == k -> return mempty
175+ | otherwise -> case Map.lookup k' bs0 of
176+ -- If we are moving from a non-existent key, that is a delete
177+ Nothing -> negateG <$> sampleBs oldBs
178+ Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
179+ -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
180+ -- child patches and wrap them in AdditivePatch.
181+ patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'
182+ return (apply pbs bs0, Just patch)
183+ (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors' liftedBs0 liftedBs'
184+ tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
185+ return (liftedResult0, liftedResult')
186+
187+instance MonadTrans (QueryT t q) where
188+ lift = QueryT . lift . lift . lift
189+
190+instance PostBuild t m => PostBuild t (QueryT t q m) where
191+ getPostBuild = lift getPostBuild
192+
193+instance (MonadAsyncException m) => MonadAsyncException (QueryT t q m) where
194+ mask f = QueryT $ mask $ \unMask -> unQueryT $ f $ QueryT . unMask . unQueryT
195+
196+instance TriggerEvent t m => TriggerEvent t (QueryT t q m) where
197+ newTriggerEvent = lift newTriggerEvent
198+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
199+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
200+
201+instance PerformEvent t m => PerformEvent t (QueryT t q m) where
202+ type Performable (QueryT t q m) = Performable m
203+ performEvent_ = lift . performEvent_
204+ performEvent = lift . performEvent
205+
206+instance MonadRef m => MonadRef (QueryT t q m) where
207+ type Ref (QueryT t q m) = Ref m
208+ newRef = QueryT . newRef
209+ readRef = QueryT . readRef
210+ writeRef r = QueryT . writeRef r
211+
212+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (QueryT t q m) where
213+ newEventWithTrigger = QueryT . newEventWithTrigger
214+ newFanEventWithTrigger a = QueryT . lift $ newFanEventWithTrigger a
215+
216+-- TODO: Monoid and Semigroup can likely be derived once StateT has them.
217+instance (Monoid a, Monad m) => Monoid (QueryT t q m a) where
218+ mempty = pure mempty
219+ mappend = (<>)
220+
221+instance (S.Semigroup a, Monad m) => S.Semigroup (QueryT t q m a) where
222+ (<>) = liftA2 (S.<>)
223+
224+
225+mapQuery :: QueryMorphism q q' -> q -> q'
226+mapQuery = _queryMorphism_mapQuery
227+
228+mapQueryResult :: QueryMorphism q q' -> QueryResult q' -> QueryResult q
229+mapQueryResult = _queryMorphism_mapQueryResult
230+
231+-- | withQueryT's QueryMorphism argument needs to be a group homomorphism in order to behave correctly
232+withQueryT :: (MonadFix m, PostBuild t m, Group q, Group q', Additive q, Additive q', Query q')
233+ => QueryMorphism q q'
234+ -> QueryT t q m a
235+ -> QueryT t q' m a
236+withQueryT f a = do
237+ r' <- askQueryResult
238+ (result, q) <- lift $ runQueryT a $ mapQueryResult f <$> r'
239+ tellQueryIncremental $ unsafeBuildIncremental
240+ (fmap (mapQuery f) (sample (currentIncremental q)))
241+ (fmapCheap (AdditivePatch . mapQuery f . unAdditivePatch) $ updatedIncremental q)
242+ return result
243+
244+-- | dynWithQueryT's (Dynamic t QueryMorphism) argument needs to be a group homomorphism at all times in order to behave correctly
245+dynWithQueryT :: (MonadFix m, PostBuild t m, Group q, Additive q, Group q', Additive q', Query q')
246+ => Dynamic t (QueryMorphism q q')
247+ -> QueryT t q m a
248+ -> QueryT t q' m a
249+dynWithQueryT f q = do
250+ r' <- askQueryResult
251+ (result, q') <- lift $ runQueryT q $ zipDynWith mapQueryResult f r'
252+ tellQueryIncremental $ zipDynIncrementalWith mapQuery f q'
253+ return result
254+ where zipDynIncrementalWith g da ib =
255+ let eab = align (updated da) (updatedIncremental ib)
256+ ec = flip push eab $ \o -> case o of
257+ This a -> do
258+ aOld <- sample $ current da
259+ b <- sample $ currentIncremental ib
260+ return $ Just $ AdditivePatch (g a b ~~ g aOld b)
261+ That (AdditivePatch b) -> do
262+ a <- sample $ current da
263+ return $ Just $ AdditivePatch $ g a b
264+ These a (AdditivePatch b) -> do
265+ aOld <- sample $ current da
266+ bOld <- sample $ currentIncremental ib
267+ return $ Just $ AdditivePatch $ mconcat [ g a bOld, negateG (g aOld bOld), g a b]
268+ in unsafeBuildIncremental (g <$> sample (current da) <*> sample (currentIncremental ib)) ec
269+
270+instance (Monad m, Group q, Additive q, Query q, Reflex t) => MonadQuery t q (QueryT t q m) where
271+ tellQueryIncremental q = do
272+ QueryT (modify (currentIncremental q:))
273+ QueryT (lift (tellEvent (fmapCheap unAdditivePatch (updatedIncremental q))))
274+ askQueryResult = QueryT ask
275+ queryIncremental q = do
276+ tellQueryIncremental q
277+ r <- askQueryResult
278+ return $ zipDynWith crop (incrementalToDynamic q) r
279+
280+instance Requester t m => Requester t (QueryT t q m) where
281+ type Request (QueryT t q m) = Request m
282+ type Response (QueryT t q m) = Response m
283+ requesting = lift . requesting
284+ requesting_ = lift . requesting_
285+
286+instance EventWriter t w m => EventWriter t w (QueryT t q m) where
287+ tellEvent = lift . tellEvent
src/Reflex/Query/Class.hsnew file+77
@@ -0,0 +1,77 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE TypeFamilies #-}
8+{-# LANGUAGE UndecidableInstances #-}
9+module Reflex.Query.Class
10+ ( Query (..)
11+ , QueryMorphism (..)
12+ , SelectedCount (..)
13+ , combineSelectedCounts
14+
15+ , MonadQuery (..)
16+ , tellQueryDyn
17+ , queryDyn
18+ ) where
19+
20+import Control.Monad.Reader
21+import Data.Bits
22+import Data.Data
23+import Data.Ix
24+import Data.Semigroup
25+import Foreign.Storable
26+
27+import Reflex.Class
28+
29+class (Monoid (QueryResult a), Semigroup (QueryResult a)) => Query a where
30+ type QueryResult a :: *
31+ crop :: a -> QueryResult a -> QueryResult a
32+
33+-- | NB: QueryMorphism's must be group homomorphisms when acting on the query type
34+-- and compatible with the query relationship when acting on the query result
35+data QueryMorphism q q' = QueryMorphism
36+ { _queryMorphism_mapQuery :: q -> q'
37+ , _queryMorphism_mapQueryResult :: QueryResult q' -> QueryResult q
38+ }
39+
40+-- | This type keeps track of the multiplicity of elements of the view selector that are being used by the app
41+newtype SelectedCount = SelectedCount { unSelectedCount :: Int }
42+ deriving (Eq, Ord, Show, Read, Integral, Num, Bounded, Enum, Real, Ix, Bits, FiniteBits, Storable, Data)
43+
44+instance Semigroup SelectedCount where
45+ SelectedCount a <> SelectedCount b = SelectedCount (a + b)
46+
47+instance Monoid SelectedCount where
48+ mempty = SelectedCount 0
49+ mappend = (<>)
50+
51+instance Group SelectedCount where
52+ negateG (SelectedCount a) = SelectedCount (negate a)
53+
54+instance Additive SelectedCount
55+
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.
57+combineSelectedCounts :: SelectedCount -> SelectedCount -> Maybe SelectedCount
58+combineSelectedCounts (SelectedCount i) (SelectedCount j) = if i == negate j then Nothing else Just $ SelectedCount (i + j)
59+
60+class (Group q, Additive q, Query q) => MonadQuery t q m | m -> q t where
61+ tellQueryIncremental :: Incremental t (AdditivePatch q) -> m ()
62+ askQueryResult :: m (Dynamic t (QueryResult q))
63+ queryIncremental :: Incremental t (AdditivePatch q) -> m (Dynamic t (QueryResult q))
64+
65+instance (Monad m, MonadQuery t q m) => MonadQuery t q (ReaderT r m) where
66+ tellQueryIncremental = lift . tellQueryIncremental
67+ askQueryResult = lift askQueryResult
68+ queryIncremental = lift . queryIncremental
69+
70+tellQueryDyn :: (Reflex t, MonadQuery t q m) => Dynamic t q -> m ()
71+tellQueryDyn d = tellQueryIncremental $ unsafeBuildIncremental (sample (current d)) $ attachWith (\old new -> AdditivePatch $ new ~~ old) (current d) (updated d)
72+
73+queryDyn :: (Reflex t, Monad m, MonadQuery t q m) => Dynamic t q -> m (Dynamic t (QueryResult q))
74+queryDyn q = do
75+ tellQueryDyn q
76+ r <- askQueryResult
77+ return $ zipDynWith crop q r
src/Reflex/Requester/Base.hsnew file+428
@@ -0,0 +1,428 @@
1+-- | This module provides 'RequesterT', the standard implementation of
2+-- 'Requester'.
3+{-# LANGUAGE AllowAmbiguousTypes #-}
4+{-# LANGUAGE CPP #-}
5+{-# LANGUAGE EmptyDataDecls #-}
6+{-# LANGUAGE ExistentialQuantification #-}
7+{-# LANGUAGE FlexibleInstances #-}
8+{-# LANGUAGE GADTs #-}
9+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10+{-# LANGUAGE MultiParamTypeClasses #-}
11+{-# LANGUAGE Rank2Types #-}
12+{-# LANGUAGE RecursiveDo #-}
13+{-# LANGUAGE ScopedTypeVariables #-}
14+{-# LANGUAGE StandaloneDeriving #-}
15+{-# LANGUAGE TypeFamilies #-}
16+{-# LANGUAGE TypeOperators #-}
17+{-# LANGUAGE UndecidableInstances #-}
18+#ifdef USE_REFLEX_OPTIMIZER
19+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
20+#endif
21+module Reflex.Requester.Base
22+ ( RequesterT (..)
23+ , runRequesterT
24+ , runWithReplaceRequesterTWith
25+ , traverseIntMapWithKeyWithAdjustRequesterTWith
26+ , traverseDMapWithKeyWithAdjustRequesterTWith
27+ , RequesterData
28+ , RequesterDataKey
29+ , traverseRequesterData
30+ , requesterDataToList
31+ , singletonRequesterData
32+ ) where
33+
34+import Reflex.Class
35+import Reflex.Dynamic
36+import Reflex.Host.Class
37+import Reflex.PerformEvent.Class
38+import Reflex.PostBuild.Class
39+import Reflex.Requester.Class
40+import Reflex.TriggerEvent.Class
41+
42+import Control.Applicative (liftA2)
43+import Control.Monad.Exception
44+import Control.Monad.Identity
45+import Control.Monad.Reader
46+import Control.Monad.Ref
47+import Control.Monad.State.Strict
48+import Data.Bits
49+import Data.Coerce
50+import Data.Dependent.Map (DMap, DSum (..))
51+import qualified Data.Dependent.Map as DMap
52+import Data.Functor.Compose
53+import Data.Functor.Misc
54+import Data.IntMap.Strict (IntMap)
55+import qualified Data.IntMap.Strict as IntMap
56+import Data.Map (Map)
57+import qualified Data.Map as Map
58+import Data.Monoid ((<>))
59+import Data.Proxy
60+import qualified Data.Semigroup as S
61+import Data.Some (Some)
62+import qualified Data.Some as Some
63+import Data.Type.Equality
64+import Data.Unique.Tag
65+
66+import GHC.Exts (Any)
67+import Unsafe.Coerce
68+
69+--TODO: Make this module type-safe
70+
71+newtype TagMap (f :: * -> *) = TagMap (IntMap Any)
72+
73+newtype RequesterData f = RequesterData (TagMap (Entry f))
74+
75+data RequesterDataKey a where
76+ RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a
77+ 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
78+ RequesterDataKey_Multi2 :: {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
79+ RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
80+
81+singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f
82+singletonRequesterData rdk v = case rdk of
83+ RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v
84+ RequesterDataKey_Multi k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v
85+ RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
86+ RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
87+
88+requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]
89+requesterDataToList (RequesterData m) = do
90+ k :=> Entry e <- tagMapToList m
91+ case myKeyType k of
92+ MyTagType_Single -> return $ RequesterDataKey_Single k :=> e
93+ MyTagType_Multi -> do
94+ (k', e') <- IntMap.toList e
95+ k'' :=> e'' <- requesterDataToList e'
96+ return $ RequesterDataKey_Multi k k' k'' :=> e''
97+ MyTagType_Multi2 -> do
98+ (k', e') <- Map.toList e
99+ (k'', e'') <- IntMap.toList e'
100+ k''' :=> e''' <- requesterDataToList e''
101+ return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''
102+ MyTagType_Multi3 -> do
103+ (k', e') <- IntMap.toList e
104+ (k'', e'') <- IntMap.toList e'
105+ k''' :=> e''' <- requesterDataToList e''
106+ return $ RequesterDataKey_Multi3 k k' k'' k''' :=> e'''
107+
108+singletonTagMap :: forall f a. MyTag a -> f a -> TagMap f
109+singletonTagMap (MyTag k) v = TagMap $ IntMap.singleton k $ (unsafeCoerce :: f a -> Any) v
110+
111+tagMapToList :: forall f. TagMap f -> [DSum MyTag f]
112+tagMapToList (TagMap m) = f <$> IntMap.toList m
113+ where f :: (Int, Any) -> DSum MyTag f
114+ f (k, v) = MyTag k :=> (unsafeCoerce :: Any -> f a) v
115+
116+traverseTagMapWithKey :: forall t f g. Applicative t => (forall a. MyTag a -> f a -> t (g a)) -> TagMap f -> t (TagMap g)
117+traverseTagMapWithKey f (TagMap m) = TagMap <$> IntMap.traverseWithKey g m
118+ where
119+ g :: Int -> Any -> t Any
120+ g k v = (unsafeCoerce :: g a -> Any) <$> f (MyTag k) ((unsafeCoerce :: Any -> f a) v)
121+
122+-- | Runs in reverse to accommodate for the fact that we accumulate it in reverse
123+traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequesterData request -> m (RequesterData response)
124+traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWithKey go m --TODO: reverse this, since our tags are in reverse order
125+ where go :: forall x. MyTag x -> Entry request x -> m (Entry response x)
126+ go k (Entry request) = Entry <$> case myKeyType k of
127+ MyTagType_Single -> f request
128+ MyTagType_Multi -> traverse (traverseRequesterData f) request
129+ MyTagType_Multi2 -> traverse (traverse (traverseRequesterData f)) request
130+ MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request
131+
132+data MyTagType :: * -> * where
133+ MyTagType_Single :: MyTagType (Single a)
134+ MyTagType_Multi :: MyTagType Multi
135+ MyTagType_Multi2 :: MyTagType (Multi2 k)
136+ MyTagType_Multi3 :: MyTagType Multi3
137+
138+myKeyType :: MyTag x -> MyTagType x
139+myKeyType (MyTag k) = case k .&. 0x3 of
140+ 0x0 -> unsafeCoerce MyTagType_Single
141+ 0x1 -> unsafeCoerce MyTagType_Multi
142+ 0x2 -> unsafeCoerce MyTagType_Multi2
143+ 0x3 -> unsafeCoerce MyTagType_Multi3
144+ t -> error $ "Reflex.Requester.Base.myKeyType: no such key type" <> show t
145+
146+data Single a
147+data Multi
148+data Multi2 (k :: * -> *)
149+data Multi3
150+
151+class MyTagTypeOffset x where
152+ myTagTypeOffset :: proxy x -> Int
153+
154+instance MyTagTypeOffset (Single a) where
155+ myTagTypeOffset _ = 0x0
156+
157+instance MyTagTypeOffset Multi where
158+ myTagTypeOffset _ = 0x1
159+
160+instance MyTagTypeOffset (Multi2 k) where
161+ myTagTypeOffset _ = 0x2
162+
163+instance MyTagTypeOffset Multi3 where
164+ myTagTypeOffset _ = 0x3
165+
166+type family EntryContents request a where
167+ EntryContents request (Single a) = request a
168+ EntryContents request Multi = IntMap (RequesterData request)
169+ EntryContents request (Multi2 k) = Map (Some k) (IntMap (RequesterData request))
170+ EntryContents request Multi3 = IntMap (IntMap (RequesterData request))
171+
172+newtype Entry request x = Entry { unEntry :: EntryContents request x }
173+
174+{-# INLINE singleEntry #-}
175+singleEntry :: f a -> Entry f (Single a)
176+singleEntry = Entry
177+
178+{-# INLINE multiEntry #-}
179+multiEntry :: IntMap (RequesterData f) -> Entry f Multi
180+multiEntry = Entry
181+
182+{-# INLINE unMultiEntry #-}
183+unMultiEntry :: Entry f Multi -> IntMap (RequesterData f)
184+unMultiEntry = unEntry
185+
186+-- | 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
187+-- 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
188+newtype MyTag x = MyTag Int deriving (Show, Eq, Ord, Enum)
189+
190+newtype MyTagWrap (f :: * -> *) x = MyTagWrap Int deriving (Show, Eq, Ord, Enum)
191+
192+{-# INLINE castMyTagWrap #-}
193+castMyTagWrap :: MyTagWrap f (Entry f x) -> MyTagWrap g (Entry g x)
194+castMyTagWrap = coerce
195+
196+instance GEq MyTag where
197+ (MyTag a) `geq` (MyTag b) =
198+ if a == b
199+ then Just $ unsafeCoerce Refl
200+ else Nothing
201+
202+instance GCompare MyTag where
203+ (MyTag a) `gcompare` (MyTag b) =
204+ case a `compare` b of
205+ LT -> GLT
206+ EQ -> unsafeCoerce GEQ
207+ GT -> GGT
208+
209+instance GEq (MyTagWrap f) where
210+ (MyTagWrap a) `geq` (MyTagWrap b) =
211+ if a == b
212+ then Just $ unsafeCoerce Refl
213+ else Nothing
214+
215+instance GCompare (MyTagWrap f) where
216+ (MyTagWrap a) `gcompare` (MyTagWrap b) =
217+ case a `compare` b of
218+ LT -> GLT
219+ EQ -> unsafeCoerce GEQ
220+ GT -> GGT
221+
222+data RequesterState t (request :: * -> *) = RequesterState
223+ { _requesterState_nextMyTag :: {-# UNPACK #-} !Int -- Starts at -4 and goes down by 4 each time, to accommodate two 'type' bits at the bottom
224+ , _requesterState_requests :: ![(Int, Event t Any)]
225+ }
226+
227+-- | A basic implementation of 'Requester'.
228+newtype RequesterT t request (response :: * -> *) m a = RequesterT { unRequesterT :: StateT (RequesterState t request) (ReaderT (EventSelectorInt t Any) m) a }
229+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException
230+-- MonadAsyncException can't be derived on ghc-8.0.1; we use base-4.9.1 as a proxy for ghc-8.0.2
231+#if MIN_VERSION_base(4,9,1)
232+ , MonadAsyncException
233+#endif
234+ )
235+
236+deriving instance MonadSample t m => MonadSample t (RequesterT t request response m)
237+deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)
238+deriving instance PostBuild t m => PostBuild t (RequesterT t request response m)
239+deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)
240+
241+-- TODO: Monoid and Semigroup can likely be derived once StateT has them.
242+instance (Monoid a, Monad m) => Monoid (RequesterT t request response m a) where
243+ mempty = pure mempty
244+ mappend = liftA2 mappend
245+
246+instance (S.Semigroup a, Monad m) => S.Semigroup (RequesterT t request response m a) where
247+ (<>) = liftA2 (S.<>)
248+
249+
250+-- | Run a 'RequesterT' action. The resulting 'Event' will fire whenever
251+-- requests are made, and responses should be provided in the input 'Event'.
252+-- The 'Tag' keys will be used to return the responses to the same place the
253+-- requests were issued.
254+
255+runRequesterT :: (Reflex t, Monad m)
256+ => RequesterT t request response m a
257+ -> Event t (RequesterData response) --TODO: This DMap will be in reverse order, so we need to make sure the caller traverses it in reverse
258+ -> m (a, Event t (RequesterData request)) --TODO: we need to hide these 'MyTag's here, because they're unsafe to mix in the wild
259+runRequesterT (RequesterT a) responses = do
260+ (result, s) <- runReaderT (runStateT a $ RequesterState (-4) []) $ fanInt $
261+ coerceEvent responses
262+ return (result, fmapCheap (RequesterData . TagMap) $ mergeInt $ IntMap.fromDistinctAscList $ _requesterState_requests s)
263+
264+instance (Reflex t, Monad m) => Requester t (RequesterT t request response m) where
265+ type Request (RequesterT t request response m) = request
266+ type Response (RequesterT t request response m) = response
267+ requesting = fmap coerceEvent . responseFromTag . castMyTagWrap <=< tagRequest . (coerceEvent :: Event t (request a) -> Event t (Entry request (Single a)))
268+ requesting_ = void . tagRequest . fmapCheap singleEntry
269+
270+{-# INLINE tagRequest #-}
271+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))
272+tagRequest req = do
273+ old <- RequesterT get
274+ let n = _requesterState_nextMyTag old .|. myTagTypeOffset (Proxy :: Proxy x)
275+ t = MyTagWrap n
276+ RequesterT $ put $ RequesterState
277+ { _requesterState_nextMyTag = _requesterState_nextMyTag old - 0x4
278+ , _requesterState_requests = (n, (unsafeCoerce :: Event t (Entry request x) -> Event t Any) req) : _requesterState_requests old
279+ }
280+ return t
281+
282+{-# INLINE responseFromTag #-}
283+responseFromTag :: (Monad m, Reflex t) => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))
284+responseFromTag (MyTagWrap t) = do
285+ responses :: EventSelectorInt t Any <- RequesterT ask
286+ return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t
287+
288+instance MonadTrans (RequesterT t request response) where
289+ lift = RequesterT . lift . lift
290+
291+instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where
292+ type Performable (RequesterT t request response m) = Performable m
293+ performEvent_ = lift . performEvent_
294+ performEvent = lift . performEvent
295+
296+instance MonadRef m => MonadRef (RequesterT t request response m) where
297+ type Ref (RequesterT t request response m) = Ref m
298+ newRef = lift . newRef
299+ readRef = lift . readRef
300+ writeRef r = lift . writeRef r
301+
302+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where
303+ newEventWithTrigger = lift . newEventWithTrigger
304+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
305+
306+instance MonadReader r m => MonadReader r (RequesterT t request response m) where
307+ ask = lift ask
308+ local f (RequesterT a) = RequesterT $ mapStateT (mapReaderT $ local f) a
309+ reader = lift . reader
310+
311+instance (Reflex t, Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (RequesterT t request response m) where
312+ runWithReplace = runWithReplaceRequesterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
313+ traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElementsMap mergeIntIncremental
314+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
315+ traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental
316+ traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove
317+
318+requesting' :: (MyTagTypeOffset x, Monad m, Reflex t) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x))
319+requesting' = responseFromTag . castMyTagWrap <=< tagRequest
320+
321+{-# INLINABLE runWithReplaceRequesterTWith #-}
322+runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m
323+ , MonadFix m
324+ )
325+ => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))
326+ -> RequesterT t request response m a
327+ -> Event t (RequesterT t request response m b)
328+ -> RequesterT t request response m (a, Event t b)
329+runWithReplaceRequesterTWith f a0 a' = do
330+ rec na' <- numberOccurrencesFrom 1 a'
331+ responses <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here
332+ let responses' = fanInt responses
333+ ((result0, requests0), v') <- f (runRequesterT a0 (selectInt responses' 0)) $ fmapCheap (\(n, a) -> fmap ((,) n) $ runRequesterT a $ selectInt responses' n) na'
334+ requests <- holdDyn (fmapCheap (IntMap.singleton 0) requests0) $ fmapCheap (\(n, (_, reqs)) -> fmapCheap (IntMap.singleton n) reqs) v'
335+ return (result0, fmapCheap (fst . snd) v')
336+
337+{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}
338+traverseIntMapWithKeyWithAdjustRequesterTWith :: forall t request response m v v' p.
339+ ( Reflex t
340+ , MonadHold t m
341+ , PatchTarget (p (Event t (IntMap (RequesterData request)))) ~ IntMap (Event t (IntMap (RequesterData request)))
342+ , Patch (p (Event t (IntMap (RequesterData request))))
343+ , Functor p
344+ , MonadFix m
345+ )
346+ => ( (IntMap.Key -> (IntMap.Key, v) -> m (Event t (IntMap (RequesterData request)), v'))
347+ -> IntMap (IntMap.Key, v)
348+ -> Event t (p (IntMap.Key, v))
349+ -> RequesterT t request response m (IntMap (Event t (IntMap (RequesterData request)), v'), Event t (p (Event t (IntMap (RequesterData request)), v')))
350+ )
351+ -> (p (Event t (IntMap (RequesterData request))) -> IntMap (Event t (IntMap (RequesterData request))))
352+ -> (Incremental t (p (Event t (IntMap (RequesterData request)))) -> Event t (IntMap (IntMap (RequesterData request))))
353+ -> (IntMap.Key -> v -> RequesterT t request response m v')
354+ -> IntMap v
355+ -> Event t (p v)
356+ -> RequesterT t request response m (IntMap v', Event t (p v'))
357+traverseIntMapWithKeyWithAdjustRequesterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do
358+ rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here
359+ let responses :: EventSelectorInt t (IntMap (RequesterData response))
360+ responses = fanInt $ fmapCheap unpack response
361+ unpack :: Entry response Multi3 -> IntMap (IntMap (RequesterData response))
362+ unpack = unEntry
363+ pack :: IntMap (IntMap (RequesterData request)) -> Entry request Multi3
364+ pack = Entry
365+ f' :: IntMap.Key -> (Int, v) -> m (Event t (IntMap (RequesterData request)), v')
366+ f' k (n, v) = do
367+ (result, myRequests) <- runRequesterT (f k v) $ fmapMaybeCheap (IntMap.lookup n) $ selectInt responses k --TODO: Instead of doing fmapMaybeCheap, can we share a fanInt across all instances of a given key, or at least the ones that are adjacent in time?
368+ return (fmapCheap (IntMap.singleton n) myRequests, result)
369+ ndm' <- numberOccurrencesFrom 1 dm'
370+ (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
371+ let result0 = fmap snd children0
372+ result' = fforCheap children' $ fmap snd
373+ requests0 :: IntMap (Event t (IntMap (RequesterData request)))
374+ requests0 = fmap fst children0
375+ requests' :: Event t (p (Event t (IntMap (RequesterData request))))
376+ requests' = fforCheap children' $ fmap fst
377+ promptRequests :: Event t (IntMap (IntMap (RequesterData request)))
378+ promptRequests = coincidence $ fmapCheap (mergeInt . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
379+ requests <- holdIncremental requests0 requests'
380+ return (result0, result')
381+
382+{-# INLINE traverseDMapWithKeyWithAdjustRequesterTWith #-}
383+traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v' p p'.
384+ ( GCompare k
385+ , Reflex t
386+ , MonadHold t m
387+ , PatchTarget (p' (Some k) (Event t (IntMap (RequesterData request)))) ~ Map (Some k) (Event t (IntMap (RequesterData request)))
388+ , Patch (p' (Some k) (Event t (IntMap (RequesterData request))))
389+ , MonadFix m
390+ )
391+ => (forall k' v1 v2. GCompare k'
392+ => (forall a. k' a -> v1 a -> m (v2 a))
393+ -> DMap k' v1
394+ -> Event t (p k' v1)
395+ -> RequesterT t request response m (DMap k' v2, Event t (p k' v2))
396+ )
397+ -> (forall v1 v2. (forall a. v1 a -> v2 a) -> p k v1 -> p k v2)
398+ -> (forall v1 v2. (forall a. v1 a -> v2) -> p k v1 -> p' (Some k) v2)
399+ -> (forall v2. p' (Some k) v2 -> Map (Some k) v2)
400+ -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a))
401+ -> (forall a. k a -> v a -> RequesterT t request response m (v' a))
402+ -> DMap k v
403+ -> Event t (p k v)
404+ -> RequesterT t request response m (DMap k v', Event t (p k v'))
405+traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do
406+ rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here
407+ let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))
408+ responses = fanMap $ fmapCheap unpack response
409+ unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))
410+ unpack = unEntry
411+ pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)
412+ pack = Entry
413+ f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)
414+ f' k (Compose (n, v)) = do
415+ (result, myRequests) <- runRequesterT (f k v) $ fmapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some.This k))
416+ return $ Compose (fmapCheap (IntMap.singleton n) myRequests, result)
417+ ndm' <- numberOccurrencesFrom 1 dm'
418+ (children0, children') <- base f' (DMap.map (\v -> Compose (0, v)) dm0) $ fmap (\(n, dm) -> mapPatch (\v -> Compose (n, v)) dm) ndm'
419+ let result0 = DMap.map (snd . getCompose) children0
420+ result' = fforCheap children' $ mapPatch $ snd . getCompose
421+ requests0 :: Map (Some k) (Event t (IntMap (RequesterData request)))
422+ requests0 = weakenDMapWith (fst . getCompose) children0
423+ requests' :: Event t (p' (Some k) (Event t (IntMap (RequesterData request))))
424+ requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose
425+ promptRequests :: Event t (Map (Some k) (IntMap (RequesterData request)))
426+ promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
427+ requests <- holdIncremental requests0 requests'
428+ return (result0, result')
src/Reflex/Requester/Class.hsnew file+73
@@ -0,0 +1,73 @@
1+-- | This module defines 'Requester', which indicates that an action can make
2+-- requests and receive responses to them. Typically, this is used for things
3+-- like a WebSocket, where it's desirable to collect many potential sources of
4+-- events and send them over a single channel, then distribute the results back
5+-- out efficiently to their original request sites.
6+{-# LANGUAGE CPP #-}
7+{-# LANGUAGE FlexibleInstances #-}
8+{-# LANGUAGE FunctionalDependencies #-}
9+{-# LANGUAGE MultiParamTypeClasses #-}
10+{-# LANGUAGE RecursiveDo #-}
11+{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE UndecidableInstances #-}
13+#ifdef USE_REFLEX_OPTIMIZER
14+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
15+#endif
16+module Reflex.Requester.Class
17+ ( Requester (..)
18+ , withRequesting
19+ , requestingIdentity
20+ ) where
21+
22+import Control.Monad.Identity
23+import Control.Monad.Reader
24+import qualified Control.Monad.State.Lazy as Lazy
25+import Control.Monad.State.Strict
26+import Reflex.Class
27+
28+-- | A 'Requester' action can trigger requests of type @Request m a@ based on
29+-- 'Event's, and receive responses of type @Response m a@ in return. Note that
30+-- the @a@ type can vary within the 'Requester' action, but will be linked for a
31+-- given request. For example, if @Request m@ is 'IO' and @Response m@ is
32+-- 'Identity', then 'requestingIdentity' has the same type as
33+-- 'Reflex.PerformEvent.Class.performEvent'.
34+class (Reflex t, Monad m) => Requester t m | m -> t where
35+ -- | The type of requests that this 'Requester' can emit
36+ type Request m :: * -> *
37+ -- | The type of responses that this 'Requester' can receive
38+ type Response m :: * -> *
39+ -- | Emit a request whenever the given 'Event' fires, and return responses in
40+ -- the resulting 'Event'.
41+ requesting :: Event t (Request m a) -> m (Event t (Response m a))
42+ -- | Emit a request whenever the given 'Event' fires, and ignore all responses.
43+ requesting_ :: Event t (Request m a) -> m ()
44+
45+
46+instance Requester t m => Requester t (ReaderT r m) where
47+ type Request (ReaderT r m) = Request m
48+ type Response (ReaderT r m) = Response m
49+ requesting = lift . requesting
50+ requesting_ = lift . requesting_
51+
52+instance Requester t m => Requester t (StateT s m) where
53+ type Request (StateT s m) = Request m
54+ type Response (StateT s m) = Response m
55+ requesting = lift . requesting
56+ requesting_ = lift . requesting_
57+
58+instance Requester t m => Requester t (Lazy.StateT s m) where
59+ type Request (Lazy.StateT s m) = Request m
60+ type Response (Lazy.StateT s m) = Response m
61+ requesting = lift . requesting
62+ requesting_ = lift . requesting_
63+
64+-- | Emit a request whenever the given 'Event' fires, and unwrap the responses
65+-- before returning them. @Response m@ must be 'Identity'.
66+requestingIdentity :: (Requester t m, Response m ~ Identity) => Event t (Request m a) -> m (Event t a)
67+requestingIdentity = fmap coerceEvent . requesting
68+
69+withRequesting :: (Requester t m, MonadFix m) => (Event t (Response m a) -> m (Event t (Request m a), r)) -> m r
70+withRequesting f = do
71+ rec response <- requesting request
72+ (request, result) <- f response
73+ return result
src/Reflex/Spider.hsnew file+17
@@ -0,0 +1,17 @@
1+{-# LANGUAGE CPP #-}
2+-- | This module exports all of the user-facing functionality of the 'Spider'
3+-- 'Reflex' engine
4+module Reflex.Spider
5+ ( Spider
6+ , SpiderTimeline
7+ , Global
8+ , SpiderHost
9+ , runSpiderHost
10+ , runSpiderHostForTimeline
11+ , newSpiderTimeline
12+ , withSpiderTimeline
13+ -- * Deprecated
14+ , SpiderEnv
15+ ) where
16+
17+import Reflex.Spider.Internal
src/Reflex/Spider/Internal.hsnew file+2630
@@ -0,0 +1,2630 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE ConstraintKinds #-}
4+{-# LANGUAGE EmptyDataDecls #-}
5+{-# LANGUAGE ExistentialQuantification #-}
6+{-# LANGUAGE FlexibleContexts #-}
7+{-# LANGUAGE FlexibleInstances #-}
8+{-# LANGUAGE FunctionalDependencies #-}
9+{-# LANGUAGE GADTs #-}
10+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
11+{-# LANGUAGE LambdaCase #-}
12+{-# LANGUAGE MagicHash #-}
13+{-# LANGUAGE MultiParamTypeClasses #-}
14+{-# LANGUAGE MultiWayIf #-}
15+{-# LANGUAGE RankNTypes #-}
16+{-# LANGUAGE RoleAnnotations #-}
17+{-# LANGUAGE ScopedTypeVariables #-}
18+{-# LANGUAGE TypeFamilies #-}
19+{-# LANGUAGE TypeOperators #-}
20+{-# LANGUAGE UndecidableInstances #-}
21+#ifdef USE_REFLEX_OPTIMIZER
22+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
23+#endif
24+-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
25+-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
26+module Reflex.Spider.Internal (module Reflex.Spider.Internal) where
27+
28+import Control.Applicative
29+import Control.Concurrent
30+import Control.Exception
31+import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)
32+import Control.Monad.Exception
33+import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence)
34+import Control.Monad.Primitive
35+import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_, sequence)
36+import Control.Monad.Ref
37+import Data.Align
38+import Data.Coerce
39+import Data.Dependent.Map (DMap, DSum (..))
40+import qualified Data.Dependent.Map as DMap
41+import Data.FastMutableIntMap (FastMutableIntMap, PatchIntMap (..))
42+import qualified Data.FastMutableIntMap as FastMutableIntMap
43+import Data.Foldable hiding (concat, elem, sequence_)
44+import Data.Function
45+import Data.Functor.Constant
46+import Data.Functor.Misc
47+import Data.Functor.Product
48+import Data.GADT.Compare
49+import Data.IntMap.Strict (IntMap)
50+import qualified Data.IntMap.Strict as IntMap
51+import Data.IORef
52+import Data.List hiding (foldl')
53+import Data.Maybe
54+import Data.Monoid ((<>))
55+import Data.Proxy
56+import Data.These
57+import Data.Traversable
58+import Data.Word
59+import GHC.Exts
60+import GHC.IORef (IORef (..))
61+import GHC.Stack
62+import Reflex.FastWeak
63+import Reflex.FunctorMaybe
64+import System.IO.Unsafe
65+import System.Mem.Weak
66+import Unsafe.Coerce
67+
68+#ifdef DEBUG_CYCLES
69+import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)
70+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
71+import qualified Data.List.NonEmpty as NonEmpty
72+import Data.Monoid (mempty)
73+import Data.Tree (Forest, Tree (..), drawForest)
74+#endif
75+
76+import Data.FastWeakBag (FastWeakBag)
77+import qualified Data.FastWeakBag as FastWeakBag
78+import Data.Reflection
79+import Data.Some (Some)
80+import qualified Data.Some as Some
81+import Data.Type.Coercion
82+import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)
83+import qualified Data.WeakBag as WeakBag
84+import qualified Reflex.Class
85+import qualified Reflex.Class as R
86+import qualified Reflex.Host.Class
87+import Reflex.NotReady.Class
88+import Reflex.Patch
89+import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
90+
91+-- Note: must come last to silence warnings due to AMP on GHC < 7.10
92+import Prelude hiding (any, concat, mapM, mapM_, sequence)
93+
94+#ifdef DEBUG_TRACE_EVENTS
95+import qualified Data.ByteString.Char8 as BS8
96+import System.IO (stderr)
97+#endif
98+
99+#ifdef DEBUG_TRACE_EVENTS
100+
101+withStackOneLine :: (BS8.ByteString -> a) -> a
102+withStackOneLine expr = unsafePerformIO $ do
103+ stack <- currentCallStack
104+ return (expr (BS8.pack (unwords (reverse stack))))
105+
106+#endif
107+
108+debugPropagate :: Bool
109+
110+debugInvalidateHeight :: Bool
111+
112+debugInvalidate :: Bool
113+
114+#ifdef DEBUG
115+
116+#define DEBUG_NODEIDS
117+
118+debugPropagate = True
119+
120+debugInvalidateHeight = False
121+
122+debugInvalidate = True
123+
124+class HasNodeId a where
125+ getNodeId :: a -> Int
126+
127+instance HasNodeId (Hold x p a) where
128+ getNodeId = holdNodeId
129+
130+instance HasNodeId (PushSubscribed x a b) where
131+ getNodeId = pushSubscribedNodeId
132+
133+instance HasNodeId (SwitchSubscribed x a) where
134+ getNodeId = switchSubscribedNodeId
135+
136+instance HasNodeId (FanSubscribed x a) where
137+ getNodeId = fanSubscribedNodeId
138+
139+instance HasNodeId (CoincidenceSubscribed x a) where
140+ getNodeId = coincidenceSubscribedNodeId
141+
142+instance HasNodeId (RootSubscribed x a) where
143+ getNodeId = rootSubscribedNodeId
144+
145+instance HasNodeId (Pull x a) where
146+ getNodeId = pullNodeId
147+
148+{-# INLINE showNodeId #-}
149+showNodeId :: HasNodeId a => a -> String
150+showNodeId = ("#"<>) . show . getNodeId
151+
152+showSubscriberType :: Subscriber x a -> String
153+showSubscriberType = \case
154+ SubscriberPush _ _ -> "SubscriberPush"
155+ SubscriberMerge _ _ -> "SubscriberMerge"
156+ SubscriberFan _ -> "SubscriberFan"
157+ SubscriberMergeChange _ -> "SubscriberMergeChange"
158+ SubscriberHold _ -> "SubscriberHold"
159+ SubscriberHoldIdentity _ -> "SubscriberHoldIdentity"
160+ SubscriberSwitch _ -> "SubscriberSwitch"
161+ SubscriberCoincidenceOuter _ -> "SubscriberCoincidenceOuter"
162+ SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"
163+ SubscriberHandle -> "SubscriberHandle"
164+
165+showEventType :: Event x a -> String
166+showEventType = \case
167+ EventRoot _ _ -> "EventRoot"
168+ EventNever -> "EventNever"
169+ EventPush _ -> "EventPush"
170+ EventMerge _ -> "EventMerge"
171+ EventFan _ _ -> "EventFan"
172+ EventSwitch _ -> "EventSwitch"
173+ EventCoincidence _ -> "EventCoincidence"
174+ EventHold _ -> "EventHold"
175+ EventDyn _ -> "EventDyn"
176+ EventHoldIdentity _ -> "EventHoldIdentity"
177+ EventDynIdentity _ -> "EventDynIdentity"
178+
179+#else
180+
181+debugPropagate = False
182+
183+debugInvalidateHeight = False
184+
185+debugInvalidate = False
186+
187+-- This must be inline, or error messages will cause memory leaks due to retaining the node in question
188+{-# INLINE showNodeId #-}
189+showNodeId :: a -> String
190+showNodeId _ = ""
191+
192+#endif
193+
194+#ifdef DEBUG_NODEIDS
195+{-# NOINLINE nextNodeIdRef #-}
196+nextNodeIdRef :: IORef Int
197+nextNodeIdRef = unsafePerformIO $ newIORef 1
198+
199+newNodeId :: IO Int
200+newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
201+
202+{-# NOINLINE unsafeNodeId #-}
203+unsafeNodeId :: a -> Int
204+unsafeNodeId a = unsafePerformIO $ do
205+ touch a
206+ newNodeId
207+#endif
208+
209+--------------------------------------------------------------------------------
210+-- EventSubscription
211+--------------------------------------------------------------------------------
212+
213+--NB: Once you subscribe to an Event, you must always hold on the the WHOLE EventSubscription you get back
214+-- If you do not retain the subscription, you may be prematurely unsubscribed from the parent event.
215+data EventSubscription x = EventSubscription
216+ { _eventSubscription_unsubscribe :: !(IO ())
217+ , _eventSubscription_subscribed :: {-# UNPACK #-} !(EventSubscribed x)
218+ }
219+
220+unsubscribe :: EventSubscription x -> IO ()
221+unsubscribe (EventSubscription u _) = u
222+
223+--------------------------------------------------------------------------------
224+-- Event
225+--------------------------------------------------------------------------------
226+
227+newtype Event x a = Event { unEvent :: Subscriber x a -> EventM x (EventSubscription x, Maybe a) }
228+
229+{-# INLINE subscribeAndRead #-}
230+subscribeAndRead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)
231+subscribeAndRead = unEvent
232+
233+{-# RULES
234+"cacheEvent/cacheEvent" forall e. cacheEvent (cacheEvent e) = cacheEvent e
235+"cacheEvent/pushCheap" forall f e. pushCheap f (cacheEvent e) = cacheEvent (pushCheap f e)
236+"hold/cacheEvent" forall f e. hold f (cacheEvent e) = hold f e
237+ #-}
238+
239+-- | Construct an 'Event' equivalent to that constructed by 'push', but with no
240+-- caching; if the computation function is very cheap, this is (much) more
241+-- efficient than 'push'
242+{-# INLINE [1] pushCheap #-}
243+pushCheap :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
244+pushCheap !f e = Event $ \sub -> do
245+ (subscription, occ) <- subscribeAndRead e $ sub
246+ { subscriberPropagate = \a -> do
247+ mb <- f a
248+ mapM_ (subscriberPropagate sub) mb
249+ }
250+ occ' <- join <$> mapM f occ
251+ return (subscription, occ')
252+
253+-- | A subscriber that never triggers other 'Event's
254+{-# INLINE terminalSubscriber #-}
255+terminalSubscriber :: (a -> EventM x ()) -> Subscriber x a
256+terminalSubscriber p = Subscriber
257+ { subscriberPropagate = p
258+ , subscriberInvalidateHeight = \_ -> return ()
259+ , subscriberRecalculateHeight = \_ -> return ()
260+ }
261+
262+-- | Subscribe to an Event only for the duration of one occurrence
263+{-# INLINE subscribeAndReadHead #-}
264+subscribeAndReadHead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)
265+subscribeAndReadHead e sub = do
266+ subscriptionRef <- liftIO $ newIORef $ error "subscribeAndReadHead: not initialized"
267+ (subscription, occ) <- subscribeAndRead e $ sub
268+ { subscriberPropagate = \a -> do
269+ liftIO $ unsubscribe =<< readIORef subscriptionRef
270+ subscriberPropagate sub a
271+ }
272+ liftIO $ case occ of
273+ Nothing -> writeIORef subscriptionRef $! subscription
274+ Just _ -> unsubscribe subscription
275+ return (subscription, occ)
276+
277+--TODO: Make this lazy in its input event
278+headE :: (MonadIO m, Defer (SomeMergeInit x) m) => Event x a -> m (Event x a)
279+headE originalE = do
280+ parent <- liftIO $ newIORef $ Just originalE
281+ defer $ SomeMergeInit $ do --TODO: Rename SomeMergeInit appropriately
282+ let clearParent = liftIO $ writeIORef parent Nothing
283+ (_, occ) <- subscribeAndReadHead originalE $ terminalSubscriber $ \_ -> clearParent
284+ when (isJust occ) clearParent
285+ return $ Event $ \sub -> do
286+ liftIO (readIORef parent) >>= \case
287+ Nothing -> return (EventSubscription (return ()) $ EventSubscribed zeroRef $ toAny (), Nothing)
288+ Just e -> subscribeAndReadHead e sub
289+
290+data CacheSubscribed x a
291+ = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(FastWeakBag (Subscriber x a))
292+ , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)
293+ , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))
294+ }
295+
296+-- | Construct an 'Event' whose value is guaranteed not to be recomputed
297+-- repeatedly
298+--
299+--TODO: Try a caching strategy where we subscribe directly to the parent when
300+--there's only one subscriber, and then build our own FastWeakBag only when a second
301+--subscriber joins
302+{-# NOINLINE [0] cacheEvent #-}
303+cacheEvent :: forall x a. HasSpiderTimeline x => Event x a -> Event x a
304+cacheEvent e =
305+#ifdef DEBUG_TRACE_EVENTS
306+ withStackOneLine $ \callSite -> Event $
307+#else
308+ Event $
309+#endif
310+ let mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))
311+ !mSubscribedRef = unsafeNewIORef e emptyFastWeak
312+ in \sub -> {-# SCC "cacheEvent" #-} do
313+#ifdef DEBUG_TRACE_EVENTS
314+ unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite
315+#endif
316+ subscribedTicket <- liftIO (readIORef mSubscribedRef >>= getFastWeakTicket) >>= \case
317+ Just subscribedTicket -> return subscribedTicket
318+ Nothing -> do
319+ subscribers <- liftIO FastWeakBag.empty
320+ occRef <- liftIO $ newIORef Nothing -- This should never be read prior to being set below
321+ (parentSub, occ) <- subscribeAndRead e $ Subscriber
322+ { subscriberPropagate = \a -> do
323+ liftIO $ writeIORef occRef $ Just a
324+ scheduleClear occRef
325+ propagateFast a subscribers
326+ , subscriberInvalidateHeight = \old -> do
327+ FastWeakBag.traverse subscribers $ invalidateSubscriberHeight old
328+ , subscriberRecalculateHeight = \new -> do
329+ FastWeakBag.traverse subscribers $ recalculateSubscriberHeight new
330+ }
331+ when (isJust occ) $ do
332+ liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing
333+ scheduleClear occRef
334+ let !subscribed = CacheSubscribed
335+ { _cacheSubscribed_subscribers = subscribers
336+ , _cacheSubscribed_parent = parentSub
337+ , _cacheSubscribed_occurrence = occRef
338+ }
339+ subscribedTicket <- liftIO $ mkFastWeakTicket subscribed
340+ liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket
341+ return subscribedTicket
342+ liftIO $ do
343+ subscribed <- getFastWeakTicketValue subscribedTicket
344+ ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed
345+ occ <- readIORef $ _cacheSubscribed_occurrence subscribed
346+ let es = EventSubscription
347+ { _eventSubscription_unsubscribe = do
348+ FastWeakBag.remove ticket
349+ isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed
350+ when isEmpty $ do
351+ writeIORef mSubscribedRef emptyFastWeak
352+ unsubscribe $ _cacheSubscribed_parent subscribed
353+ touch ticket
354+ touch subscribedTicket
355+ , _eventSubscription_subscribed = EventSubscribed
356+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed
357+ , eventSubscribedRetained = toAny subscribedTicket
358+ }
359+ }
360+ return (es, occ)
361+
362+subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)
363+subscribe e s = fst <$> subscribeAndRead e s
364+
365+{-# INLINE wrap #-}
366+wrap :: MonadIO m => (t -> EventSubscribed x) -> (Subscriber x a -> m (WeakBagTicket, t, Maybe a)) -> Subscriber x a -> m (EventSubscription x, Maybe a)
367+wrap tag getSpecificSubscribed sub = do
368+ (sln, subd, occ) <- getSpecificSubscribed sub
369+ let es = tag subd
370+ return (EventSubscription (WeakBag.remove sln >> touch sln) es, occ)
371+
372+eventRoot :: GCompare k => k a -> Root x k -> Event x a
373+eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r
374+
375+eventNever :: Event x a
376+eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
377+
378+eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k -> Event x a
379+eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
380+
381+eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a
382+eventSwitch !s = Event $ wrap eventSubscribedSwitch $ getSwitchSubscribed s
383+
384+eventCoincidence :: HasSpiderTimeline x => Coincidence x a -> Event x a
385+eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSubscribed c
386+
387+eventHold :: HasSpiderTimeline x => Hold x p -> Event x p
388+eventHold !h = Event $ subscribeHoldEvent h
389+
390+eventDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Event x p
391+eventDyn !j = Event $ \sub -> getDynHold j >>= \h -> subscribeHoldEvent h sub
392+
393+{-# INLINE subscribeCoincidenceInner #-}
394+subscribeCoincidenceInner :: HasSpiderTimeline x => Event x a -> Height -> CoincidenceSubscribed x a -> EventM x (Maybe a, Height, EventSubscribed x)
395+subscribeCoincidenceInner inner outerHeight subscribedUnsafe = do
396+ subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe
397+ (subscription@(EventSubscription _ innerSubd), innerOcc) <- subscribeAndRead inner subInner
398+ innerHeight <- liftIO $ getEventSubscribedHeight innerSubd
399+ let height = max innerHeight outerHeight
400+ defer $ SomeResetCoincidence subscription $ if height > outerHeight then Just subscribedUnsafe else Nothing
401+ return (innerOcc, height, innerSubd)
402+
403+--------------------------------------------------------------------------------
404+-- Subscriber
405+--------------------------------------------------------------------------------
406+
407+data Subscriber x a = Subscriber
408+ { subscriberPropagate :: !(a -> EventM x ())
409+ , subscriberInvalidateHeight :: !(Height -> IO ())
410+ , subscriberRecalculateHeight :: !(Height -> IO ())
411+ }
412+
413+--TODO: Move this comment to WeakBag
414+-- These function are constructor functions that are marked NOINLINE so they are
415+-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away
416+-- so any weak references that are attached to the constructors will have their
417+-- finalizer run. Using the opaque constructor, does not see the
418+-- constructor application, so it behaves like an IORef and cannot be fused away.
419+--
420+-- The result is also evaluated to WHNF, since forcing a thunk invalidates
421+-- the weak pointer to it in some cases.
422+
423+newSubscriberHold :: (HasSpiderTimeline x, Patch p) => Hold x p -> IO (Subscriber x p)
424+newSubscriberHold h = return $ Subscriber
425+ { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h
426+ , subscriberInvalidateHeight = \_ -> return ()
427+ , subscriberRecalculateHeight = \_ -> return ()
428+ }
429+
430+newSubscriberFan :: forall x k. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k -> IO (Subscriber x (DMap k Identity))
431+newSubscriberFan subscribed = return $ Subscriber
432+ { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
433+ subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
434+ tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
435+ liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
436+ scheduleClear $ fanSubscribedOccurrence subscribed
437+ let f _ (Pair (Identity v) subsubs) = do
438+ propagate v $ _fanSubscribedChildren_list subsubs
439+ return $ Constant ()
440+ _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
441+ return ()
442+ , subscriberInvalidateHeight = \old -> do
443+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
444+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
445+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old
446+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
447+ , subscriberRecalculateHeight = \new -> do
448+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
449+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
450+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new
451+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
452+ }
453+
454+newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)
455+newSubscriberSwitch subscribed = return $ Subscriber
456+ { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do
457+ tracePropagate (Proxy :: Proxy x) $ "SubscriberSwitch" <> showNodeId subscribed
458+ liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a
459+ scheduleClear $ switchSubscribedOccurrence subscribed
460+ propagate a $ switchSubscribedSubscribers subscribed
461+ , subscriberInvalidateHeight = \_ -> do
462+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
463+ oldHeight <- readIORef $ switchSubscribedHeight subscribed
464+ when (oldHeight /= invalidHeight) $ do
465+ writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
466+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
467+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
468+ , subscriberRecalculateHeight = \new -> do
469+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
470+ updateSwitchHeight new subscribed
471+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
472+ }
473+
474+newSubscriberCoincidenceOuter :: forall x b. HasSpiderTimeline x => CoincidenceSubscribed x b -> IO (Subscriber x (Event x b))
475+newSubscriberCoincidenceOuter subscribed = return $ Subscriber
476+ { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do
477+ tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceOuter" <> showNodeId subscribed
478+ outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed
479+ tracePropagate (Proxy :: Proxy x) $ " outerHeight = " <> show outerHeight
480+ (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed
481+ tracePropagate (Proxy :: Proxy x) $ " isJust occ = " <> show (isJust occ)
482+ tracePropagate (Proxy :: Proxy x) $ " innerHeight = " <> show innerHeight
483+ liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd
484+ scheduleClear $ coincidenceSubscribedInnerParent subscribed
485+ case occ of
486+ Nothing -> do
487+ when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
488+ writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight
489+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight
490+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight
491+ Just o -> do -- Since it's already firing, no need to adjust height
492+ liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
493+ scheduleClear $ coincidenceSubscribedOccurrence subscribed
494+ propagate o $ coincidenceSubscribedSubscribers subscribed
495+ , subscriberInvalidateHeight = \_ -> do
496+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
497+ invalidateCoincidenceHeight subscribed
498+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
499+ , subscriberRecalculateHeight = \_ -> do
500+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
501+ recalculateCoincidenceHeight subscribed
502+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
503+ }
504+
505+newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)
506+newSubscriberCoincidenceInner subscribed = return $ Subscriber
507+ { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do
508+ tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceInner" <> showNodeId subscribed
509+ occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed
510+ case occ of
511+ Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event
512+ Nothing -> do
513+ liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a
514+ scheduleClear $ coincidenceSubscribedOccurrence subscribed
515+ propagate a $ coincidenceSubscribedSubscribers subscribed
516+ , subscriberInvalidateHeight = \_ -> do
517+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
518+ invalidateCoincidenceHeight subscribed
519+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
520+ , subscriberRecalculateHeight = \_ -> do
521+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
522+ recalculateCoincidenceHeight subscribed
523+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
524+ }
525+
526+invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()
527+invalidateSubscriberHeight = flip subscriberInvalidateHeight
528+
529+recalculateSubscriberHeight :: Height -> Subscriber x a -> IO ()
530+recalculateSubscriberHeight = flip subscriberRecalculateHeight
531+
532+-- | Propagate everything at the current height
533+propagate :: a -> WeakBag (Subscriber x a) -> EventM x ()
534+propagate a subscribers = withIncreasedDepth $ do
535+ -- 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
536+ --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
537+ WeakBag.traverse subscribers $ \s -> subscriberPropagate s a
538+
539+-- | Propagate everything at the current height
540+propagateFast :: a -> FastWeakBag (Subscriber x a) -> EventM x ()
541+propagateFast a subscribers = withIncreasedDepth $ do
542+ -- 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
543+ --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
544+ FastWeakBag.traverse subscribers $ \s -> subscriberPropagate s a
545+
546+--------------------------------------------------------------------------------
547+-- EventSubscribed
548+--------------------------------------------------------------------------------
549+
550+toAny :: a -> Any
551+toAny = unsafeCoerce
552+
553+data EventSubscribed x = EventSubscribed
554+ { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
555+ , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
556+#ifdef DEBUG_CYCLES
557+ , eventSubscribedGetParents :: !(IO [Some (EventSubscribed x)]) -- For debugging loops
558+ , eventSubscribedHasOwnHeightRef :: !Bool
559+ , eventSubscribedWhoCreated :: !(IO [String])
560+#endif
561+ }
562+
563+eventSubscribedRoot :: RootSubscribed x a -> EventSubscribed x
564+eventSubscribedRoot !r = EventSubscribed
565+ { eventSubscribedHeightRef = zeroRef
566+ , eventSubscribedRetained = toAny r
567+#ifdef DEBUG_CYCLES
568+ , eventSubscribedGetParents = return []
569+ , eventSubscribedHasOwnHeightRef = False
570+ , eventSubscribedWhoCreated = return ["root"]
571+#endif
572+ }
573+
574+eventSubscribedNever :: EventSubscribed x
575+eventSubscribedNever = EventSubscribed
576+ { eventSubscribedHeightRef = zeroRef
577+ , eventSubscribedRetained = toAny ()
578+#ifdef DEBUG_CYCLES
579+ , eventSubscribedGetParents = return []
580+ , eventSubscribedHasOwnHeightRef = False
581+ , eventSubscribedWhoCreated = return ["never"]
582+#endif
583+ }
584+
585+eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x
586+eventSubscribedFan !subscribed = EventSubscribed
587+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
588+ , eventSubscribedRetained = toAny subscribed
589+#ifdef DEBUG_CYCLES
590+ , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
591+ , eventSubscribedHasOwnHeightRef = False
592+ , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
593+#endif
594+ }
595+
596+eventSubscribedSwitch :: SwitchSubscribed x a -> EventSubscribed x
597+eventSubscribedSwitch !subscribed = EventSubscribed
598+ { eventSubscribedHeightRef = switchSubscribedHeight subscribed
599+ , eventSubscribedRetained = toAny subscribed
600+#ifdef DEBUG_CYCLES
601+ , eventSubscribedGetParents = do
602+ s <- readIORef $ switchSubscribedCurrentParent subscribed
603+ return [Some.This $ _eventSubscription_subscribed s]
604+ , eventSubscribedHasOwnHeightRef = True
605+ , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
606+#endif
607+ }
608+
609+eventSubscribedCoincidence :: CoincidenceSubscribed x a -> EventSubscribed x
610+eventSubscribedCoincidence !subscribed = EventSubscribed
611+ { eventSubscribedHeightRef = coincidenceSubscribedHeight subscribed
612+ , eventSubscribedRetained = toAny subscribed
613+#ifdef DEBUG_CYCLES
614+ , eventSubscribedGetParents = do
615+ innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
616+ let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
617+ innerParents = maybeToList $ fmap Some.This innerSubscription
618+ return $ outerParent : innerParents
619+ , eventSubscribedHasOwnHeightRef = True
620+ , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
621+#endif
622+ }
623+
624+getEventSubscribedHeight :: EventSubscribed x -> IO Height
625+getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es
626+
627+#ifdef DEBUG_CYCLES
628+whoCreatedEventSubscribed :: EventSubscribed x -> IO [String]
629+whoCreatedEventSubscribed = eventSubscribedWhoCreated
630+
631+walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)]
632+walkInvalidHeightParents s0 = do
633+ subscribers <- flip execStateT mempty $ ($ Some.This s0) $ fix $ \loop (Some.This s) -> do
634+ h <- liftIO $ readIORef $ eventSubscribedHeightRef s
635+ when (h == invalidHeight) $ do
636+ when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed
637+ modify (Some.This s :)
638+ mapM_ loop =<< liftIO (eventSubscribedGetParents s)
639+ forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
640+ return subscribers
641+#endif
642+
643+{-# INLINE subscribeHoldEvent #-}
644+subscribeHoldEvent :: HasSpiderTimeline x => Hold x p -> Subscriber x p -> EventM x (EventSubscription x, Maybe p)
645+subscribeHoldEvent = subscribeAndRead . holdEvent
646+
647+--------------------------------------------------------------------------------
648+-- Behavior
649+--------------------------------------------------------------------------------
650+
651+newtype Behavior x a = Behavior { readBehaviorTracked :: BehaviorM x a }
652+
653+behaviorHold :: Hold x p -> Behavior x (PatchTarget p)
654+behaviorHold !h = Behavior $ readHoldTracked h
655+
656+behaviorHoldIdentity :: Hold x (Identity a) -> Behavior x a
657+behaviorHoldIdentity = behaviorHold
658+
659+behaviorConst :: a -> Behavior x a
660+behaviorConst !a = Behavior $ return a
661+
662+behaviorPull :: Pull x a -> Behavior x a
663+behaviorPull !p = Behavior $ do
664+ val <- liftIO $ readIORef $ pullValue p
665+ case val of
666+ Just subscribed -> do
667+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
668+ askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))
669+ liftIO $ touch $ pullSubscribedOwnInvalidator subscribed
670+ return $ pullSubscribedValue subscribed
671+ Nothing -> do
672+ i <- liftIO $ newInvalidatorPull p
673+ wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
674+ parentsRef <- liftIO $ newIORef []
675+ holdInits <- askBehaviorHoldInits
676+ a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
677+ invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
678+ parents <- liftIO $ readIORef parentsRef
679+ let subscribed = PullSubscribed
680+ { pullSubscribedValue = a
681+ , pullSubscribedInvalidators = invsRef
682+ , pullSubscribedOwnInvalidator = i
683+ , pullSubscribedParents = parents
684+ }
685+ liftIO $ writeIORef (pullValue p) $ Just subscribed
686+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
687+ return a
688+
689+behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p)
690+behaviorDyn !d = Behavior $ readHoldTracked =<< getDynHold d
691+
692+{-# INLINE readHoldTracked #-}
693+readHoldTracked :: Hold x p -> BehaviorM x (PatchTarget p)
694+readHoldTracked h = do
695+ result <- liftIO $ readIORef $ holdValue h
696+ askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))
697+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))
698+ liftIO $ touch h -- Otherwise, if this gets inlined enough, the hold's parent reference may get collected
699+ return result
700+
701+{-# INLINABLE readBehaviorUntracked #-}
702+readBehaviorUntracked :: Defer (SomeHoldInit x) m => Behavior x a -> m a
703+readBehaviorUntracked b = do
704+ holdInits <- getDeferralQueue
705+ liftIO $ runBehaviorM (readBehaviorTracked b) Nothing holdInits --TODO: Specialize readBehaviorTracked to the Nothing and Just cases
706+
707+--------------------------------------------------------------------------------
708+-- Dynamic
709+--------------------------------------------------------------------------------
710+
711+data Dynamic x p = Dynamic
712+ { dynamicCurrent :: !(Behavior x (PatchTarget p))
713+ , dynamicUpdated :: !(Event x p)
714+ }
715+
716+dynamicHold :: HasSpiderTimeline x => Hold x p -> Dynamic x p
717+dynamicHold !h = Dynamic
718+ { dynamicCurrent = behaviorHold h
719+ , dynamicUpdated = eventHold h
720+ }
721+
722+dynamicHoldIdentity :: HasSpiderTimeline x => Hold x (Identity a) -> Dynamic x (Identity a)
723+dynamicHoldIdentity = dynamicHold
724+
725+dynamicConst :: PatchTarget p -> Dynamic x p
726+dynamicConst !a = Dynamic
727+ { dynamicCurrent = behaviorConst a
728+ , dynamicUpdated = eventNever
729+ }
730+
731+dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p
732+dynamicDyn !d = Dynamic
733+ { dynamicCurrent = behaviorDyn d
734+ , dynamicUpdated = eventDyn d
735+ }
736+
737+dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a)
738+dynamicDynIdentity = dynamicDyn
739+
740+--------------------------------------------------------------------------------
741+-- Combinators
742+--------------------------------------------------------------------------------
743+
744+--TODO: Figure out why certain things are not 'representational', then make them
745+--representational so we can use coerce
746+
747+--type role Hold representational
748+data Hold x p
749+ = Hold { holdValue :: !(IORef (PatchTarget p))
750+ , holdInvalidators :: !(IORef [Weak (Invalidator x)])
751+ , holdEvent :: Event x p -- This must be lazy, or holds cannot be defined before their input Events
752+ , holdParent :: !(IORef (Maybe (EventSubscription x))) -- Keeps its parent alive (will be undefined until the hold is initialized) --TODO: Probably shouldn't be an IORef
753+#ifdef DEBUG_NODEIDS
754+ , holdNodeId :: Int
755+#endif
756+ }
757+
758+-- | A statically allocated 'SpiderTimeline'
759+data Global
760+
761+{-# NOINLINE globalSpiderTimelineEnv #-}
762+globalSpiderTimelineEnv :: SpiderTimelineEnv Global
763+globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv
764+
765+-- | Stores all global data relevant to a particular Spider timeline; only one
766+-- value should exist for each type @x@
767+data SpiderTimelineEnv x = SpiderTimelineEnv
768+ { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
769+ , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
770+#ifdef DEBUG
771+ , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
772+#endif
773+ }
774+type role SpiderTimelineEnv nominal
775+
776+instance Eq (SpiderTimelineEnv x) where
777+ _ == _ = True -- Since only one exists of each type
778+
779+instance GEq SpiderTimelineEnv where
780+ a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b
781+ then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
782+ else Nothing
783+
784+data EventEnv x
785+ = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe
786+ , eventEnvHoldInits :: !(IORef [SomeHoldInit x]) -- Needed for Subscribe
787+ , eventEnvDynInits :: !(IORef [SomeDynInit x])
788+ , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])
789+ , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe
790+ , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe
791+ , eventEnvIntClears :: !(IORef [SomeIntClear])
792+ , eventEnvRootClears :: !(IORef [SomeRootClear])
793+ , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe
794+ , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe
795+ , eventEnvDelayedMerges :: !(IORef (IntMap [EventM x ()]))
796+ }
797+
798+{-# INLINE runEventM #-}
799+runEventM :: EventM x a -> IO a
800+runEventM = unEventM
801+
802+asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a
803+asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
804+
805+class MonadIO m => Defer a m where
806+ getDeferralQueue :: m (IORef [a])
807+
808+{-# INLINE defer #-}
809+defer :: Defer a m => a -> m ()
810+defer a = do
811+ q <- getDeferralQueue
812+ liftIO $ modifyIORef' q (a:)
813+
814+instance HasSpiderTimeline x => Defer (SomeAssignment x) (EventM x) where
815+ {-# INLINE getDeferralQueue #-}
816+ getDeferralQueue = asksEventEnv eventEnvAssignments
817+
818+instance HasSpiderTimeline x => Defer (SomeHoldInit x) (EventM x) where
819+ {-# INLINE getDeferralQueue #-}
820+ getDeferralQueue = asksEventEnv eventEnvHoldInits
821+
822+instance HasSpiderTimeline x => Defer (SomeDynInit x) (EventM x) where
823+ {-# INLINE getDeferralQueue #-}
824+ getDeferralQueue = asksEventEnv eventEnvDynInits
825+
826+instance Defer (SomeHoldInit x) (BehaviorM x) where
827+ {-# INLINE getDeferralQueue #-}
828+ getDeferralQueue = BehaviorM $ asks snd
829+
830+instance HasSpiderTimeline x => Defer (SomeMergeUpdate x) (EventM x) where
831+ {-# INLINE getDeferralQueue #-}
832+ getDeferralQueue = asksEventEnv eventEnvMergeUpdates
833+
834+instance HasSpiderTimeline x => Defer (SomeMergeInit x) (EventM x) where
835+ {-# INLINE getDeferralQueue #-}
836+ getDeferralQueue = asksEventEnv eventEnvMergeInits
837+
838+class HasSpiderTimeline x => HasCurrentHeight x m | m -> x where
839+ getCurrentHeight :: m Height
840+ scheduleMerge :: Height -> EventM x () -> m ()
841+
842+instance HasSpiderTimeline x => HasCurrentHeight x (EventM x) where
843+ {-# INLINE getCurrentHeight #-}
844+ getCurrentHeight = do
845+ heightRef <- asksEventEnv eventEnvCurrentHeight
846+ liftIO $ readIORef heightRef
847+ {-# INLINE scheduleMerge #-}
848+ scheduleMerge height subscribed = do
849+ delayedRef <- asksEventEnv eventEnvDelayedMerges
850+ liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [subscribed]
851+
852+class HasSpiderTimeline x where
853+ -- | Retrieve the current SpiderTimelineEnv
854+ spiderTimeline :: SpiderTimelineEnv x
855+
856+instance HasSpiderTimeline Global where
857+ spiderTimeline = globalSpiderTimelineEnv
858+
859+putCurrentHeight :: HasSpiderTimeline x => Height -> EventM x ()
860+putCurrentHeight h = do
861+ heightRef <- asksEventEnv eventEnvCurrentHeight
862+ liftIO $ writeIORef heightRef $! h
863+
864+instance HasSpiderTimeline x => Defer SomeClear (EventM x) where
865+ {-# INLINE getDeferralQueue #-}
866+ getDeferralQueue = asksEventEnv eventEnvClears
867+
868+{-# INLINE scheduleClear #-}
869+scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()
870+scheduleClear r = defer $ SomeClear r
871+
872+instance HasSpiderTimeline x => Defer SomeIntClear (EventM x) where
873+ {-# INLINE getDeferralQueue #-}
874+ getDeferralQueue = asksEventEnv eventEnvIntClears
875+
876+{-# INLINE scheduleIntClear #-}
877+scheduleIntClear :: Defer SomeIntClear m => IORef (IntMap a) -> m ()
878+scheduleIntClear r = defer $ SomeIntClear r
879+
880+instance HasSpiderTimeline x => Defer SomeRootClear (EventM x) where
881+ {-# INLINE getDeferralQueue #-}
882+ getDeferralQueue = asksEventEnv eventEnvRootClears
883+
884+{-# INLINE scheduleRootClear #-}
885+scheduleRootClear :: Defer SomeRootClear m => IORef (DMap k Identity) -> m ()
886+scheduleRootClear r = defer $ SomeRootClear r
887+
888+instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where
889+ {-# INLINE getDeferralQueue #-}
890+ getDeferralQueue = asksEventEnv eventEnvResetCoincidences
891+
892+-- Note: hold cannot examine its event until after the phase is over
893+{-# INLINE [1] hold #-}
894+hold :: (Patch p, Defer (SomeHoldInit x) m) => PatchTarget p -> Event x p -> m (Hold x p)
895+hold v0 e = do
896+ valRef <- liftIO $ newIORef v0
897+ invsRef <- liftIO $ newIORef []
898+ parentRef <- liftIO $ newIORef Nothing
899+#ifdef DEBUG_NODEIDS
900+ nodeId <- liftIO newNodeId
901+#endif
902+ let h = Hold
903+ { holdValue = valRef
904+ , holdInvalidators = invsRef
905+ , holdEvent = e
906+ , holdParent = parentRef
907+#ifdef DEBUG_NODEIDS
908+ , holdNodeId = nodeId
909+#endif
910+ }
911+ defer $ SomeHoldInit h
912+ return h
913+
914+{-# INLINE getHoldEventSubscription #-}
915+getHoldEventSubscription :: forall p x. (HasSpiderTimeline x, Patch p) => Hold x p -> EventM x (EventSubscription x)
916+getHoldEventSubscription h = do
917+ ep <- liftIO $ readIORef $ holdParent h
918+ case ep of
919+ Just subd -> return subd
920+ Nothing -> do
921+ let e = holdEvent h
922+ subscriptionRef <- liftIO $ newIORef $ error "getHoldEventSubscription: subdRef uninitialized"
923+ (subscription@(EventSubscription _ _), occ) <- subscribeAndRead e =<< liftIO (newSubscriberHold h)
924+ liftIO $ writeIORef subscriptionRef $! subscription
925+ case occ of
926+ Nothing -> return ()
927+ Just o -> do
928+ old <- liftIO $ readIORef $ holdValue h
929+ case apply o old of
930+ Nothing -> return ()
931+ Just new -> do
932+ -- Need to evaluate these so that we don't retain the Hold itself
933+ v <- liftIO $ evaluate $ holdValue h
934+ i <- liftIO $ evaluate $ holdInvalidators h
935+ defer $ SomeAssignment v i new
936+ liftIO $ writeIORef (holdParent h) $ Just subscription
937+ return subscription
938+
939+type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
940+
941+--type role BehaviorM representational
942+-- BehaviorM can sample behaviors
943+newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderT (BehaviorEnv x) IO a } deriving (Functor, Applicative, MonadIO, MonadFix)
944+
945+instance Monad (BehaviorM x) where
946+ {-# INLINE (>>=) #-}
947+ BehaviorM x >>= f = BehaviorM $ x >>= unBehaviorM . f
948+ {-# INLINE (>>) #-}
949+ BehaviorM x >> BehaviorM y = BehaviorM $ x >> y
950+ {-# INLINE return #-}
951+ return x = BehaviorM $ return x
952+ {-# INLINE fail #-}
953+ fail s = BehaviorM $ fail s
954+
955+data BehaviorSubscribed x a
956+ = forall p. BehaviorSubscribedHold (Hold x p)
957+ | BehaviorSubscribedPull (PullSubscribed x a)
958+
959+data SomeBehaviorSubscribed x = forall a. SomeBehaviorSubscribed (BehaviorSubscribed x a)
960+
961+--type role PullSubscribed representational
962+data PullSubscribed x a
963+ = PullSubscribed { pullSubscribedValue :: !a
964+ , pullSubscribedInvalidators :: !(IORef [Weak (Invalidator x)])
965+ , pullSubscribedOwnInvalidator :: !(Invalidator x)
966+ , pullSubscribedParents :: ![SomeBehaviorSubscribed x] -- Need to keep parent behaviors alive, or they won't let us know when they're invalidated
967+ }
968+
969+--type role Pull representational
970+data Pull x a
971+ = Pull { pullValue :: !(IORef (Maybe (PullSubscribed x a)))
972+ , pullCompute :: !(BehaviorM x a)
973+#ifdef DEBUG_NODEIDS
974+ , pullNodeId :: Int
975+#endif
976+ }
977+
978+data Invalidator x
979+ = forall a. InvalidatorPull (Pull x a)
980+ | forall a. InvalidatorSwitch (SwitchSubscribed x a)
981+
982+data RootSubscribed x a = forall k. GCompare k => RootSubscribed
983+ { rootSubscribedKey :: !(k a)
984+ , rootSubscribedCachedSubscribed :: !(IORef (DMap k (RootSubscribed x))) -- From the original Root
985+ , rootSubscribedSubscribers :: !(WeakBag (Subscriber x a))
986+ , rootSubscribedOccurrence :: !(IO (Maybe a)) -- Lookup from rootOccurrence
987+ , rootSubscribedUninit :: IO ()
988+ , rootSubscribedWeakSelf :: !(IORef (Weak (RootSubscribed x a))) --TODO: Can we make this a lazy non-IORef and then force it manually to avoid an indirection each time we use it?
989+#ifdef DEBUG_NODEIDS
990+ , rootSubscribedNodeId :: Int
991+#endif
992+ }
993+
994+data Root x (k :: * -> *)
995+ = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
996+ , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))
997+ , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))
998+ }
999+
1000+data SomeHoldInit x = forall p. Patch p => SomeHoldInit !(Hold x p)
1001+
1002+data SomeDynInit x = forall p. Patch p => SomeDynInit !(Dyn x p)
1003+
1004+data SomeMergeUpdate x = SomeMergeUpdate
1005+ { _someMergeUpdate_update :: !(EventM x [EventSubscription x])
1006+ , _someMergeUpdate_invalidateHeight :: !(IO ())
1007+ , _someMergeUpdate_recalculateHeight :: !(IO ())
1008+ }
1009+
1010+newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }
1011+
1012+-- EventM can do everything BehaviorM can, plus create holds
1013+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
1014+
1015+newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }
1016+
1017+data MergeSubscribedParentWithMove x k a = MergeSubscribedParentWithMove
1018+ { _mergeSubscribedParentWithMove_subscription :: !(EventSubscription x)
1019+ , _mergeSubscribedParentWithMove_key :: !(IORef (k a))
1020+ }
1021+
1022+data HeightBag = HeightBag
1023+ { _heightBag_size :: {-# UNPACK #-} !Int
1024+ , _heightBag_contents :: !(IntMap Word) -- Number of excess in each bucket
1025+ }
1026+ deriving (Show, Read, Eq, Ord)
1027+
1028+heightBagEmpty :: HeightBag
1029+heightBagEmpty = heightBagVerify $ HeightBag 0 IntMap.empty
1030+
1031+heightBagSize :: HeightBag -> Int
1032+heightBagSize = _heightBag_size
1033+
1034+heightBagFromList :: [Height] -> HeightBag
1035+heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights
1036+
1037+heightBagAdd :: Height -> HeightBag -> HeightBag
1038+heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $ IntMap.insertWithKey (\_ _ old -> succ old) h 0 c
1039+
1040+heightBagRemove :: Height -> HeightBag -> HeightBag
1041+heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of
1042+ Nothing -> error $ "heightBagRemove: Height " <> show h <> " not present in bag " <> show b
1043+ Just old -> HeightBag (pred s) $ case old of
1044+ 0 -> IntMap.delete h c
1045+ _ -> IntMap.insert h (pred old) c
1046+
1047+heightBagMax :: HeightBag -> Height
1048+heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of
1049+ Just ((h, _), _) -> Height h
1050+ Nothing -> zeroHeight
1051+
1052+heightBagVerify :: HeightBag -> HeightBag
1053+#ifdef DEBUG
1054+heightBagVerify b@(HeightBag s c) = if
1055+ | s /= IntMap.size c + fromIntegral (sum (IntMap.elems c))
1056+ -> error $ "heightBagVerify: size doesn't match: " <> show b
1057+ | unHeight invalidHeight `IntMap.member` c
1058+ -> error $ "heightBagVerify: contains invalid height: " <> show b
1059+ | otherwise -> b
1060+#else
1061+heightBagVerify = id
1062+#endif
1063+
1064+data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren
1065+ { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a))
1066+ , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k)
1067+ , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k)))
1068+ }
1069+
1070+data FanSubscribed (x :: *) k
1071+ = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1072+ , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
1073+ , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty
1074+ , fanSubscribedParent :: !(EventSubscription x)
1075+#ifdef DEBUG_NODEIDS
1076+ , fanSubscribedNodeId :: Int
1077+#endif
1078+ }
1079+
1080+data Fan x k
1081+ = Fan { fanParent :: !(Event x (DMap k Identity))
1082+ , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1083+ }
1084+
1085+data SwitchSubscribed x a
1086+ = SwitchSubscribed { switchSubscribedCachedSubscribed :: !(IORef (Maybe (SwitchSubscribed x a)))
1087+ , switchSubscribedOccurrence :: !(IORef (Maybe a))
1088+ , switchSubscribedHeight :: !(IORef Height)
1089+ , switchSubscribedSubscribers :: !(WeakBag (Subscriber x a))
1090+ , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} !(Invalidator x)
1091+ , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak (Invalidator x)))
1092+ , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed x])
1093+ , switchSubscribedParent :: !(Behavior x (Event x a))
1094+ , switchSubscribedCurrentParent :: !(IORef (EventSubscription x))
1095+ , switchSubscribedWeakSelf :: !(IORef (Weak (SwitchSubscribed x a)))
1096+#ifdef DEBUG_NODEIDS
1097+ , switchSubscribedNodeId :: Int
1098+#endif
1099+ }
1100+
1101+data Switch x a
1102+ = Switch { switchParent :: !(Behavior x (Event x a))
1103+ , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed x a)))
1104+ }
1105+
1106+#ifdef USE_TEMPLATE_HASKELL
1107+{-# ANN CoincidenceSubscribed "HLint: ignore Redundant bracket" #-}
1108+#endif
1109+data CoincidenceSubscribed x a
1110+ = CoincidenceSubscribed { coincidenceSubscribedCachedSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a)))
1111+ , coincidenceSubscribedOccurrence :: !(IORef (Maybe a))
1112+ , coincidenceSubscribedSubscribers :: !(WeakBag (Subscriber x a))
1113+ , coincidenceSubscribedHeight :: !(IORef Height)
1114+ , coincidenceSubscribedOuter :: {-# NOUNPACK #-} (Subscriber x (Event x a))
1115+ , coincidenceSubscribedOuterParent :: !(EventSubscription x)
1116+ , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed x)))
1117+ , coincidenceSubscribedWeakSelf :: !(IORef (Weak (CoincidenceSubscribed x a)))
1118+#ifdef DEBUG_NODEIDS
1119+ , coincidenceSubscribedNodeId :: Int
1120+#endif
1121+ }
1122+
1123+data Coincidence x a
1124+ = Coincidence { coincidenceParent :: !(Event x (Event x a))
1125+ , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a)))
1126+ }
1127+
1128+{-# NOINLINE newInvalidatorSwitch #-}
1129+newInvalidatorSwitch :: SwitchSubscribed x a -> IO (Invalidator x)
1130+newInvalidatorSwitch subd = return $! InvalidatorSwitch subd
1131+
1132+{-# NOINLINE newInvalidatorPull #-}
1133+newInvalidatorPull :: Pull x a -> IO (Invalidator x)
1134+newInvalidatorPull p = return $! InvalidatorPull p
1135+
1136+instance HasSpiderTimeline x => FunctorMaybe (Event x) where
1137+ fmapMaybe f = push $ return . f
1138+
1139+instance HasSpiderTimeline x => Align (Event x) where
1140+ nil = eventNever
1141+ align ea eb = fmapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
1142+
1143+newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (PatchTarget p), Event x p) (Hold x p)) }
1144+
1145+newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)
1146+newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
1147+
1148+--TODO: Avoid the duplication between this and R.zipDynWith
1149+zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c)
1150+zipDynWith f da db =
1151+ let eab = align (dynamicUpdated da) (dynamicUpdated db)
1152+ ec = flip push eab $ \o -> do
1153+ (a, b) <- case o of
1154+ This (Identity a) -> do
1155+ b <- readBehaviorUntracked $ dynamicCurrent db
1156+ return (a, b)
1157+ That (Identity b) -> do
1158+ a <- readBehaviorUntracked $ dynamicCurrent da
1159+ return (a, b)
1160+ These (Identity a) (Identity b) -> return (a, b)
1161+ return $ Just $ Identity $ f a b
1162+ in dynamicDynIdentity $ unsafeBuildDynamic (f <$> readBehaviorUntracked (dynamicCurrent da) <*> readBehaviorUntracked (dynamicCurrent db)) ec
1163+
1164+buildDynamic :: (Defer (SomeDynInit x) m, Patch p) => BehaviorM x (PatchTarget p) -> Event x p -> m (Dyn x p)
1165+buildDynamic readV0 v' = do
1166+ result <- liftIO $ newIORef $ Left (readV0, v')
1167+ let !d = Dyn result
1168+ defer $ SomeDynInit d
1169+ return d
1170+
1171+unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
1172+unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ Left x
1173+ where x = (readV0, v')
1174+
1175+-- ResultM can read behaviors and events
1176+type ResultM = EventM
1177+
1178+{-# NOINLINE unsafeNewIORef #-}
1179+unsafeNewIORef :: a -> b -> IORef b
1180+unsafeNewIORef a b = unsafePerformIO $ do
1181+ touch a
1182+ newIORef b
1183+
1184+instance HasSpiderTimeline x => Functor (Event x) where
1185+ fmap f = push $ return . Just . f
1186+
1187+instance Functor (Behavior x) where
1188+ fmap f = pull . fmap f . readBehaviorTracked
1189+
1190+{-# INLINE push #-}
1191+push :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
1192+push f e = cacheEvent (pushCheap f e)
1193+
1194+{-# INLINABLE pull #-}
1195+pull :: BehaviorM x a -> Behavior x a
1196+pull a = behaviorPull $ Pull
1197+ { pullCompute = a
1198+ , pullValue = unsafeNewIORef a Nothing
1199+#ifdef DEBUG_NODEIDS
1200+ , pullNodeId = unsafeNodeId a
1201+#endif
1202+ }
1203+
1204+{-# INLINABLE switch #-}
1205+switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a
1206+switch a = eventSwitch $ Switch
1207+ { switchParent = a
1208+ , switchSubscribed = unsafeNewIORef a Nothing
1209+ }
1210+
1211+coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a
1212+coincidence a = eventCoincidence $ Coincidence
1213+ { coincidenceParent = a
1214+ , coincidenceSubscribed = unsafeNewIORef a Nothing
1215+ }
1216+
1217+-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
1218+run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
1219+run roots after = do
1220+ tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
1221+ t <- SpiderHost ask
1222+ result <- SpiderHost $ lift $ withMVar (_spiderTimeline_lock t) $ \_ -> flip runReaderT t $ unSpiderHost $ runFrame $ do
1223+ rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
1224+ occBefore <- liftIO $ do
1225+ occBefore <- readIORef occRef
1226+ writeIORef occRef $! DMap.insert k a occBefore
1227+ return occBefore
1228+ if DMap.null occBefore
1229+ then do scheduleRootClear occRef
1230+ return $ Just r
1231+ else return Nothing
1232+ forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> Identity a) -> do
1233+ propagate a subscribersRef
1234+ delayedRef <- asksEventEnv eventEnvDelayedMerges
1235+ let go = do
1236+ delayed <- liftIO $ readIORef delayedRef
1237+ case IntMap.minViewWithKey delayed of
1238+ Nothing -> return ()
1239+ Just ((currentHeight, cur), future) -> do
1240+ tracePropagate (Proxy :: Proxy x) $ "Running height " ++ show currentHeight
1241+ putCurrentHeight $ Height currentHeight
1242+ liftIO $ writeIORef delayedRef $! future
1243+ sequence_ cur
1244+ go
1245+ go
1246+ putCurrentHeight maxBound
1247+ after
1248+ tracePropagate (Proxy :: Proxy x) "Done running an event frame"
1249+ return result
1250+
1251+scheduleMerge' :: HasSpiderTimeline x => Height -> IORef Height -> EventM x () -> EventM x ()
1252+scheduleMerge' initialHeight heightRef a = scheduleMerge initialHeight $ do
1253+ height <- liftIO $ readIORef heightRef
1254+ currentHeight <- getCurrentHeight
1255+ case height `compare` currentHeight of
1256+ LT -> error "Somehow a merge's height has been decreased after it was scheduled"
1257+ GT -> scheduleMerge' height heightRef a -- The height has been increased (by a coincidence event; TODO: is this the only way?)
1258+ EQ -> a
1259+
1260+data SomeClear = forall a. SomeClear {-# UNPACK #-} !(IORef (Maybe a))
1261+
1262+data SomeIntClear = forall a. SomeIntClear {-# UNPACK #-} !(IORef (IntMap a))
1263+
1264+data SomeRootClear = forall k. SomeRootClear {-# UNPACK #-} !(IORef (DMap k Identity))
1265+
1266+data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a
1267+
1268+debugFinalize :: Bool
1269+debugFinalize = False
1270+
1271+mkWeakPtrWithDebug :: a -> String -> IO (Weak a)
1272+mkWeakPtrWithDebug x debugNote = do
1273+ x' <- evaluate x
1274+ mkWeakPtr x' $
1275+ if debugFinalize
1276+ then Just $ putStrLn $ "finalizing: " ++ debugNote
1277+ else Nothing
1278+
1279+type WeakList a = [Weak a]
1280+
1281+{-# INLINE withIncreasedDepth #-}
1282+#ifdef DEBUG
1283+withIncreasedDepth :: CanTrace x m => m a -> m a
1284+withIncreasedDepth a = do
1285+ spiderTimeline <- askSpiderTimelineEnv
1286+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ
1287+ result <- a
1288+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred
1289+ return result
1290+#else
1291+withIncreasedDepth :: m a -> m a
1292+withIncreasedDepth = id
1293+#endif
1294+
1295+type CanTrace x m = (HasSpiderTimeline x, MonadIO m)
1296+
1297+{-# INLINE tracePropagate #-}
1298+tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1299+tracePropagate p = traceWhen p debugPropagate
1300+
1301+{-# INLINE traceInvalidate #-}
1302+traceInvalidate :: String -> IO ()
1303+traceInvalidate = when debugInvalidate . liftIO . putStrLn
1304+
1305+{-# INLINE traceWhen #-}
1306+traceWhen :: (CanTrace x m) => proxy x -> Bool -> String -> m ()
1307+traceWhen p b message = traceMWhen p b $ return message
1308+
1309+{-# INLINE traceMWhen #-}
1310+traceMWhen :: (CanTrace x m) => proxy x -> Bool -> m String -> m ()
1311+traceMWhen _ b getMessage = when b $ do
1312+ message <- getMessage
1313+#ifdef DEBUG
1314+ spiderTimeline <- askSpiderTimelineEnv
1315+ d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline
1316+#else
1317+ let d = 0
1318+#endif
1319+ liftIO $ putStrLn $ replicate d ' ' <> message
1320+
1321+whoCreatedIORef :: IORef a -> IO [String]
1322+whoCreatedIORef (IORef a) = whoCreated $! a
1323+
1324+#ifdef DEBUG_CYCLES
1325+groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
1326+groupByHead = \case
1327+ [] -> []
1328+ (x :| xs) : t -> case groupByHead t of
1329+ [] -> [(x, xs :| [])]
1330+ l@((y, yss) : t')
1331+ | x == y -> (x, xs `NonEmpty.cons` yss) : t'
1332+ | otherwise -> (x, xs :| []) : l
1333+
1334+listsToForest :: Eq a => [[a]] -> Forest a
1335+listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l
1336+#endif
1337+
1338+{-# INLINE propagateSubscriberHold #-}
1339+propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()
1340+propagateSubscriberHold h a = do
1341+ {-# SCC "trace" #-} traceMWhen (Proxy :: Proxy x) debugPropagate $ liftIO $ do
1342+ invalidators <- liftIO $ readIORef $ holdInvalidators h
1343+ return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
1344+ v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h
1345+ case {-# SCC "apply" #-} apply a v of
1346+ Nothing -> return ()
1347+ Just v' -> do
1348+ {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate (Proxy :: Proxy x) $ "propagateSubscriberHold: assigning Hold" <> showNodeId h
1349+ vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
1350+ iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
1351+ defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'
1352+
1353+data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1354+
1355+runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a
1356+runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)
1357+
1358+askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
1359+askInvalidator = do
1360+ (!m, _) <- BehaviorM ask
1361+ case m of
1362+ Nothing -> return Nothing
1363+ Just (!wi, _) -> return $ Just wi
1364+
1365+askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
1366+askParentsRef = do
1367+ (!m, _) <- BehaviorM ask
1368+ case m of
1369+ Nothing -> return Nothing
1370+ Just (_, !p) -> return $ Just p
1371+
1372+askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
1373+askBehaviorHoldInits = do
1374+ (_, !his) <- BehaviorM ask
1375+ return his
1376+
1377+{-# INLINE getDynHold #-}
1378+getDynHold :: (Defer (SomeHoldInit x) m, Patch p) => Dyn x p -> m (Hold x p)
1379+getDynHold d = do
1380+ mh <- liftIO $ readIORef $ unDyn d
1381+ case mh of
1382+ Right h -> return h
1383+ Left (readV0, v') -> do
1384+ holdInits <- getDeferralQueue
1385+ v0 <- liftIO $ runBehaviorM readV0 Nothing holdInits
1386+ h <- hold v0 v'
1387+ liftIO $ writeIORef (unDyn d) $ Right h
1388+ return h
1389+
1390+-- Always refers to 0
1391+{-# NOINLINE zeroRef #-}
1392+zeroRef :: IORef Height
1393+zeroRef = unsafePerformIO $ newIORef zeroHeight
1394+
1395+getRootSubscribed :: GCompare k => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)
1396+getRootSubscribed k r sub = do
1397+ mSubscribed <- readIORef $ rootSubscribed r
1398+ let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r
1399+ case DMap.lookup k mSubscribed of
1400+ Just subscribed -> {-# SCC "hitRoot" #-} do
1401+ sln <- subscribeRootSubscribed subscribed sub
1402+ occ <- getOcc
1403+ return (sln, subscribed, occ)
1404+ Nothing -> {-# SCC "missRoot" #-} do
1405+ weakSelf <- newIORef $ error "getRootSubscribed: weakSelfRef not initialized"
1406+ let !cached = rootSubscribed r
1407+ uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"
1408+ (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed
1409+ when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"
1410+ uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
1411+ writeIORef uninitRef $! uninit
1412+ let !subscribed = RootSubscribed
1413+ { rootSubscribedKey = k
1414+ , rootSubscribedCachedSubscribed = cached
1415+ , rootSubscribedOccurrence = getOcc
1416+ , rootSubscribedSubscribers = subs
1417+ , rootSubscribedUninit = uninit
1418+ , rootSubscribedWeakSelf = weakSelf
1419+#ifdef DEBUG_NODEIDS
1420+ , rootSubscribedNodeId = unsafeNodeId (k, r, subs)
1421+#endif
1422+ }
1423+ -- If we die at the same moment that all our children die, they will
1424+ -- try to clean us up but will fail because their Weak reference to us
1425+ -- will also be dead. So, if we are dying, check if there are any
1426+ -- children; since children don't bother cleaning themselves up if
1427+ -- their parents are already dead, I don't think there's a race
1428+ -- condition here. However, if there are any children, then we can
1429+ -- infer that we need to clean ourselves up, so we do.
1430+ finalCleanup = do
1431+ cs <- readIORef $ _weakBag_children subs
1432+ when (not $ IntMap.null cs) (cleanupRootSubscribed subscribed)
1433+ writeIORef weakSelf =<< evaluate =<< mkWeakPtr subscribed (Just finalCleanup)
1434+ modifyIORef' (rootSubscribed r) $ DMap.insertWith (error $ "getRootSubscribed: duplicate key inserted into Root") k subscribed --TODO: I think we can just write back mSubscribed rather than re-reading it
1435+ occ <- getOcc
1436+ return (sln, subscribed, occ)
1437+
1438+#ifdef USE_TEMPLATE_HASKELL
1439+{-# ANN cleanupRootSubscribed "HLint: ignore Redundant bracket" #-}
1440+#endif
1441+cleanupRootSubscribed :: RootSubscribed x a -> IO ()
1442+cleanupRootSubscribed self@RootSubscribed { rootSubscribedKey = k, rootSubscribedCachedSubscribed = cached } = do
1443+ rootSubscribedUninit self
1444+ modifyIORef' cached $ DMap.delete k
1445+
1446+{-# INLINE subscribeRootSubscribed #-}
1447+subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1448+subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed
1449+
1450+newtype EventSelectorInt x a = EventSelectorInt { selectInt :: Int -> Event x a }
1451+
1452+data FanInt x a = FanInt
1453+ { _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
1454+ , _fanInt_subscriptionRef :: {-# UNPACK #-} !(IORef (EventSubscription x)) -- This should have a valid subscription iff subscribers is non-empty
1455+ , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a))
1456+ }
1457+
1458+newFanInt :: IO (FanInt x a)
1459+newFanInt = do
1460+ 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
1461+ subscriptionRef <- newIORef $ error "fanInt: no subscription"
1462+ occRef <- newIORef $ error "fanInt: no occurrence"
1463+ return $ FanInt
1464+ { _fanInt_subscribers = subscribers
1465+ , _fanInt_subscriptionRef = subscriptionRef
1466+ , _fanInt_occRef = occRef
1467+ }
1468+
1469+{-# NOINLINE unsafeNewFanInt #-}
1470+unsafeNewFanInt :: b -> FanInt x a
1471+unsafeNewFanInt b = unsafePerformIO $ do
1472+ touch b
1473+ newFanInt
1474+
1475+fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a
1476+fanInt p =
1477+ let self = unsafeNewFanInt p
1478+ in EventSelectorInt $ \k -> Event $ \sub -> do
1479+ isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)
1480+ when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input
1481+ (subscription, parentOcc) <- subscribeAndRead p $ Subscriber
1482+ { subscriberPropagate = \m -> do
1483+ liftIO $ writeIORef (_fanInt_occRef self) m
1484+ scheduleIntClear $ _fanInt_occRef self
1485+ FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> do --TODO: Do we need to know that no subscribers are being added as we traverse?
1486+ FastWeakBag.traverse b $ \s -> do
1487+ subscriberPropagate s v
1488+ , subscriberInvalidateHeight = \old -> do
1489+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1490+ FastWeakBag.traverse b $ \s -> do
1491+ subscriberInvalidateHeight s old
1492+ , subscriberRecalculateHeight = \new -> do
1493+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1494+ FastWeakBag.traverse b $ \s -> do
1495+ subscriberRecalculateHeight s new
1496+ }
1497+ liftIO $ do
1498+ writeIORef (_fanInt_subscriptionRef self) subscription
1499+ writeIORef (_fanInt_occRef self) $ fromMaybe IntMap.empty parentOcc
1500+ scheduleIntClear $ _fanInt_occRef self
1501+ liftIO $ do
1502+ b <- FastMutableIntMap.lookup (_fanInt_subscribers self) k >>= \case
1503+ Nothing -> do
1504+ b <- FastWeakBag.empty
1505+ FastMutableIntMap.insert (_fanInt_subscribers self) k b
1506+ return b
1507+ Just b -> return b
1508+ t <- liftIO $ FastWeakBag.insert sub b
1509+ currentOcc <- readIORef (_fanInt_occRef self)
1510+ (EventSubscription _ (EventSubscribed !heightRef _)) <- readIORef (_fanInt_subscriptionRef self)
1511+ return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)
1512+
1513+{-# INLINABLE getFanSubscribed #-}
1514+getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket, FanSubscribed x k, Maybe a)
1515+getFanSubscribed k f sub = do
1516+ mSubscribed <- liftIO $ readIORef $ fanSubscribed f
1517+ case mSubscribed of
1518+ Just subscribed -> {-# SCC "hitFan" #-} liftIO $ do
1519+ sln <- subscribeFanSubscribed k subscribed sub
1520+ occ <- readIORef $ fanSubscribedOccurrence subscribed
1521+ return (sln, subscribed, coerce $ DMap.lookup k =<< occ)
1522+ Nothing -> {-# SCC "missFan" #-} do
1523+ subscribedRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribedRef not yet initialized"
1524+ subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1525+ s <- liftIO $ newSubscriberFan subscribedUnsafe
1526+ (subscription, parentOcc) <- subscribeAndRead (fanParent f) s
1527+ weakSelf <- liftIO $ newIORef $ error "getFanSubscribed: weakSelf not yet initialized"
1528+ (subsForK, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupFanSubscribed
1529+ subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
1530+ occRef <- liftIO $ newIORef parentOcc
1531+ when (isJust parentOcc) $ scheduleClear occRef
1532+ let subscribed = FanSubscribed
1533+ { fanSubscribedCachedSubscribed = fanSubscribed f
1534+ , fanSubscribedOccurrence = occRef
1535+ , fanSubscribedParent = subscription
1536+ , fanSubscribedSubscribers = subscribersRef
1537+#ifdef DEBUG_NODEIDS
1538+ , fanSubscribedNodeId = unsafeNodeId f
1539+#endif
1540+ }
1541+ let !self = (k, subscribed)
1542+ liftIO $ writeIORef subscribersRef $! DMap.singleton k $ FanSubscribedChildren subsForK self weakSelf
1543+ liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug self "FanSubscribed"
1544+ liftIO $ writeIORef subscribedRef $! subscribed
1545+ liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
1546+ return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)
1547+
1548+cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO ()
1549+cleanupFanSubscribed (k, subscribed) = do
1550+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1551+ let reducedSubscribers = DMap.delete k subscribers
1552+ if DMap.null reducedSubscribers
1553+ then do
1554+ unsubscribe $ fanSubscribedParent subscribed
1555+ -- Not necessary in this case, because this whole FanSubscribed is dead: writeIORef (fanSubscribedSubscribers subscribed) reducedSubscribers
1556+ writeIORef (fanSubscribedCachedSubscribed subscribed) Nothing
1557+ else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
1558+
1559+{-# INLINE subscribeFanSubscribed #-}
1560+subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO WeakBagTicket
1561+subscribeFanSubscribed k subscribed sub = do
1562+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1563+ case DMap.lookup k subscribers of
1564+ Nothing -> {-# SCC "missSubscribeFanSubscribed" #-} do
1565+ let !self = (k, subscribed)
1566+ weakSelf <- newIORef =<< mkWeakPtrWithDebug self "FanSubscribed"
1567+ (list, sln) <- WeakBag.singleton sub weakSelf cleanupFanSubscribed
1568+ writeIORef (fanSubscribedSubscribers subscribed) $! DMap.insertWith (error "subscribeFanSubscribed: key that we just failed to find is present - should be impossible") k (FanSubscribedChildren list self weakSelf) subscribers
1569+ return sln
1570+ Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed
1571+
1572+{-# INLINABLE getSwitchSubscribed #-}
1573+getSwitchSubscribed :: HasSpiderTimeline x => Switch x a -> Subscriber x a -> EventM x (WeakBagTicket, SwitchSubscribed x a, Maybe a)
1574+getSwitchSubscribed s sub = do
1575+ mSubscribed <- liftIO $ readIORef $ switchSubscribed s
1576+ case mSubscribed of
1577+ Just subscribed -> {-# SCC "hitSwitch" #-} liftIO $ do
1578+ sln <- subscribeSwitchSubscribed subscribed sub
1579+ occ <- readIORef $ switchSubscribedOccurrence subscribed
1580+ return (sln, subscribed, occ)
1581+ Nothing -> {-# SCC "missSwitch" #-} do
1582+ subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created"
1583+ subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1584+ i <- liftIO $ newInvalidatorSwitch subscribedUnsafe
1585+ mySub <- liftIO $ newSubscriberSwitch subscribedUnsafe
1586+ wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorSwitch"
1587+ wiRef <- liftIO $ newIORef wi
1588+ parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior
1589+ holdInits <- getDeferralQueue
1590+ e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) (Just (wi, parentsRef)) holdInits
1591+ (subscription@(EventSubscription _ subd), parentOcc) <- subscribeAndRead e mySub
1592+ heightRef <- liftIO $ newIORef =<< getEventSubscribedHeight subd
1593+ subscriptionRef <- liftIO $ newIORef subscription
1594+ occRef <- liftIO $ newIORef parentOcc
1595+ when (isJust parentOcc) $ scheduleClear occRef
1596+ weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
1597+ (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1598+ let !subscribed = SwitchSubscribed
1599+ { switchSubscribedCachedSubscribed = switchSubscribed s
1600+ , switchSubscribedOccurrence = occRef
1601+ , switchSubscribedHeight = heightRef
1602+ , switchSubscribedSubscribers = subs
1603+ , switchSubscribedOwnInvalidator = i
1604+ , switchSubscribedOwnWeakInvalidator = wiRef
1605+ , switchSubscribedBehaviorParents = parentsRef
1606+ , switchSubscribedParent = switchParent s
1607+ , switchSubscribedCurrentParent = subscriptionRef
1608+ , switchSubscribedWeakSelf = weakSelf
1609+#ifdef DEBUG_NODEIDS
1610+ , switchSubscribedNodeId = unsafeNodeId s
1611+#endif
1612+ }
1613+ liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
1614+ liftIO $ writeIORef subscribedRef $! subscribed
1615+ liftIO $ writeIORef (switchSubscribed s) $ Just subscribed
1616+ return (slnForSub, subscribed, parentOcc)
1617+
1618+cleanupSwitchSubscribed :: SwitchSubscribed x a -> IO ()
1619+cleanupSwitchSubscribed subscribed = do
1620+ unsubscribe =<< readIORef (switchSubscribedCurrentParent subscribed)
1621+ finalize =<< readIORef (switchSubscribedOwnWeakInvalidator subscribed) -- We don't need to get invalidated if we're dead
1622+ writeIORef (switchSubscribedCachedSubscribed subscribed) Nothing
1623+
1624+{-# INLINE subscribeSwitchSubscribed #-}
1625+subscribeSwitchSubscribed :: SwitchSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1626+subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed
1627+
1628+{-# INLINABLE getCoincidenceSubscribed #-}
1629+getCoincidenceSubscribed :: forall x a. HasSpiderTimeline x => Coincidence x a -> Subscriber x a -> EventM x (WeakBagTicket, CoincidenceSubscribed x a, Maybe a)
1630+getCoincidenceSubscribed c sub = do
1631+ mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c
1632+ case mSubscribed of
1633+ Just subscribed -> {-# SCC "hitCoincidence" #-} liftIO $ do
1634+ sln <- subscribeCoincidenceSubscribed subscribed sub
1635+ occ <- readIORef $ coincidenceSubscribedOccurrence subscribed
1636+ return (sln, subscribed, occ)
1637+ Nothing -> {-# SCC "missCoincidence" #-} do
1638+ subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"
1639+ subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1640+ subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe
1641+ (outerSubscription@(EventSubscription _ outerSubd), outerOcc) <- subscribeAndRead (coincidenceParent c) subOuter
1642+ outerHeight <- liftIO $ getEventSubscribedHeight outerSubd
1643+ (occ, height, mInnerSubd) <- case outerOcc of
1644+ Nothing -> return (Nothing, outerHeight, Nothing)
1645+ Just o -> do
1646+ (occ, height, innerSubd) <- subscribeCoincidenceInner o outerHeight subscribedUnsafe
1647+ return (occ, height, Just innerSubd)
1648+ occRef <- liftIO $ newIORef occ
1649+ when (isJust occ) $ scheduleClear occRef
1650+ heightRef <- liftIO $ newIORef height
1651+ innerSubdRef <- liftIO $ newIORef mInnerSubd
1652+ scheduleClear innerSubdRef
1653+ weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
1654+ (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
1655+ let subscribed = CoincidenceSubscribed
1656+ { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
1657+ , coincidenceSubscribedOccurrence = occRef
1658+ , coincidenceSubscribedHeight = heightRef
1659+ , coincidenceSubscribedSubscribers = subs
1660+ , coincidenceSubscribedOuter = subOuter
1661+ , coincidenceSubscribedOuterParent = outerSubscription
1662+ , coincidenceSubscribedInnerParent = innerSubdRef
1663+ , coincidenceSubscribedWeakSelf = weakSelf
1664+#ifdef DEBUG_NODEIDS
1665+ , coincidenceSubscribedNodeId = unsafeNodeId c
1666+#endif
1667+ }
1668+ liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
1669+ liftIO $ writeIORef subscribedRef $! subscribed
1670+ liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed
1671+ return (slnForSub, subscribed, occ)
1672+
1673+cleanupCoincidenceSubscribed :: CoincidenceSubscribed x a -> IO ()
1674+cleanupCoincidenceSubscribed subscribed = do
1675+ unsubscribe $ coincidenceSubscribedOuterParent subscribed
1676+ writeIORef (coincidenceSubscribedCachedSubscribed subscribed) Nothing
1677+
1678+{-# INLINE subscribeCoincidenceSubscribed #-}
1679+subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1680+subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
1681+
1682+{-# INLINE merge #-}
1683+merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1684+merge d = cacheEvent (mergeCheap d)
1685+
1686+{-# INLINE mergeWithMove #-}
1687+mergeWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1688+mergeWithMove d = cacheEvent (mergeCheapWithMove d)
1689+
1690+{-# INLINE [1] mergeCheap #-}
1691+mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1692+mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy
1693+ where
1694+ updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)
1695+ updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
1696+ let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do
1697+ (mOldSubd, newPs) <- case me of
1698+ Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
1699+ Just e -> do
1700+ let s = subscriber $ return k
1701+ subscription@(EventSubscription _ subd) <- subscribe e s
1702+ newParentHeight <- liftIO $ getEventSubscribedHeight subd
1703+ let newParent = MergeSubscribedParent subscription
1704+ liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1705+ return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
1706+ forM_ mOldSubd $ \oldSubd -> do
1707+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd
1708+ liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1709+ return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
1710+ foldM f ([], oldParents) $ DMap.toList p
1711+ getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParent x)
1712+ getInitialSubscribers initialParents subscriber = do
1713+ subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1714+ let s = subscriber $ return k
1715+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1716+ height <- liftIO $ getEventSubscribedHeight parentSubd
1717+ return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription)
1718+ return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1719+ , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1720+ , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1721+ )
1722+ destroy :: MergeDestroyFunc k (MergeSubscribedParent x)
1723+ destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub
1724+
1725+{-# INLINE [1] mergeCheapWithMove #-}
1726+mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1727+mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
1728+ where
1729+ updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)
1730+ updateMe subscriber heightBagRef oldParents p = do
1731+ -- Prepare new parents for insertion
1732+ let subscribeParent :: forall a. k a -> Event x a -> EventM x (MergeSubscribedParentWithMove x k a)
1733+ subscribeParent k e = do
1734+ keyRef <- liftIO $ newIORef k
1735+ let s = subscriber $ liftIO $ readIORef keyRef
1736+ subscription@(EventSubscription _ subd) <- subscribe e s
1737+ liftIO $ do
1738+ newParentHeight <- getEventSubscribedHeight subd
1739+ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1740+ return $ MergeSubscribedParentWithMove subscription keyRef
1741+ p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey subscribeParent p
1742+ -- Collect old parents for deletion and update the keys of moved parents
1743+ let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Event x) a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
1744+ moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
1745+ Nothing -> do
1746+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent
1747+ liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1748+ return $ Just $ _mergeSubscribedParentWithMove_subscription parent
1749+ Just toKey -> do
1750+ liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey
1751+ return Nothing
1752+ toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
1753+ return (toDelete, applyAlways p' oldParents)
1754+ getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k)
1755+ getInitialSubscribers initialParents subscriber = do
1756+ subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1757+ keyRef <- liftIO $ newIORef k
1758+ let s = subscriber $ liftIO $ readIORef keyRef
1759+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1760+ height <- liftIO $ getEventSubscribedHeight parentSubd
1761+ return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
1762+ return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1763+ , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1764+ , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1765+ )
1766+ destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)
1767+ destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub
1768+
1769+type MergeUpdateFunc k x p s
1770+ = (forall a. EventM x (k a) -> Subscriber x a)
1771+ -> IORef HeightBag
1772+ -> DMap k s
1773+ -> p
1774+ -> EventM x ([EventSubscription x], DMap k s)
1775+
1776+type MergeInitFunc k x s
1777+ = DMap k (Event x)
1778+ -> (forall a. EventM x (k a) -> Subscriber x a)
1779+ -> EventM x (DMap k Identity, [Height], DMap k s)
1780+
1781+type MergeDestroyFunc k s
1782+ = DMap k s
1783+ -> IO ()
1784+
1785+data Merge x k s = Merge
1786+ { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))
1787+ , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)
1788+ , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)
1789+ , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k Identity))
1790+ , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k Identity))
1791+ }
1792+
1793+invalidateMergeHeight :: Merge x k s -> IO ()
1794+invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)
1795+
1796+invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
1797+invalidateMergeHeight' heightRef sub = do
1798+ oldHeight <- readIORef heightRef
1799+ 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
1800+ writeIORef heightRef $! invalidHeight
1801+ subscriberInvalidateHeight sub oldHeight
1802+
1803+
1804+revalidateMergeHeight :: Merge x k s -> IO ()
1805+revalidateMergeHeight m = do
1806+ currentHeight <- readIORef $ _merge_heightRef m
1807+ when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
1808+ heights <- readIORef $ _merge_heightBagRef m
1809+ parents <- readIORef $ _merge_parentsRef m
1810+ -- When the number of heights in the bag reaches the number of parents, we should have a valid height
1811+ case heightBagSize heights `compare` DMap.size parents of
1812+ LT -> return ()
1813+ EQ -> do
1814+ let height = succHeight $ heightBagMax heights
1815+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
1816+ writeIORef (_merge_heightRef m) $! height
1817+ subscriberRecalculateHeight (_merge_sub m) height
1818+ GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
1819+
1820+scheduleMergeSelf :: HasSpiderTimeline x => Merge x k s -> Height -> EventM x ()
1821+scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
1822+ vals <- liftIO $ readIORef $ _merge_accumRef m
1823+ liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us, it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers
1824+ --TODO: Assert that m is not empty
1825+ subscriberPropagate (_merge_sub m) vals
1826+
1827+mergeSubscriber :: forall x k s a. (HasSpiderTimeline x, GCompare k) => Merge x k s -> EventM x (k a) -> Subscriber x a
1828+mergeSubscriber m getKey = Subscriber
1829+ { subscriberPropagate = \a -> do
1830+ oldM <- liftIO $ readIORef $ _merge_accumRef m
1831+ k <- getKey
1832+ let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM
1833+ tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
1834+ liftIO $ writeIORef (_merge_accumRef m) $! newM
1835+ when (DMap.null oldM) $ do -- Only schedule the firing once
1836+ height <- liftIO $ readIORef $ _merge_heightRef m
1837+ --TODO: assertions about height
1838+ currentHeight <- getCurrentHeight
1839+ when (height <= currentHeight) $ do
1840+ if height /= invalidHeight
1841+ then do
1842+ myStack <- liftIO $ whoCreatedIORef undefined --TODO
1843+ error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
1844+ else liftIO $ do
1845+#ifdef DEBUG_CYCLES
1846+ nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
1847+ stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es
1848+ let cycleInfo = ":\n" <> drawForest (listsToForest stacks)
1849+#else
1850+ let cycleInfo = ""
1851+#endif
1852+ error $ "Causality loop found" <> cycleInfo
1853+ scheduleMergeSelf m height
1854+ , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating
1855+ modifyIORef' (_merge_heightBagRef m) $ heightBagRemove old
1856+ invalidateMergeHeight m
1857+ , subscriberRecalculateHeight = \new -> do
1858+ modifyIORef' (_merge_heightBagRef m) $ heightBagAdd new
1859+ revalidateMergeHeight m
1860+ }
1861+
1862+--TODO: Be able to run as much of this as possible promptly
1863+updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k s -> MergeUpdateFunc k x p s -> p -> SomeMergeUpdate x
1864+updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)
1865+ where updateMe = do
1866+ oldParents <- liftIO $ readIORef $ _merge_parentsRef m
1867+ (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber m) (_merge_heightBagRef m) oldParents p
1868+ liftIO $ writeIORef (_merge_parentsRef m) $! newParents
1869+ return subscriptionsToKill
1870+
1871+{-# INLINE mergeCheap' #-}
1872+mergeCheap' :: forall k x p s. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k (Event x)) => MergeInitFunc k x s -> MergeUpdateFunc k x p s -> MergeDestroyFunc k s -> Dynamic x p -> Event x (DMap k Identity)
1873+mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1874+ initialParents <- readBehaviorUntracked $ dynamicCurrent d
1875+ accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
1876+ heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
1877+ heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"
1878+ parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"
1879+ let m = Merge
1880+ { _merge_parentsRef = parentsRef
1881+ , _merge_heightBagRef = heightBagRef
1882+ , _merge_heightRef = heightRef
1883+ , _merge_sub = sub
1884+ , _merge_accumRef = accumRef
1885+ }
1886+ (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber m
1887+ let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights
1888+ myHeight = if invalidHeight `elem` heights
1889+ then invalidHeight
1890+ else succHeight $ heightBagMax myHeightBag
1891+ currentHeight <- getCurrentHeight
1892+ let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now
1893+ then (if DMap.null dm then Nothing else Just dm, DMap.empty)
1894+ else (Nothing, dm)
1895+ unless (DMap.null accum) $ do
1896+ scheduleMergeSelf m myHeight
1897+ liftIO $ writeIORef accumRef $! accum
1898+ liftIO $ writeIORef heightRef $! myHeight
1899+ liftIO $ writeIORef heightBagRef $! myHeightBag
1900+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
1901+ liftIO $ writeIORef parentsRef $! initialParentState
1902+ defer $ SomeMergeInit $ do
1903+ let s = Subscriber
1904+ { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
1905+ tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change"
1906+ defer $ updateMerge m updateFunc a
1907+ , subscriberInvalidateHeight = \_ -> return ()
1908+ , subscriberRecalculateHeight = \_ -> return ()
1909+ }
1910+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s
1911+ forM_ change $ \c -> defer $ updateMerge m updateFunc c
1912+ -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
1913+ -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
1914+ -- its subscription.
1915+ liftIO $ writeIORef changeSubdRef (s, changeSubscription)
1916+ let unsubscribeAll = destroy =<< readIORef parentsRef
1917+ return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parentsRef, changeSubdRef)
1918+ , occ
1919+ )
1920+
1921+mergeInt :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1922+mergeInt = cacheEvent . mergeIntCheap
1923+
1924+{-# INLINABLE mergeIntCheap #-}
1925+mergeIntCheap :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1926+mergeIntCheap d = Event $ \sub -> do
1927+ initialParents <- readBehaviorUntracked $ dynamicCurrent d
1928+ accum <- liftIO $ FastMutableIntMap.newEmpty
1929+ heightRef <- liftIO $ newIORef zeroHeight
1930+ heightBagRef <- liftIO $ newIORef heightBagEmpty
1931+ parents <- liftIO $ FastMutableIntMap.newEmpty
1932+ let scheduleSelf = do
1933+ height <- liftIO $ readIORef $ heightRef
1934+ scheduleMerge' height heightRef $ do
1935+ vals <- liftIO $ FastMutableIntMap.getFrozenAndClear accum
1936+ subscriberPropagate sub vals
1937+ invalidateMyHeight = do
1938+ invalidateMergeHeight' heightRef sub
1939+ recalculateMyHeight = do
1940+ currentHeight <- readIORef heightRef
1941+ 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?
1942+ heights <- readIORef heightBagRef
1943+ numParents <- FastMutableIntMap.size parents
1944+ case heightBagSize heights `compare` numParents of
1945+ LT -> return ()
1946+ EQ -> do
1947+ let height = succHeight $ heightBagMax heights
1948+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
1949+ writeIORef heightRef $! height
1950+ subscriberRecalculateHeight sub height
1951+ GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"
1952+ mySubscriber k = Subscriber
1953+ { subscriberPropagate = \a -> do
1954+ wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum
1955+ liftIO $ FastMutableIntMap.insert accum k a
1956+ when wasEmpty scheduleSelf
1957+ , subscriberInvalidateHeight = \old -> do
1958+ modifyIORef' heightBagRef $ heightBagRemove old
1959+ invalidateMyHeight
1960+ , subscriberRecalculateHeight = \new -> do
1961+ modifyIORef' heightBagRef $ heightBagAdd new
1962+ recalculateMyHeight
1963+ }
1964+ forM_ (IntMap.toList initialParents) $ \(k, p) -> do
1965+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead p $ mySubscriber k
1966+ liftIO $ do
1967+ forM_ parentOcc $ FastMutableIntMap.insert accum k
1968+ FastMutableIntMap.insert parents k subscription
1969+ height <- getEventSubscribedHeight parentSubd
1970+ if height == invalidHeight
1971+ then writeIORef heightRef invalidHeight
1972+ else do
1973+ modifyIORef' heightBagRef $ heightBagAdd height
1974+ modifyIORef' heightRef $ \oldHeight ->
1975+ if oldHeight == invalidHeight
1976+ then invalidHeight
1977+ else max (succHeight height) oldHeight
1978+ myHeight <- liftIO $ readIORef heightRef
1979+ currentHeight <- getCurrentHeight
1980+ isEmpty <- liftIO $ FastMutableIntMap.isEmpty accum
1981+ occ <- if currentHeight >= myHeight -- If we should have fired by now
1982+ then if isEmpty
1983+ then return Nothing
1984+ else liftIO $ Just <$> FastMutableIntMap.getFrozenAndClear accum
1985+ else do when (not isEmpty) scheduleSelf -- We have things accumulated, but we shouldn't have fired them yet
1986+ return Nothing
1987+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
1988+ defer $ SomeMergeInit $ do
1989+ let updateMe a = SomeMergeUpdate u invalidateMyHeight recalculateMyHeight
1990+ where
1991+ u = do
1992+ let f k newParent = do
1993+ subscription@(EventSubscription _ subd) <- subscribe newParent $ mySubscriber k
1994+ newParentHeight <- liftIO $ getEventSubscribedHeight subd
1995+ liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1996+ return subscription
1997+ newSubscriptions <- FastMutableIntMap.traverseIntMapPatchWithKey f a
1998+ oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions
1999+ liftIO $ for_ oldParents $ \oldParent -> do
2000+ oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent
2001+ modifyIORef' heightBagRef $ heightBagRemove oldParentHeight
2002+ return $ IntMap.elems oldParents
2003+ let s = Subscriber
2004+ { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
2005+ tracePropagate (Proxy :: Proxy x) $ "SubscriberMergeInt/Change"
2006+ defer $ updateMe a
2007+ , subscriberInvalidateHeight = \_ -> return ()
2008+ , subscriberRecalculateHeight = \_ -> return ()
2009+ }
2010+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s
2011+ forM_ change $ \c -> defer $ updateMe c
2012+ -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
2013+ -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
2014+ -- its subscription.
2015+ liftIO $ writeIORef changeSubdRef (s, changeSubscription)
2016+ let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents
2017+ return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parents, changeSubdRef)
2018+ , occ
2019+ )
2020+
2021+newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
2022+
2023+fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k
2024+fan e =
2025+ let f = Fan
2026+ { fanParent = e
2027+ , fanSubscribed = unsafeNewIORef e Nothing
2028+ }
2029+ in EventSelector $ \k -> eventFan k f
2030+
2031+runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()
2032+runHoldInits holdInitRef dynInitRef mergeInitRef = do
2033+ holdInits <- liftIO $ readIORef holdInitRef
2034+ dynInits <- liftIO $ readIORef dynInitRef
2035+ mergeInits <- liftIO $ readIORef mergeInitRef
2036+ unless (null holdInits && null dynInits && null mergeInits) $ do
2037+ liftIO $ writeIORef holdInitRef []
2038+ liftIO $ writeIORef dynInitRef []
2039+ liftIO $ writeIORef mergeInitRef []
2040+ mapM_ initHold holdInits
2041+ mapM_ initDyn dynInits
2042+ mapM_ unSomeMergeInit mergeInits
2043+ runHoldInits holdInitRef dynInitRef mergeInitRef
2044+
2045+initHold :: HasSpiderTimeline x => SomeHoldInit x -> EventM x ()
2046+initHold (SomeHoldInit h) = void $ getHoldEventSubscription h
2047+
2048+initDyn :: HasSpiderTimeline x => SomeDynInit x -> EventM x ()
2049+initDyn (SomeDynInit d) = void $ getDynHold d
2050+
2051+newEventEnv :: IO (EventEnv x)
2052+newEventEnv = do
2053+ toAssignRef <- newIORef [] -- This should only actually get used when events are firing
2054+ holdInitRef <- newIORef []
2055+ dynInitRef <- newIORef []
2056+ mergeUpdateRef <- newIORef []
2057+ mergeInitRef <- newIORef []
2058+ heightRef <- newIORef zeroHeight
2059+ toClearRef <- newIORef []
2060+ toClearIntRef <- newIORef []
2061+ toClearRootRef <- newIORef []
2062+ coincidenceInfosRef <- newIORef []
2063+ delayedRef <- newIORef IntMap.empty
2064+ return $ EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef
2065+
2066+clearEventEnv :: EventEnv x -> IO ()
2067+clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef) = do
2068+ writeIORef toAssignRef []
2069+ writeIORef holdInitRef []
2070+ writeIORef dynInitRef []
2071+ writeIORef mergeUpdateRef []
2072+ writeIORef mergeInitRef []
2073+ writeIORef heightRef zeroHeight
2074+ writeIORef toClearRef []
2075+ writeIORef toClearIntRef []
2076+ writeIORef toClearRootRef []
2077+ writeIORef coincidenceInfosRef []
2078+ writeIORef delayedRef IntMap.empty
2079+
2080+-- | Run an event action outside of a frame
2081+runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
2082+runFrame a = SpiderHost $ ask >>= \_ -> lift $ do
2083+ let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
2084+ let go = do
2085+ result <- a
2086+ 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
2087+ return result
2088+ result <- runEventM go
2089+ toClear <- readIORef $ eventEnvClears env
2090+ forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing
2091+ toClearInt <- readIORef $ eventEnvIntClears env
2092+ forM_ toClearInt $ \(SomeIntClear ref) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty
2093+ toClearRoot <- readIORef $ eventEnvRootClears env
2094+ forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty
2095+ toAssign <- readIORef $ eventEnvAssignments env
2096+ toReconnectRef <- newIORef []
2097+ coincidenceInfos <- readIORef $ eventEnvResetCoincidences env
2098+ forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do
2099+ writeIORef vRef v
2100+ when debugInvalidate $ putStrLn $ "Invalidating Hold"
2101+ writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef
2102+ mergeUpdates <- readIORef $ eventEnvMergeUpdates env
2103+ writeIORef (eventEnvMergeUpdates env) []
2104+ when debugPropagate $ putStrLn "Updating merges"
2105+ mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates
2106+ when debugPropagate $ putStrLn "Updating merges done"
2107+ toReconnect <- readIORef toReconnectRef
2108+ clearEventEnv env
2109+ switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
2110+ oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed
2111+ wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed
2112+ when debugInvalidate $ putStrLn $ "Finalizing invalidator for Switch" <> showNodeId subscribed
2113+ finalize wi
2114+ i <- evaluate $ switchSubscribedOwnInvalidator subscribed
2115+ wi' <- mkWeakPtrWithDebug i "wi'"
2116+ writeIORef (switchSubscribedOwnWeakInvalidator subscribed) $! wi'
2117+ writeIORef (switchSubscribedBehaviorParents subscribed) []
2118+ writeIORef (eventEnvHoldInits env) [] --TODO: Should we reuse this?
2119+ e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) $ eventEnvHoldInits env
2120+ 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
2121+ --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times
2122+ sub <- newSubscriberSwitch subscribed
2123+ 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
2124+ {-
2125+ stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
2126+ liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
2127+ EventRoot _ -> "EventRoot"
2128+ EventNever -> "EventNever"
2129+ _ -> "something else"
2130+ -}
2131+ writeIORef (switchSubscribedCurrentParent subscribed) $! subscription
2132+ return oldSubscription
2133+ liftIO $ mapM_ unsubscribe mergeSubscriptionsToKill
2134+ liftIO $ mapM_ unsubscribe switchSubscriptionsToKill
2135+ forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
2136+ EventSubscription _ subd' <- readIORef $ switchSubscribedCurrentParent subscribed
2137+ parentHeight <- getEventSubscribedHeight subd'
2138+ myHeight <- readIORef $ switchSubscribedHeight subscribed
2139+ when (parentHeight /= myHeight) $ do
2140+ writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
2141+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight
2142+ 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
2143+ forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
2144+ unsubscribe subscription
2145+ mapM_ invalidateCoincidenceHeight mcs
2146+ forM_ coincidenceInfos $ \(SomeResetCoincidence _ mcs) -> mapM_ recalculateCoincidenceHeight mcs
2147+ mapM_ _someMergeUpdate_recalculateHeight mergeUpdates
2148+ forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
2149+ height <- calculateSwitchHeight subscribed
2150+ updateSwitchHeight height subscribed
2151+ return result
2152+
2153+newtype Height = Height { unHeight :: Int } deriving (Show, Read, Eq, Ord, Bounded)
2154+
2155+{-# INLINE zeroHeight #-}
2156+zeroHeight :: Height
2157+zeroHeight = Height 0
2158+
2159+{-# INLINE invalidHeight #-}
2160+invalidHeight :: Height
2161+invalidHeight = Height (-1000)
2162+
2163+#ifdef DEBUG_CYCLES
2164+-- | An invalid height that is currently being traversed, e.g. by walkInvalidHeightParents
2165+{-# INLINE invalidHeightBeingTraversed #-}
2166+invalidHeightBeingTraversed :: Height
2167+invalidHeightBeingTraversed = Height (-1001)
2168+#endif
2169+
2170+{-# INLINE succHeight #-}
2171+succHeight :: Height -> Height
2172+succHeight h@(Height a) =
2173+ if h == invalidHeight
2174+ then invalidHeight
2175+ else Height $ succ a
2176+
2177+invalidateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
2178+invalidateCoincidenceHeight subscribed = do
2179+ oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
2180+ when (oldHeight /= invalidHeight) $ do
2181+ writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight
2182+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
2183+
2184+updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()
2185+updateSwitchHeight new subscribed = do
2186+ oldHeight <- readIORef $ switchSubscribedHeight subscribed
2187+ when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2188+ when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2189+ writeIORef (switchSubscribedHeight subscribed) $! new
2190+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new
2191+
2192+recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
2193+recalculateCoincidenceHeight subscribed = do
2194+ oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
2195+ when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2196+ height <- calculateCoincidenceHeight subscribed
2197+ when (height /= invalidHeight) $ do
2198+ writeIORef (coincidenceSubscribedHeight subscribed) $! height
2199+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
2200+
2201+calculateSwitchHeight :: SwitchSubscribed x a -> IO Height
2202+calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)
2203+
2204+calculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO Height
2205+calculateCoincidenceHeight subscribed = do
2206+ outerHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
2207+ innerHeight <- maybe (return zeroHeight) getEventSubscribedHeight =<< readIORef (coincidenceSubscribedInnerParent subscribed)
2208+ return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight
2209+
2210+data SomeSwitchSubscribed x = forall a. SomeSwitchSubscribed {-# NOUNPACK #-} (SwitchSubscribed x a)
2211+
2212+invalidate :: IORef [SomeSwitchSubscribed x] -> WeakList (Invalidator x) -> IO (WeakList (Invalidator x))
2213+invalidate toReconnectRef wis = do
2214+ forM_ wis $ \wi -> do
2215+ mi <- deRefWeak wi
2216+ case mi of
2217+ Nothing -> do
2218+ traceInvalidate "invalidate Dead"
2219+ return () --TODO: Should we clean this up here?
2220+ Just i -> do
2221+ finalize wi -- Once something's invalidated, it doesn't need to hang around; this will change when some things are strict
2222+ case i of
2223+ InvalidatorPull p -> do
2224+ traceInvalidate $ "invalidate: Pull" <> showNodeId p
2225+ mVal <- readIORef $ pullValue p
2226+ forM_ mVal $ \val -> do
2227+ writeIORef (pullValue p) Nothing
2228+ writeIORef (pullSubscribedInvalidators val) =<< evaluate =<< invalidate toReconnectRef =<< readIORef (pullSubscribedInvalidators val)
2229+ InvalidatorSwitch subscribed -> do
2230+ traceInvalidate $ "invalidate: Switch" <> showNodeId subscribed
2231+ modifyIORef' toReconnectRef (SomeSwitchSubscribed subscribed :)
2232+ return [] -- Since we always finalize everything, always return an empty list --TODO: There are some things that will need to be re-subscribed every time; we should try to avoid finalizing them
2233+
2234+--------------------------------------------------------------------------------
2235+-- Reflex integration
2236+--------------------------------------------------------------------------------
2237+
2238+-- When we're specializing, we include this from Reflex.Class instead, because
2239+-- it needs access to these types; when we're not, we want them here, so our
2240+-- instance isn't an orphan instance.
2241+-- | Designates the default, global Spider timeline
2242+data SpiderTimeline x
2243+type role SpiderTimeline nominal
2244+
2245+-- | The default, global Spider environment
2246+type Spider = SpiderTimeline Global
2247+
2248+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (EventM x) where
2249+ {-# INLINABLE sample #-}
2250+ sample (SpiderBehavior b) = readBehaviorUntracked b
2251+
2252+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (EventM x) where
2253+ {-# INLINABLE hold #-}
2254+ hold = holdSpiderEventM
2255+ {-# INLINABLE holdDyn #-}
2256+ holdDyn = holdDynSpiderEventM
2257+ {-# INLINABLE holdIncremental #-}
2258+ holdIncremental = holdIncrementalSpiderEventM
2259+ {-# INLINABLE buildDynamic #-}
2260+ buildDynamic = buildDynamicSpiderEventM
2261+ {-# INLINABLE headE #-}
2262+ headE = R.slowHeadE
2263+-- headE (SpiderEvent e) = SpiderEvent <$> Reflex.Spider.Internal.headE e
2264+
2265+instance Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where
2266+ {-# INLINABLE sample #-}
2267+ sample = coerce . readBehaviorTracked . unSpiderBehavior
2268+
2269+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPushM x) where
2270+ {-# INLINABLE sample #-}
2271+ sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b
2272+
2273+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderPushM x) where
2274+ {-# INLINABLE hold #-}
2275+ hold v0 e = Reflex.Class.current <$> Reflex.Class.holdDyn v0 e
2276+ {-# INLINABLE holdDyn #-}
2277+ holdDyn v0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce e
2278+ {-# INLINABLE holdIncremental #-}
2279+ holdIncremental v0 (SpiderEvent e) = SpiderPushM $ SpiderIncremental . dynamicHold <$> Reflex.Spider.Internal.hold v0 e
2280+ {-# INLINABLE buildDynamic #-}
2281+ buildDynamic getV0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce e
2282+ {-# INLINABLE headE #-}
2283+ headE = R.slowHeadE
2284+-- headE (SpiderEvent e) = SpiderPushM $ SpiderEvent <$> Reflex.Spider.Internal.headE e
2285+
2286+instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where
2287+ {-# INLINE return #-}
2288+ return = pure
2289+ {-# INLINE (>>=) #-}
2290+ x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x
2291+ {-# INLINE (>>) #-}
2292+ (>>) = (*>)
2293+ {-# INLINE fail #-}
2294+ fail _ = error "Dynamic does not support 'fail'"
2295+
2296+{-# INLINABLE newJoinDyn #-}
2297+newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)
2298+newJoinDyn d =
2299+ let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)
2300+ eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d
2301+ eInner = Reflex.Spider.Internal.switch $ dynamicUpdated <$> dynamicCurrent d
2302+ eBoth = Reflex.Spider.Internal.coincidence $ dynamicUpdated . runIdentity <$> dynamicUpdated d
2303+ v' = unSpiderEvent $ Reflex.Class.leftmost $ map SpiderEvent [eBoth, eOuter, eInner]
2304+ in Reflex.Spider.Internal.unsafeBuildDynamic readV0 v'
2305+
2306+instance HasSpiderTimeline x => Functor (Reflex.Class.Dynamic (SpiderTimeline x)) where
2307+ fmap f = SpiderDynamic . newMapDyn f . unSpiderDynamic
2308+ x <$ d = R.unsafeBuildDynamic (return x) $ x <$ R.updated d
2309+
2310+instance HasSpiderTimeline x => Applicative (Reflex.Class.Dynamic (SpiderTimeline x)) where
2311+ pure = SpiderDynamic . dynamicConst
2312+#if MIN_VERSION_base(4,10,0)
2313+ liftA2 f a b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith f (unSpiderDynamic a) (unSpiderDynamic b)
2314+#endif
2315+ SpiderDynamic a <*> SpiderDynamic b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith ($) a b
2316+ a *> b = R.unsafeBuildDynamic (R.sample $ R.current b) $ R.leftmost [R.updated b, R.tag (R.current b) $ R.updated a]
2317+ (<*) = flip (*>) -- There are no effects, so order doesn't matter
2318+
2319+holdSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Behavior (SpiderTimeline x) a)
2320+holdSpiderEventM v0 e = fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e
2321+
2322+holdDynSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)
2323+holdDynSpiderEventM v0 e = fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e
2324+
2325+holdIncrementalSpiderEventM :: (HasSpiderTimeline x, Patch p) => PatchTarget p -> Reflex.Class.Event (SpiderTimeline x) p -> EventM x (Reflex.Class.Incremental (SpiderTimeline x) p)
2326+holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e
2327+
2328+buildDynamicSpiderEventM :: HasSpiderTimeline x => SpiderPullM x a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)
2329+buildDynamicSpiderEventM getV0 e = fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e
2330+
2331+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHost x) where
2332+ {-# INLINABLE hold #-}
2333+ hold v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.hold v0 e
2334+ {-# INLINABLE holdDyn #-}
2335+ holdDyn v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdDyn v0 e
2336+ {-# INLINABLE holdIncremental #-}
2337+ holdIncremental v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdIncremental v0 e
2338+ {-# INLINABLE buildDynamic #-}
2339+ buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e
2340+ {-# INLINABLE headE #-}
2341+ headE e = runFrame . runSpiderHostFrame $ Reflex.Class.headE e
2342+
2343+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where
2344+ sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can
2345+
2346+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHostFrame x) where
2347+ {-# INLINABLE hold #-}
2348+ hold v0 e = SpiderHostFrame $ fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e
2349+ {-# INLINABLE holdDyn #-}
2350+ holdDyn v0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e
2351+ {-# INLINABLE holdIncremental #-}
2352+ holdIncremental v0 e = SpiderHostFrame $ fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e
2353+ {-# INLINABLE buildDynamic #-}
2354+ buildDynamic getV0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e
2355+ {-# INLINABLE headE #-}
2356+ headE = R.slowHeadE
2357+-- headE (SpiderEvent e) = SpiderHostFrame $ SpiderEvent <$> Reflex.Spider.Internal.headE e
2358+
2359+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where
2360+ {-# INLINABLE sample #-}
2361+ sample = runFrame . readBehaviorUntracked . unSpiderBehavior
2362+
2363+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where
2364+ {-# INLINABLE sample #-}
2365+ sample = Reflex.Spider.Internal.ReadPhase . Reflex.Class.sample
2366+
2367+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where
2368+ {-# INLINABLE hold #-}
2369+ hold v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.hold v0 e
2370+ {-# INLINABLE holdDyn #-}
2371+ holdDyn v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdDyn v0 e
2372+ {-# INLINABLE holdIncremental #-}
2373+ holdIncremental v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdIncremental v0 e
2374+ {-# INLINABLE buildDynamic #-}
2375+ buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e
2376+ {-# INLINABLE headE #-}
2377+ headE e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.headE e
2378+
2379+--------------------------------------------------------------------------------
2380+-- Deprecated items
2381+--------------------------------------------------------------------------------
2382+
2383+-- | 'SpiderEnv' is the old name for 'SpiderTimeline'
2384+{-# DEPRECATED SpiderEnv "Use 'SpiderTimelineEnv' instead" #-}
2385+type SpiderEnv = SpiderTimeline
2386+instance HasSpiderTimeline x => Reflex.Host.Class.MonadSubscribeEvent (SpiderTimeline x) (SpiderHostFrame x) where
2387+ {-# INLINABLE subscribeEvent #-}
2388+ subscribeEvent e = SpiderHostFrame $ do
2389+ --TODO: Unsubscribe eventually (manually and/or with weak ref)
2390+ val <- liftIO $ newIORef Nothing
2391+ subscription <- subscribe (unSpiderEvent e) $ Subscriber
2392+ { subscriberPropagate = \a -> do
2393+ liftIO $ writeIORef val $ Just a
2394+ scheduleClear val
2395+ , subscriberInvalidateHeight = \_ -> return ()
2396+ , subscriberRecalculateHeight = \_ -> return ()
2397+ }
2398+ return $ SpiderEventHandle
2399+ { spiderEventHandleSubscription = subscription
2400+ , spiderEventHandleValue = val
2401+ }
2402+
2403+instance HasSpiderTimeline x => Reflex.Host.Class.ReflexHost (SpiderTimeline x) where
2404+ type EventTrigger (SpiderTimeline x) = RootTrigger x
2405+ type EventHandle (SpiderTimeline x) = SpiderEventHandle x
2406+ type HostFrame (SpiderTimeline x) = SpiderHostFrame x
2407+
2408+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReadEvent (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where
2409+ {-# NOINLINE readEvent #-}
2410+ readEvent h = Reflex.Spider.Internal.ReadPhase $ fmap (fmap return) $ liftIO $ do
2411+ result <- readIORef $ spiderEventHandleValue h
2412+ touch h
2413+ return result
2414+
2415+instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where
2416+ newEventWithTrigger = SpiderHost . lift . fmap SpiderEvent . newEventWithTriggerIO
2417+ newFanEventWithTrigger f = SpiderHost $ lift $ do
2418+ es <- newFanEventWithTriggerIO f
2419+ return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es
2420+
2421+instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where
2422+ newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO
2423+ newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do
2424+ es <- newFanEventWithTriggerIO f
2425+ return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es
2426+
2427+instance HasSpiderTimeline x => Reflex.Host.Class.MonadSubscribeEvent (SpiderTimeline x) (SpiderHost x) where
2428+ {-# INLINABLE subscribeEvent #-}
2429+ subscribeEvent = runFrame . runSpiderHostFrame . Reflex.Host.Class.subscribeEvent
2430+
2431+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexHost (SpiderTimeline x) (SpiderHost x) where
2432+ type ReadPhase (SpiderHost x) = Reflex.Spider.Internal.ReadPhase x
2433+ fireEventsAndRead es (Reflex.Spider.Internal.ReadPhase a) = run es a
2434+ runHostFrame = runFrame . runSpiderHostFrame
2435+
2436+unsafeNewSpiderTimelineEnv :: forall x. IO (SpiderTimelineEnv x)
2437+unsafeNewSpiderTimelineEnv = do
2438+ lock <- newMVar ()
2439+ env <- newEventEnv
2440+#ifdef DEBUG
2441+ depthRef <- newIORef 0
2442+#endif
2443+ return $ SpiderTimelineEnv
2444+ { _spiderTimeline_lock = lock
2445+ , _spiderTimeline_eventEnv = env
2446+#ifdef DEBUG
2447+ , _spiderTimeline_depth = depthRef
2448+#endif
2449+ }
2450+
2451+-- | Create a new SpiderTimelineEnv
2452+newSpiderTimeline :: IO (Some SpiderTimelineEnv)
2453+newSpiderTimeline = withSpiderTimeline (pure . Some.This)
2454+
2455+data LocalSpiderTimeline x s
2456+
2457+instance Reifies s (SpiderTimelineEnv x) =>
2458+ HasSpiderTimeline (LocalSpiderTimeline x s) where
2459+ spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s)
2460+
2461+localSpiderTimeline
2462+ :: Proxy s
2463+ -> SpiderTimelineEnv x
2464+ -> SpiderTimelineEnv (LocalSpiderTimeline x s)
2465+localSpiderTimeline _ = unsafeCoerce
2466+
2467+-- | Pass a new timeline to the given function.
2468+withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r
2469+withSpiderTimeline k = do
2470+ env <- unsafeNewSpiderTimelineEnv
2471+ reify env $ \s -> k $ localSpiderTimeline s env
2472+
2473+newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2474+
2475+type ComputeM = EventM
2476+
2477+newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2478+
2479+instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2480+ {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
2481+ newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
2482+ newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }
2483+ newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad)
2484+ newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }
2485+ type PullM (SpiderTimeline x) = SpiderPullM x
2486+ type PushM (SpiderTimeline x) = SpiderPushM x
2487+ {-# INLINABLE never #-}
2488+ never = SpiderEvent eventNever
2489+ {-# INLINABLE constant #-}
2490+ constant = SpiderBehavior . behaviorConst
2491+ {-# INLINE push #-}
2492+ push f = SpiderEvent . push (coerce f) . unSpiderEvent
2493+ {-# INLINE pushCheap #-}
2494+ pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
2495+ {-# INLINABLE pull #-}
2496+ pull = SpiderBehavior . pull . coerce
2497+ {-# INLINABLE merge #-}
2498+ merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x))
2499+ {-# INLINABLE fan #-}
2500+ fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
2501+ {-# INLINABLE switch #-}
2502+ switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior
2503+ {-# INLINABLE coincidence #-}
2504+ coincidence = SpiderEvent . coincidence . (coerce :: Event x (R.Event (SpiderTimeline x) a) -> Event x (Event x a)) . unSpiderEvent
2505+ {-# INLINABLE current #-}
2506+ current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
2507+ {-# INLINABLE updated #-}
2508+ updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic
2509+ {-# INLINABLE unsafeBuildDynamic #-}
2510+ unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
2511+ {-# INLINABLE unsafeBuildIncremental #-}
2512+ unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv
2513+ {-# INLINABLE mergeIncremental #-}
2514+ mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental
2515+ {-# INLINABLE mergeIncrementalWithMove #-}
2516+ mergeIncrementalWithMove = SpiderEvent . mergeWithMove . (unsafeCoerce :: Dynamic x (PatchDMapWithMove k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMapWithMove k (Event x))) . unSpiderIncremental
2517+ {-# INLINABLE currentIncremental #-}
2518+ currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
2519+ {-# INLINABLE updatedIncremental #-}
2520+ updatedIncremental = SpiderEvent . dynamicUpdated . unSpiderIncremental
2521+ {-# INLINABLE incrementalToDynamic #-}
2522+ incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (readBehaviorUntracked $ dynamicCurrent i) $ flip push (dynamicUpdated i) $ \p -> do
2523+ c <- readBehaviorUntracked $ dynamicCurrent i
2524+ return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'
2525+ eventCoercion Coercion = Coercion
2526+ behaviorCoercion Coercion = Coercion
2527+ dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance
2528+ {-# INLINABLE mergeIntIncremental #-}
2529+ mergeIntIncremental = SpiderEvent . mergeInt . (unsafeCoerce :: Dynamic x (PatchIntMap (R.Event (SpiderTimeline x) a)) -> Dynamic x (PatchIntMap (Event x a))) . unSpiderIncremental
2530+ {-# INLINABLE fanInt #-}
2531+ fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))
2532+
2533+data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)
2534+
2535+data SpiderEventHandle x a = SpiderEventHandle
2536+ { spiderEventHandleSubscription :: EventSubscription x
2537+ , spiderEventHandleValue :: IORef (Maybe a)
2538+ }
2539+
2540+instance MonadRef (EventM x) where
2541+ type Ref (EventM x) = Ref IO
2542+ {-# INLINABLE newRef #-}
2543+ {-# INLINABLE readRef #-}
2544+ {-# INLINABLE writeRef #-}
2545+ newRef = liftIO . newRef
2546+ readRef = liftIO . readRef
2547+ writeRef r a = liftIO $ writeRef r a
2548+
2549+instance MonadAtomicRef (EventM x) where
2550+ {-# INLINABLE atomicModifyRef #-}
2551+ atomicModifyRef r f = liftIO $ atomicModifyRef r f
2552+
2553+-- | The monad for actions that manipulate a Spider timeline identified by @x@
2554+newtype SpiderHost x a = SpiderHost { unSpiderHost :: ReaderT (SpiderTimelineEnv x) IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2555+
2556+instance Monad (SpiderHost x) where
2557+ {-# INLINABLE (>>=) #-}
2558+ SpiderHost x >>= f = SpiderHost $ x >>= unSpiderHost . f
2559+ {-# INLINABLE (>>) #-}
2560+ SpiderHost x >> SpiderHost y = SpiderHost $ x >> y
2561+ {-# INLINABLE return #-}
2562+ return x = SpiderHost $ return x
2563+ {-# INLINABLE fail #-}
2564+ fail s = SpiderHost $ fail s
2565+
2566+-- | Run an action affecting the global Spider timeline; this will be guarded by
2567+-- a mutex for that timeline
2568+runSpiderHost :: SpiderHost Global a -> IO a
2569+runSpiderHost (SpiderHost a) = runReaderT a globalSpiderTimelineEnv
2570+
2571+-- | Run an action affecting a given Spider timeline; this will be guarded by a
2572+-- mutex for that timeline
2573+runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
2574+runSpiderHostForTimeline (SpiderHost a) = runReaderT a
2575+
2576+newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2577+
2578+instance Monad (SpiderHostFrame x) where
2579+ {-# INLINABLE (>>=) #-}
2580+ SpiderHostFrame x >>= f = SpiderHostFrame $ x >>= runSpiderHostFrame . f
2581+ {-# INLINABLE (>>) #-}
2582+ SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y
2583+ {-# INLINABLE return #-}
2584+ return x = SpiderHostFrame $ return x
2585+ {-# INLINABLE fail #-}
2586+ fail s = SpiderHostFrame $ fail s
2587+
2588+instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where
2589+ notReadyUntil _ = pure ()
2590+ notReady = pure ()
2591+
2592+newEventWithTriggerIO :: (RootTrigger x a -> IO (IO ())) -> IO (Event x a)
2593+newEventWithTriggerIO f = do
2594+ es <- newFanEventWithTriggerIO $ \Refl -> f
2595+ return $ select es Refl
2596+
2597+newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)
2598+newFanEventWithTriggerIO f = do
2599+ occRef <- newIORef DMap.empty
2600+ subscribedRef <- newIORef DMap.empty
2601+ let !r = Root
2602+ { rootOccurrence = occRef
2603+ , rootSubscribed = subscribedRef
2604+ , rootInit = f
2605+ }
2606+ return $ EventSelector $ \k -> eventRoot k r
2607+
2608+newtype ReadPhase x a = ReadPhase (ResultM x a) deriving (Functor, Applicative, Monad, MonadFix)
2609+
2610+instance MonadRef (SpiderHost x) where
2611+ type Ref (SpiderHost x) = Ref IO
2612+ newRef = SpiderHost . newRef
2613+ readRef = SpiderHost . readRef
2614+ writeRef r = SpiderHost . writeRef r
2615+
2616+instance MonadAtomicRef (SpiderHost x) where
2617+ atomicModifyRef r = SpiderHost . atomicModifyRef r
2618+
2619+instance MonadRef (SpiderHostFrame x) where
2620+ type Ref (SpiderHostFrame x) = Ref IO
2621+ newRef = SpiderHostFrame . newRef
2622+ readRef = SpiderHostFrame . readRef
2623+ writeRef r = SpiderHostFrame . writeRef r
2624+
2625+instance MonadAtomicRef (SpiderHostFrame x) where
2626+ atomicModifyRef r = SpiderHostFrame . atomicModifyRef r
2627+
2628+instance PrimMonad (SpiderHostFrame x) where
2629+ type PrimState (SpiderHostFrame x) = PrimState IO
2630+ primitive = SpiderHostFrame . EventM . primitive
src/Reflex/Time.hsnew file+284
@@ -0,0 +1,284 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
5+{-# LANGUAGE RecursiveDo #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE TupleSections #-}
8+{-# LANGUAGE TypeFamilies #-}
9+#ifdef USE_TEMPLATE_HASKELL
10+{-# LANGUAGE TemplateHaskell #-}
11+#endif
12+module Reflex.Time where
13+
14+import Reflex.Class
15+import Reflex.Dynamic
16+import Reflex.PerformEvent.Class
17+import Reflex.PostBuild.Class
18+import Reflex.TriggerEvent.Class
19+
20+import Control.Concurrent
21+import qualified Control.Concurrent.Thread.Delay as Concurrent
22+import Control.Lens hiding ((|>))
23+import Control.Monad
24+import Control.Monad.Fix
25+import Control.Monad.IO.Class
26+import Data.Align
27+import Data.Fixed
28+import Data.Sequence (Seq, (|>))
29+import qualified Data.Sequence as Seq
30+import Data.These
31+import Data.Time.Clock
32+import Data.Typeable
33+import System.Random
34+
35+data TickInfo
36+ = TickInfo { _tickInfo_lastUTC :: UTCTime
37+ -- ^ UTC time immediately after the last tick.
38+ , _tickInfo_n :: Integer
39+ -- ^ Number of time periods since t0
40+ , _tickInfo_alreadyElapsed :: NominalDiffTime
41+ -- ^ Amount of time already elapsed in the current tick period.
42+ }
43+ deriving (Eq, Ord, Show, Typeable)
44+
45+-- | Special case of 'tickLossyFrom' that uses the post-build event to start the
46+-- tick thread.
47+tickLossy :: (PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m) => NominalDiffTime -> UTCTime -> m (Event t TickInfo)
48+tickLossy dt t0 = tickLossyFrom dt t0 =<< getPostBuild
49+
50+-- | Special case of 'tickLossyFrom' that uses the post-build event to start the
51+-- tick thread and the time of the post-build as the tick basis time.
52+tickLossyFromPostBuildTime :: (PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m) => NominalDiffTime -> m (Event t TickInfo)
53+tickLossyFromPostBuildTime dt = do
54+ postBuild <- getPostBuild
55+ postBuildTime <- performEvent $ liftIO getCurrentTime <$ postBuild
56+ tickLossyFrom' $ (dt,) <$> postBuildTime
57+
58+-- | Send events over time with the given basis time and interval
59+-- If the system starts running behind, occurrences will be dropped rather than buffered
60+-- Each occurrence of the resulting event will contain the index of the current interval, with 0 representing the basis time
61+tickLossyFrom
62+ :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m)
63+ => NominalDiffTime
64+ -- ^ The length of a tick interval
65+ -> UTCTime
66+ -- ^ The basis time from which intervals count
67+ -> Event t a
68+ -- ^ Event that starts a tick generation thread. Usually you want this to
69+ -- be something like the result of getPostBuild that only fires once. But
70+ -- there could be uses for starting multiple timer threads.
71+ -> m (Event t TickInfo)
72+tickLossyFrom dt t0 e = tickLossyFrom' $ (dt, t0) <$ e
73+
74+-- | Generalization of tickLossyFrom that takes dt and t0 in the event.
75+tickLossyFrom'
76+ :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m)
77+ => Event t (NominalDiffTime, UTCTime)
78+ -- ^ Event that starts a tick generation thread. Usually you want this to
79+ -- be something like the result of getPostBuild that only fires once. But
80+ -- there could be uses for starting multiple timer threads.
81+ -> m (Event t TickInfo)
82+tickLossyFrom' e = do
83+ rec result <- performEventAsync $ callAtNextInterval <$> leftmost [e, snd <$> result]
84+ return $ fst <$> result
85+ where callAtNextInterval pair cb = void $ liftIO $ forkIO $ do
86+ tick <- uncurry getCurrentTick pair
87+ Concurrent.delay $ ceiling $ (fst pair - _tickInfo_alreadyElapsed tick) * 1000000
88+ cb (tick, pair)
89+
90+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)
91+clockLossy dt t0 = do
92+ initial <- liftIO $ getCurrentTick dt t0
93+ e <- tickLossy dt t0
94+ holdDyn initial e
95+
96+getCurrentTick :: NominalDiffTime -> UTCTime -> IO TickInfo
97+getCurrentTick dt t0 = do
98+ t <- getCurrentTime
99+ let offset = t `diffUTCTime` t0
100+ (n, alreadyElapsed) = offset `divMod'` dt
101+ return $ TickInfo t n alreadyElapsed
102+
103+-- | Delay an Event's occurrences by a given amount in seconds.
104+delay :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t a)
105+delay dt e = performEventAsync $ ffor e $ \a cb -> liftIO $ void $ forkIO $ do
106+ Concurrent.delay $ ceiling $ dt * 1000000
107+ cb a
108+
109+-- | Send events with Poisson timing with the given basis and rate
110+-- Each occurence of the resulting event will contain the index of
111+-- the current interval, with 0 representing the basis time
112+poissonLossyFrom
113+ :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m)
114+ => g
115+ -> Double
116+ -- ^ Poisson event rate (Hz)
117+ -> UTCTime
118+ -- ^ Baseline time for events
119+ -> Event t a
120+ -- ^ Event that starts a tick generation thread. Usually you want this to
121+ -- be something like the result of getPostBuild that only fires once. But
122+ -- there could be uses for starting multiple timer threads.
123+ -- Start sending events in response to the event parameter.
124+ -> m (Event t TickInfo)
125+poissonLossyFrom rnd rate = inhomogeneousPoissonFrom rnd (constant rate) rate
126+
127+
128+-- | Send events with Poisson timing with the given basis and rate
129+-- Each occurence of the resulting event will contain the index of
130+-- the current interval, with 0 representing the basis time.
131+-- Automatically begin sending events when the DOM is built
132+poissonLossy
133+ :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, PostBuild t m)
134+ => g
135+ -> Double
136+ -- ^ Poisson event rate (Hz)
137+ -> UTCTime
138+ -- ^ Baseline time for events
139+ -> m (Event t TickInfo)
140+poissonLossy rnd rate t0 = poissonLossyFrom rnd rate t0 =<< getPostBuild
141+
142+-- | Send events with inhomogeneous Poisson timing with the given basis
143+-- and variable rate. Provide a maxRate that you expect to support.
144+inhomogeneousPoissonFrom
145+ :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m)
146+ => g
147+ -> Behavior t Double
148+ -> Double
149+ -> UTCTime
150+ -> Event t a
151+ -> m (Event t TickInfo)
152+inhomogeneousPoissonFrom rnd rate maxRate t0 e = do
153+
154+ -- Create a thread for producing homogeneous poisson events
155+ -- along with random Doubles (usage of Double's explained below)
156+ ticksWithRateRand <- performEventAsync $
157+ fmap callAtNextInterval e
158+
159+ -- Filter homogeneous events according to associated
160+ -- random values and the current rate parameter
161+ return $ attachWithMaybe filterFun rate ticksWithRateRand
162+
163+ where
164+
165+ -- Inhomogeneous poisson processes are built from faster
166+ -- homogeneous ones by randomly dropping events from the
167+ -- fast process. For each fast homogeneous event, choose
168+ -- a uniform random sample from (0, rMax). If the
169+ -- inhomogeneous rate at this moment is greater than the
170+ -- random sample, then keep this event, otherwise drop it
171+ filterFun :: Double -> (TickInfo, Double) -> Maybe TickInfo
172+ filterFun r (tInfo, p)
173+ | r >= p = Just tInfo
174+ | otherwise = Nothing
175+
176+ callAtNextInterval _ cb = void $ liftIO $ forkIO $ go t0 rnd cb 0
177+
178+ go tTargetLast lastGen cb lastN = do
179+ t <- getCurrentTime
180+
181+ -- Generate random numbers for this poisson interval (u)
182+ -- and sample-retention likelihood (p)
183+ let (u, nextGen) = randomR (0,1) lastGen
184+ (p :: Double, nextGen') = randomR (0,maxRate) nextGen
185+
186+ -- Inter-event interval is drawn from exponential
187+ -- distribution accourding to u
188+ let dt = realToFrac $ (-1) * log u / maxRate :: NominalDiffTime
189+ nEvents = lastN + 1
190+ alreadyElapsed = diffUTCTime t tTargetLast
191+ tTarget = addUTCTime dt tTargetLast
192+ thisDelay = realToFrac $ diffUTCTime tTarget t :: Double
193+ Concurrent.delay $ ceiling $ thisDelay * 1000000
194+ _ <- cb (TickInfo t nEvents alreadyElapsed, p)
195+ go tTarget nextGen' cb nEvents
196+
197+-- | Send events with inhomogeneous Poisson timing with the given basis
198+-- and variable rate. Provide a maxRate that you expect to support
199+inhomogeneousPoisson
200+ :: (RandomGen g, MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, PostBuild t m)
201+ => g
202+ -> Behavior t Double
203+ -> Double
204+ -> UTCTime
205+ -> m (Event t TickInfo)
206+inhomogeneousPoisson rnd rate maxRate t0 =
207+ inhomogeneousPoissonFrom rnd rate maxRate t0 =<< getPostBuild
208+
209+-- | Block occurrences of an Event until the given number of seconds elapses without
210+-- the Event firing, at which point the last occurrence of the Event will fire.
211+debounce :: (MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t a)
212+debounce dt e = do
213+ n :: Dynamic t Integer <- count e
214+ let tagged = attachPromptlyDynWith (,) n e
215+ delayed <- delay dt tagged
216+ return $ attachWithMaybe (\n' (t, v) -> if n' == t then Just v else Nothing) (current n) delayed
217+
218+-- | When the given 'Event' occurs, wait the given amount of time and collect
219+-- all occurrences during that time. Then, fire the output 'Event' with the
220+-- collected output.
221+batchOccurrences :: (MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t (Seq a))
222+batchOccurrences t newValues = do
223+ let f s x = (Just newState, out)
224+ where newState = case x of
225+ This a -> s |> a
226+ That _ -> mempty
227+ These a _ -> Seq.singleton a
228+ out = case x of
229+ This _ -> if Seq.null s then Just () else Nothing
230+ That _ -> Nothing
231+ These _ _ -> Just ()
232+ rec (buffer, toDelay) <- mapAccumMaybe f mempty $ align newValues delayed
233+ delayed <- delay t toDelay
234+ return $ tag buffer delayed
235+
236+-- | 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
237+-- frequently, the output event occurs with the most recently seen input value after the given delay passes since the last occurrence of the output.
238+-- If the output event has not occurred recently, occurrences of the input event will cause the output event to fire immediately.
239+throttle :: (MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => NominalDiffTime -> Event t a -> m (Event t a)
240+throttle t e = do
241+ let f (immediate, buffer) x = case x of -- (Just newState, out)
242+ This a -- If only the input event fires
243+ | immediate -> -- and we're in immediate mode
244+ -- Immediate mode turns off, and the buffer is empty.
245+ -- We fire the output event with the input event value immediately.
246+ (Just (False, Nothing), Just a)
247+ | otherwise -> -- and we're not in immediate mode
248+ -- Immediate mode remains off, and we replace the contents of the buffer (if any) with the input value.
249+ -- We don't fire the output event.
250+ (Just (False, Just a), Nothing)
251+ That _ -> -- If only the delayed output event fires,
252+ case buffer of
253+ Nothing -> -- and the buffer is empty:
254+ -- Immediate mode turns back on, and the buffer remains empty.
255+ -- We don't fire.
256+ (Just (True, Nothing), Nothing)
257+ Just b -> -- and the buffer is full:
258+ -- Immediate mode remains off, and the buffer is cleared.
259+ -- We fire with the buffered value.
260+ (Just (False, Nothing), Just b)
261+ These a _ -> -- If both the input and delayed output event fire simultaneously:
262+ -- Immediate mode turns off, and the buffer is empty.
263+ -- We fire with the input event's value, as it is the most recent we have seen at this moment.
264+ (Just (False, Nothing), Just a)
265+ rec (_, outE) <- mapAccumMaybeDyn f (True, Nothing) $ align e delayed -- We start in immediate mode with an empty buffer.
266+ delayed <- delay t outE
267+ return outE
268+
269+#ifdef USE_TEMPLATE_HASKELL
270+makeLensesWith (lensRules & simpleLenses .~ True) ''TickInfo
271+#else
272+tickInfo_lastUTC :: Lens' TickInfo UTCTime
273+tickInfo_lastUTC f (TickInfo x1 x2 x3) = (\y -> TickInfo y x2 x3) <$> f x1
274+{-# INLINE tickInfo_lastUTC #-}
275+
276+tickInfo_n :: Lens' TickInfo Integer
277+tickInfo_n f (TickInfo x1 x2 x3) = (\y -> TickInfo x1 y x3) <$> f x2
278+{-# INLINE tickInfo_n #-}
279+
280+tickInfo_alreadyElapsed :: Lens' TickInfo NominalDiffTime
281+tickInfo_alreadyElapsed f (TickInfo x1 x2 x3) = (\y -> TickInfo x1 x2 y) <$> f x3
282+{-# INLINE tickInfo_alreadyElapsed #-}
283+#endif
284+
src/Reflex/TriggerEvent/Base.hsnew file+147
@@ -0,0 +1,147 @@
1+-- | This module defines 'TriggerEventT', the standard implementation of
2+-- 'TriggerEvent'.
3+{-# LANGUAGE DeriveFunctor #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE TypeFamilies #-}
8+module Reflex.TriggerEvent.Base
9+ ( TriggerEventT (..)
10+ , runTriggerEventT
11+ , askEvents
12+ , TriggerInvocation (..)
13+ , EventTriggerRef (..)
14+ ) where
15+
16+import Control.Applicative (liftA2)
17+import Control.Concurrent
18+import Control.Monad.Exception
19+import Control.Monad.Primitive
20+import Control.Monad.Reader
21+import Control.Monad.Ref
22+import Data.Coerce
23+import Data.Dependent.Sum
24+import Data.IORef
25+import Data.Monoid ((<>))
26+import qualified Data.Semigroup as S
27+import Reflex.Class
28+import Reflex.Host.Class
29+import Reflex.PerformEvent.Class
30+import Reflex.PostBuild.Class
31+import Reflex.TriggerEvent.Class
32+
33+-- | A value with which to fire an 'Event', as well as a callback to invoke
34+-- after its propagation has completed.
35+data TriggerInvocation a = TriggerInvocation a (IO ())
36+
37+-- | A reference to an 'EventTrigger' suitable for firing with 'TriggerEventT'.
38+newtype EventTriggerRef t a = EventTriggerRef { unEventTriggerRef :: IORef (Maybe (EventTrigger t a)) }
39+
40+-- | A basic implementation of 'TriggerEvent'.
41+newtype TriggerEventT t m a = TriggerEventT { unTriggerEventT :: ReaderT (Chan [DSum (EventTriggerRef t) TriggerInvocation]) m a }
42+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
43+
44+-- | Run a 'TriggerEventT' action. The argument should be a 'Chan' into which
45+-- 'TriggerInvocation's can be passed; it is expected that some other thread
46+-- will be responsible for popping values out of the 'Chan' and firing their
47+-- 'EventTrigger's.
48+runTriggerEventT :: TriggerEventT t m a -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a
49+runTriggerEventT = runReaderT . unTriggerEventT
50+
51+instance MonadTrans (TriggerEventT t) where
52+ {-# INLINABLE lift #-}
53+ lift = TriggerEventT . lift
54+
55+instance PrimMonad m => PrimMonad (TriggerEventT t m) where
56+ type PrimState (TriggerEventT t m) = PrimState m
57+ {-# INLINABLE primitive #-}
58+ primitive = lift . primitive
59+
60+instance PerformEvent t m => PerformEvent t (TriggerEventT t m) where
61+ type Performable (TriggerEventT t m) = Performable m
62+ {-# INLINABLE performEvent_ #-}
63+ performEvent_ e = lift $ performEvent_ e
64+ {-# INLINABLE performEvent #-}
65+ performEvent e = lift $ performEvent e
66+
67+instance PostBuild t m => PostBuild t (TriggerEventT t m) where
68+ {-# INLINABLE getPostBuild #-}
69+ getPostBuild = lift getPostBuild
70+
71+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (TriggerEventT t m) where
72+ {-# INLINABLE newEventWithTrigger #-}
73+ newEventWithTrigger = lift . newEventWithTrigger
74+ {-# INLINABLE newFanEventWithTrigger #-}
75+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
76+
77+instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (TriggerEventT t m) where
78+ {-# INLINABLE newTriggerEvent #-}
79+ newTriggerEvent = do
80+ (e, t) <- newTriggerEventWithOnComplete
81+ return (e, \a -> t a $ return ())
82+ {-# INLINABLE newTriggerEventWithOnComplete #-}
83+ newTriggerEventWithOnComplete = do
84+ events <- askEvents
85+ (eResult, reResultTrigger) <- lift newEventWithTriggerRef
86+ return . (,) eResult $ \a cb ->
87+ writeChan events [EventTriggerRef reResultTrigger :=> TriggerInvocation a cb]
88+ {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
89+ newEventWithLazyTriggerWithOnComplete f = do
90+ events <- askEvents
91+ lift . newEventWithTrigger $ \t ->
92+ f $ \a cb -> do
93+ reResultTrigger <- newRef $ Just t
94+ writeChan events [EventTriggerRef reResultTrigger :=> TriggerInvocation a cb]
95+
96+instance MonadRef m => MonadRef (TriggerEventT t m) where
97+ type Ref (TriggerEventT t m) = Ref m
98+ {-# INLINABLE newRef #-}
99+ newRef = lift . newRef
100+ {-# INLINABLE readRef #-}
101+ readRef = lift . readRef
102+ {-# INLINABLE writeRef #-}
103+ writeRef r = lift . writeRef r
104+
105+instance MonadAtomicRef m => MonadAtomicRef (TriggerEventT t m) where
106+ {-# INLINABLE atomicModifyRef #-}
107+ atomicModifyRef r = lift . atomicModifyRef r
108+
109+instance MonadSample t m => MonadSample t (TriggerEventT t m) where
110+ {-# INLINABLE sample #-}
111+ sample = lift . sample
112+
113+instance MonadHold t m => MonadHold t (TriggerEventT t m) where
114+ {-# INLINABLE hold #-}
115+ hold v0 v' = lift $ hold v0 v'
116+ {-# INLINABLE holdDyn #-}
117+ holdDyn v0 v' = lift $ holdDyn v0 v'
118+ {-# INLINABLE holdIncremental #-}
119+ holdIncremental v0 v' = lift $ holdIncremental v0 v'
120+ {-# INLINABLE buildDynamic #-}
121+ buildDynamic a0 = lift . buildDynamic a0
122+ {-# INLINABLE headE #-}
123+ headE = lift . headE
124+
125+instance Adjustable t m => Adjustable t (TriggerEventT t m) where
126+ {-# INLINABLE runWithReplace #-}
127+ runWithReplace (TriggerEventT a0) a' = TriggerEventT $ runWithReplace a0 (coerceEvent a')
128+ {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}
129+ traverseIntMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseIntMapWithKeyWithAdjust (coerce . f) dm0 dm'
130+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
131+ traverseDMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjust (coerce . f) dm0 dm'
132+ {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}
133+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjustWithMove (coerce . f) dm0 dm'
134+
135+-- TODO: Monoid and Semigroup can likely be derived once ReaderT has them.
136+instance (Monoid a, Applicative m) => Monoid (TriggerEventT t m a) where
137+ mempty = pure mempty
138+ mappend = (<>)
139+
140+instance (S.Semigroup a, Applicative m) => S.Semigroup (TriggerEventT t m a) where
141+ (<>) = liftA2 (S.<>)
142+
143+
144+-- | Retrieve the current 'Chan'; event trigger invocations pushed into it will
145+-- be fired.
146+askEvents :: Monad m => TriggerEventT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])
147+askEvents = TriggerEventT ask
src/Reflex/TriggerEvent/Class.hsnew file+50
@@ -0,0 +1,50 @@
1+-- | This module defines 'TriggerEvent', which describes actions that may create
2+-- new 'Event's that can be triggered from 'IO'.
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE UndecidableInstances #-}
7+module Reflex.TriggerEvent.Class
8+ ( TriggerEvent (..)
9+ ) where
10+
11+import Reflex.Class
12+
13+import Control.Monad.Reader
14+import Control.Monad.State
15+import qualified Control.Monad.State.Strict as Strict
16+
17+--TODO: Shouldn't have IO hard-coded
18+-- | 'TriggerEvent' represents actions that can create 'Event's that can be
19+-- triggered by 'IO' actions.
20+class Monad m => TriggerEvent t m | m -> t where
21+ -- | Create a triggerable 'Event'. Whenever the resulting function is called,
22+ -- the resulting 'Event' will fire at some point in the future. Note that
23+ -- this may not be synchronous.
24+ newTriggerEvent :: m (Event t a, a -> IO ())
25+ -- | Like 'newTriggerEvent', but the callback itself takes another callback,
26+ -- to be invoked once the requested 'Event' occurrence has finished firing.
27+ -- This allows synchronous operation.
28+ newTriggerEventWithOnComplete :: m (Event t a, a -> IO () -> IO ()) --TODO: This and newTriggerEvent should be unified somehow
29+ -- | Like 'newTriggerEventWithOnComplete', but with setup and teardown. This
30+ -- relatively complex type signature allows any external listeners to be
31+ -- subscribed lazily and then removed whenever the returned 'Event' is no
32+ -- longer being listened to. Note that the setup/teardown may happen multiple
33+ -- times, and there is no guarantee that the teardown will be executed
34+ -- promptly, or even at all, in the case of program termination.
35+ newEventWithLazyTriggerWithOnComplete :: ((a -> IO () -> IO ()) -> IO (IO ())) -> m (Event t a)
36+
37+instance TriggerEvent t m => TriggerEvent t (ReaderT r m) where
38+ newTriggerEvent = lift newTriggerEvent
39+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
40+ 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
src/Reflex/Widget/Basic.hsnew file+42
@@ -0,0 +1,42 @@
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+import Reflex.Class
14+import Reflex.Patch.MapWithMove
15+
16+
17+-- | Build sortable content in such a way that re-sorting it can cause minimal
18+-- disruption to an existing context.
19+--
20+-- Naively re-sorting a list of images would destroy every image and add them back
21+-- in the new order. This framework is able to avoid that by preserving the
22+-- identity of each image and simply moving it to the new location.
23+--
24+-- Example:
25+--
26+-- > let sortByFst = buttonA $> comparing fst
27+-- > sortBySnd = buttonB $> comparing snd
28+-- > sortEvent = leftmost [sortByFst, sortBySnd]
29+-- > sortableList
30+-- > (\k v -> text $ "\n" ++ show k ++ " " ++ v) -- show each element on a new line
31+-- > (Map.fromList $ zip [0..] [(3, "a"), (2, "b"), (1, "c")])
32+-- > sortEvent
33+sortableList :: forall t m k v a. (MonadHold t m, MonadFix m, Adjustable t m, Ord k)
34+ => (k -> v -> m a) -- ^ Function to render the content for each key/value pair
35+ -> Map k v -- ^ The sortable list with an initial ordering determined by the @Map@ keys in ascending order
36+ -> Event t (v -> v -> Ordering) -- ^ An event carrying a sort function for the list
37+ -> m (Map k a)
38+sortableList f m0 reSortFunc = do
39+ rec let reSortPatch = attachWith (flip patchThatSortsMapWith) (currentIncremental m) reSortFunc
40+ m <- holdIncremental m0 reSortPatch
41+ (results, _) <- mapMapWithAdjustWithMove f m0 reSortPatch
42+ pure results
src/Reflex/Workflow.hsnew file+37
@@ -0,0 +1,37 @@
1+{-# LANGUAGE RecursiveDo #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+module Reflex.Workflow (
4+ -- * Workflows
5+ Workflow (..)
6+ , workflow
7+ , workflowView
8+ , mapWorkflow
9+ , mapWorkflowCheap
10+ ) where
11+
12+import Control.Arrow ((***))
13+import Control.Monad.Fix (MonadFix)
14+
15+import Reflex.Class
16+import Reflex.Network
17+import Reflex.NotReady.Class
18+import Reflex.PostBuild.Class
19+
20+newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }
21+
22+workflow :: forall t m a. (Reflex t, Adjustable t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a)
23+workflow w0 = do
24+ rec eResult <- networkHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult
25+ return $ fmap fst eResult
26+
27+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)
28+workflowView w0 = do
29+ rec eResult <- networkView . fmap unWorkflow =<< holdDyn w0 eReplace
30+ eReplace <- fmap switch $ hold never $ fmap snd eResult
31+ return $ fmap fst eResult
32+
33+mapWorkflow :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b
34+mapWorkflow f (Workflow x) = Workflow (fmap (f *** fmap (mapWorkflow f)) x)
35+
36+mapWorkflowCheap :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b
37+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/EventWriterT.hsnew file+45
@@ -0,0 +1,45 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE GADTs #-}
3+module Main where
4+
5+import Control.Lens
6+import Control.Monad
7+import Data.These
8+
9+import Reflex
10+import Reflex.EventWriter.Base
11+import Test.Run
12+
13+main :: IO ()
14+main = do
15+ os1@[[Just [10,9,8,7,6,5,4,3,2,1]]] <- runApp' (unwrapApp testOrdering) $
16+ [ Just ()
17+ ]
18+ print os1
19+ os2@[[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]]
20+ <- runApp' (unwrapApp testSimultaneous) $ map Just $
21+ [ This ()
22+ , That ()
23+ , This ()
24+ , These () ()
25+ ]
26+ print os2
27+ return ()
28+
29+unwrapApp :: (Reflex t, Monad m) => (a -> EventWriterT t [Int] m ()) -> a -> m (Event t [Int])
30+unwrapApp x appIn = do
31+ ((), e) <- runEventWriterT $ x appIn
32+ return e
33+
34+testOrdering :: (Reflex t, Monad m) => Event t () -> EventWriterT t [Int] m ()
35+testOrdering pulse = do
36+ forM_ [10,9..1] $ \i -> tellEvent ([i] <$ pulse)
37+ return ()
38+
39+testSimultaneous :: (Reflex t, Adjustable t m, MonadHold t m) => Event t (These () ()) -> EventWriterT t [Int] m ()
40+testSimultaneous pulse = do
41+ let e0 = fmapMaybe (^? here) pulse
42+ e1 = fmapMaybe (^? there) pulse
43+ forM_ [1,3..9] $ \i -> runWithReplace (tellEvent ([i] <$ e0)) $ ffor e1 $ \_ -> tellEvent ([i+1] <$ e0)
44+ return ()
45+
test/GC.hsnew file+100
@@ -0,0 +1,100 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE GADTs #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE RankNTypes #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE TypeFamilies #-}
7+module Main where
8+
9+import Control.Monad
10+import Control.Monad.IO.Class
11+import Control.Monad.Ref
12+import Data.Align
13+import Data.Dependent.Map (DMap)
14+import qualified Data.Dependent.Map as DMap
15+import Data.Dependent.Sum
16+import Data.Functor.Identity
17+import Data.GADT.Compare
18+import Data.IORef
19+import Data.Semigroup
20+import Data.These
21+
22+import Data.Functor.Misc
23+import Reflex.Patch
24+
25+import qualified Reflex.Host.Class as Host
26+import qualified Reflex.Spider.Internal as S
27+
28+import System.Exit
29+import System.Mem
30+
31+main :: IO ()
32+main = do
33+ ref <- newIORef Nothing
34+ hostPerf ref
35+ readIORef ref >>= maybe exitFailure (putStrLn . ("Result " <>) . show)
36+
37+hostPerf :: IORef (Maybe Int) -> IO ()
38+hostPerf ref = S.runSpiderHost $ do
39+ ---- body
40+ liftIO $ putStrLn "#creating triggers"
41+ (response', responseTrigger) <- Host.newEventWithTriggerRef
42+ (eadd', addTriggerRef) <- Host.newEventWithTriggerRef
43+ let response = S.unSpiderEvent response'
44+ eadd = S.unSpiderEvent eadd'
45+ liftIO $ putStrLn "#creating event graph"
46+ eventToPerform <- Host.runHostFrame $ do
47+ (reqMap :: S.Event S.Global (DMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) Identity))
48+ <- S.SpiderHostFrame
49+ $ fmap ( S.merge
50+ . S.dynamicHold)
51+ $ S.hold DMap.empty
52+ -- Construct a new heap object for the subscriber, invalidating any weak references to the subscriber if they are not retained
53+ $ (\e -> S.Event $ \sub -> do
54+ (s, o) <- S.subscribeAndRead e $ sub
55+ { S.subscriberPropagate = S.subscriberPropagate sub
56+ }
57+ return (s, o))
58+ $ runIdentity <$> S.select
59+ (S.fan $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response)
60+ (WrapArg Request)
61+ return $ alignWith (mergeThese (<>))
62+ (flip S.pushCheap eadd $ \_ -> return $ Just $ DMap.singleton Request $ do
63+ liftIO $ putStrLn "#eadd fired"
64+ return $ PatchDMap $ DMap.singleton (Const2 (1 :: Int)) $ ComposeMaybe $ Just
65+ $ S.pushCheap (return . Just . DMap.singleton Action . (\_ -> liftIO (writeIORef ref (Just 1)))) $ eadd)
66+ (flip S.pushCheap reqMap $ \m -> return $ Just $ mconcat $ (\(Const2 _ :=> Identity reqs) -> reqs) <$> DMap.toList m)
67+ ---- epilogue
68+ eventToPerformHandle <- Host.subscribeEvent (S.SpiderEvent eventToPerform)
69+ liftIO $ putStrLn "#performing GC" >> performMajorGC
70+ liftIO $ putStrLn "#attempting to fire eadd"
71+ mAddTrigger <- readRef addTriggerRef
72+ forM_ mAddTrigger $ \t -> replicateM_ 2 $ do
73+ liftIO $ putStrLn "#firing eadd"
74+ mToPerform <- Host.fireEventsAndRead [t :=> Identity ()] $ sequence =<< Host.readEvent eventToPerformHandle
75+ case mToPerform of
76+ Nothing -> return ()
77+ Just toPerform -> do
78+ responses <- Host.runHostFrame $ DMap.traverseWithKey (\_ v -> Identity <$> v) toPerform
79+ mrt <- readRef responseTrigger
80+ let followupEventTriggers = case mrt of
81+ Just rt -> [rt :=> Identity responses]
82+ Nothing -> []
83+ Host.fireEventsAndRead followupEventTriggers $ return ()
84+ return ()
85+ return ()
86+
87+data Tell a where
88+ Action :: Tell ()
89+ Request :: Tell (PatchDMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) (S.Event S.Global))
90+
91+instance GEq Tell where
92+ geq Action Action = Just Refl
93+ geq Request Request = Just Refl
94+ geq _ _ = Nothing
95+
96+instance GCompare Tell where
97+ gcompare Action Action = GEQ
98+ gcompare Request Request = GEQ
99+ gcompare Action Request = GLT
100+ gcompare Request Action = GGT
test/QueryT.hsnew file+131
@@ -0,0 +1,131 @@
1+{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+{-# LANGUAGE LambdaCase #-}
5+{-# LANGUAGE RankNTypes #-}
6+{-# LANGUAGE TypeFamilies #-}
7+
8+import Control.Lens
9+import Control.Monad.Fix
10+import Data.Align
11+import Data.AppendMap (AppendMap)
12+import qualified Data.AppendMap as AMap
13+import Data.Functor.Misc
14+import Data.Map (Map)
15+import qualified Data.Map as Map
16+import Data.Semigroup
17+import Data.These
18+
19+import Reflex
20+import Reflex.Patch.MapWithMove
21+import Test.Run
22+
23+newtype MyQuery = MyQuery SelectedCount
24+ deriving (Show, Read, Eq, Ord, Monoid, Semigroup, Additive, Group)
25+
26+instance Query MyQuery where
27+ type QueryResult MyQuery = ()
28+ crop _ _ = ()
29+
30+instance (Ord k, Query a, Eq (QueryResult a)) => Query (Selector k a) where
31+ type QueryResult (Selector k a) = Selector k (QueryResult a)
32+ crop q r = undefined
33+
34+newtype Selector k a = Selector { unSelector :: AppendMap k a }
35+ deriving (Show, Read, Eq, Ord, Functor)
36+
37+instance (Ord k, Eq a, Monoid a) => Semigroup (Selector k a) where
38+ (Selector a) <> (Selector b) = Selector $ fmapMaybe id $ f a b
39+ where
40+ f = alignWith $ \case
41+ This x -> Just x
42+ That y -> Just y
43+ These x y ->
44+ let z = x `mappend` y
45+ in if z == mempty then Nothing else Just z
46+
47+instance (Ord k, Eq a, Monoid a) => Monoid (Selector k a) where
48+ mempty = Selector AMap.empty
49+ mappend = (<>)
50+
51+instance (Eq a, Ord k, Group a) => Group (Selector k a) where
52+ negateG = fmap negateG
53+
54+instance (Eq a, Ord k, Group a) => Additive (Selector k a)
55+
56+main :: IO ()
57+main = do
58+ [0, 1, 1, 0] <- fmap (map fst . concat) $
59+ runApp (testQueryT testRunWithReplace) () $ map (Just . That) $
60+ [ That (), This (), That () ]
61+ [0, 1, 1, 0] <- fmap (map fst . concat) $
62+ runApp (testQueryT testSequenceDMapWithAdjust) () $ map (Just . That) $
63+ [ That (), This (), That () ]
64+ [0, 1, 1, 0] <- fmap (map fst . concat) $
65+ runApp (testQueryT testSequenceDMapWithAdjustWithMove) () $ map (Just . That) $
66+ [ That (), This (), That () ]
67+ return ()
68+
69+testQueryT :: (Reflex t, MonadFix m)
70+ => (Event t () -> Event t () -> QueryT t (Selector Int MyQuery) m ())
71+ -> AppIn t () (These () ())
72+ -> m (AppOut t Int Int)
73+testQueryT w (AppIn _ pulse) = do
74+ let replace = fmapMaybe (^? here) pulse
75+ increment = fmapMaybe (^? there) pulse
76+ (_, q) <- runQueryT (w replace increment) $ pure mempty
77+ let qDyn = head . AMap.keys . unSelector <$> incrementalToDynamic q
78+ return $ AppOut
79+ { _appOut_behavior = current qDyn
80+ , _appOut_event = updated qDyn
81+ }
82+
83+testRunWithReplace :: ( Reflex t
84+ , Adjustable t m
85+ , MonadHold t m
86+ , MonadFix m
87+ , MonadQuery t (Selector Int MyQuery) m)
88+ => Event t ()
89+ -> Event t ()
90+ -> m ()
91+testRunWithReplace replace increment = do
92+ let w = do
93+ n <- count increment
94+ queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1
95+ _ <- runWithReplace w $ w <$ replace
96+ return ()
97+
98+testSequenceDMapWithAdjust :: ( Reflex t
99+ , Adjustable t m
100+ , MonadHold t m
101+ , MonadFix m
102+ , MonadQuery t (Selector Int MyQuery) m)
103+ => Event t ()
104+ -> Event t ()
105+ -> m ()
106+testSequenceDMapWithAdjust replace increment = do
107+ _ <- listHoldWithKey (Map.singleton () ()) (Map.singleton () (Just ()) <$ replace) $ \_ _ -> do
108+ n <- count increment
109+ queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1
110+ return ()
111+
112+testSequenceDMapWithAdjustWithMove :: ( Reflex t
113+ , Adjustable t m
114+ , MonadHold t m
115+ , MonadFix m
116+ , MonadQuery t (Selector Int MyQuery) m)
117+ => Event t ()
118+ -> Event t ()
119+ -> m ()
120+testSequenceDMapWithAdjustWithMove replace increment = do
121+ _ <- listHoldWithKeyWithMove (Map.singleton () ()) (Map.singleton () (Just ()) <$ replace) $ \_ _ -> do
122+ n <- count increment
123+ queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1
124+ return ()
125+
126+-- scam it out to test traverseDMapWithAdjustWithMove
127+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))
128+listHoldWithKeyWithMove m0 m' f = do
129+ (n0, n') <- mapMapWithAdjustWithMove f m0 $ ffor m' $ PatchMapWithMove . Map.map (\v -> NodeInfo (maybe From_Delete From_Insert v) Nothing)
130+ incrementalToDynamic <$> holdIncremental n0 n'
131+-- -}
test/Reflex/Bench/Focused.hsnew file+369
@@ -0,0 +1,369 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE RankNTypes #-}
7+{-# LANGUAGE RecursiveDo #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE TupleSections #-}
10+{-# LANGUAGE TypeSynonymInstances #-}
11+
12+module Reflex.Bench.Focused where
13+
14+import Reflex
15+import Reflex.TestPlan
16+
17+import Control.Applicative
18+import Control.Monad
19+import Control.Monad.Fix
20+import Control.Monad.Identity
21+import Data.Traversable (for, traverse)
22+
23+import qualified Data.Dependent.Map as DMap
24+import Data.Map (Map)
25+import qualified Data.Map as Map
26+import Data.Maybe
27+
28+import Data.Functor.Misc
29+
30+import Data.List
31+import Data.List.Split
32+import Data.Tuple
33+
34+import Data.Monoid
35+import Data.Word
36+
37+import Control.DeepSeq
38+
39+import Prelude hiding (concat, sum)
40+
41+
42+mergeTree :: Num a => (Monoid (f [a]), Functor f) => Int -> [f a] -> f a
43+mergeTree n es | length es <= n = sum' es
44+ | otherwise = mergeTree n subTrees
45+ where
46+ merges = chunksOf n es
47+ subTrees = map sum' merges
48+ sum' = fmap sum . mconcat . fmap (fmap (:[]) )
49+
50+mergeListDyn :: Reflex t => [Dynamic t a] -> Dynamic t [a]
51+mergeListDyn = mconcat . fmap (fmap pure)
52+
53+mergeTreeDyn :: (Num a, Reflex t) => Int -> [Dynamic t a] -> Dynamic t a
54+mergeTreeDyn n dyns | length dyns <= n = sumDyns dyns
55+ | otherwise = mergeTreeDyn n $ fmap sumDyns merges
56+ where
57+ merges = chunksOf n dyns
58+ sumDyns = fmap sum . mergeListDyn
59+
60+
61+
62+-- N events all firing for N frames
63+continuous :: TestPlan t m => Word -> Word -> m [Event t Word]
64+continuous n frames = for [1..n] $ \i -> plan $ (, i) <$> [1..frames]
65+
66+-- Fire N events once every P frames for total N frames (interspersed evenly)
67+occasional :: TestPlan t m => Word -> Word -> Word -> m [Event t Word]
68+occasional n period frames = traverse plan $ zipWith occs [1..] phases
69+ where
70+ phases = take (fromIntegral n) $ concat (repeat [1..period])
71+ occs i phase = (, i) <$> [1, phase+1..frames]
72+
73+
74+
75+-- Event which never fires (but isn't 'never')
76+never' :: TestPlan t m => m (Event t Word)
77+never' = plan []
78+
79+
80+-- Event which fires once on first frame
81+event :: TestPlan t m => m (Event t Word)
82+event = plan [(1, 0)]
83+
84+-- Event which fires constantly over N frames
85+events :: TestPlan t m => Word -> m (Event t Word)
86+events n = plan $ (\i -> (i, i)) <$> [1..n]
87+
88+
89+-- N events all originating from one event
90+fmapFan :: Reflex t => Word -> Event t Word -> [Event t Word]
91+fmapFan n e = (\i -> (+i) <$> e) <$> [1..n]
92+
93+
94+-- Make a fan using the value in the event converting it to a singleton Map
95+-- use a fan of size n (key is the value mod n)
96+fanMerge :: Reflex t => Word -> Event t Word -> Event t Word
97+fanMerge n e = leftmost $ s <$> [0..n - 1] where
98+ s k = select f (Const2 k)
99+ f = fan (toMap <$> e)
100+ toMap k = DMap.singleton (Const2 $ k `mod` n) (Identity k)
101+
102+-- Dumb version of the above using simple fmapMaybe to filter
103+fmapFanMerge :: Reflex t => Word -> Event t Word -> Event t Word
104+fmapFanMerge n e = leftmost $ s <$> [0..n - 1] where
105+ s k = flip fmapMaybe e $ \j -> if k == j `mod` n
106+ then Just k
107+ else Nothing
108+
109+
110+
111+-- Create an Event with a Map which is dense to size N
112+denseMap :: TestPlan t m => Word -> m (Event t (Map Word Word))
113+denseMap n = plan [(1, m)] where
114+ m = Map.fromList $ zip [1..n] [1..n]
115+
116+iter :: (a -> a) -> Word -> a -> a
117+iter _ 0 a = a
118+iter f n a = iter f (n - 1) (f a)
119+
120+iterM :: Monad m => (a -> m a) -> Word -> a -> m a
121+iterM _ 0 a = return a
122+iterM f n a = iterM f (n - 1) =<< f a
123+
124+fmapChain :: (Functor f) => Word -> f Word -> f Word
125+fmapChain = iter (fmap (+1))
126+
127+mapDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
128+mapDynChain = iterM (return . fmap (+1))
129+
130+joinDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
131+joinDynChain = iterM (\d -> return $ join $ fmap (const d) d)
132+
133+combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
134+combineDynChain = iterM (\d -> return $ zipDynWith (+) d d)
135+
136+pingPong :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> Event t a -> m (Event t a)
137+pingPong e1 e2 = do
138+ rec
139+ d <- foldDyn (const swap) (e1, e2) e
140+ let e = switch (fst <$> current d)
141+ return e
142+
143+switchFactors :: (Reflex t, MonadHold t m) => Word -> Event t Word -> m (Event t Word)
144+switchFactors 0 e = return e
145+switchFactors i e = do
146+ b <- hold ((+1) <$> e) (e <$ ffilter ((== 0) . (i `mod`)) e)
147+ switchFactors (i - 1) (switch b)
148+
149+
150+switchChain :: (Reflex t, MonadHold t m, MonadFix m) => Word -> Event t Word -> m (Event t Word)
151+switchChain = iterM (\e -> pingPong e ((+1) <$> e))
152+
153+
154+switchChain2 :: (Reflex t, MonadHold t m, MonadFix m) => Word -> Event t Word -> m (Event t Word)
155+switchChain2 = iterM (\e -> pingPong e ((+1) <$> leftmost [e, e]))
156+
157+switchPromptlyChain :: (Reflex t, MonadHold t m) => Word -> Event t Word -> m (Event t Word)
158+switchPromptlyChain = iterM $ \e ->
159+ switchPromptlyDyn <$> holdDyn e (e <$ e)
160+
161+
162+coinChain :: Reflex t => Word -> Event t Word -> Event t Word
163+coinChain = iter $ \e -> coincidence (e <$ e)
164+
165+fanMergeChain :: Reflex t => Word -> Word -> Event t Word -> Event t Word
166+fanMergeChain width = iter $ fanMerge width
167+
168+fmapFanMergeChain :: Reflex t => Word -> Word -> Event t Word -> Event t Word
169+fmapFanMergeChain width = iter $ fmapFanMerge width
170+
171+-- | Data type for a collection (a map) which is updated by providing differences
172+data UpdatedMap t k a = UpdatedMap (Map k a) (Event t (Map k (Maybe a)))
173+
174+-- This will hopefully become a primitive (faster!)
175+switchMergeEvents :: (MonadFix m, MonadHold t m, Reflex t, Ord k) => UpdatedMap t k (Event t a) -> m (Event t (Map k a))
176+switchMergeEvents mapChanges = switch . fmap mergeMap <$> holdMap mapChanges
177+
178+-- switchMergeMaybe :: (MonadFix m, MonadHold t m, Reflex t, Ord k) => UpdatedMap t k (Event t a) -> m (Event t (Map k a))
179+-- switchMergeMaybe (UpdatedMap initial changes) = switchMergeMap initial (fmap (fromMaybe never) <$> changes)
180+
181+switchMergeBehaviors :: forall a t m k. (MonadFix m, MonadHold t m, Reflex t, Ord k) => UpdatedMap t k (Behavior t a) -> m (Behavior t (Map k a))
182+switchMergeBehaviors mapChanges = pull . joinMap <$> holdMap mapChanges
183+ where joinMap m = traverse sample =<< sample m
184+
185+-- | Turn an UpdatedMap into a Dynamic by applying the differences to the initial value
186+holdMapDyn :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => UpdatedMap t k a -> m (Dynamic t (Map k a))
187+holdMapDyn (UpdatedMap initial changes) = foldDyn (flip (Map.foldWithKey modify)) initial changes
188+
189+ where
190+ modify k Nothing items = Map.delete k items
191+ modify k (Just item) items = Map.insert k item items
192+
193+
194+-- | Hold an UpdatedMap as a behavior by applying differences to the initial value
195+holdMap :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => UpdatedMap t k a -> m (Behavior t (Map k a))
196+holdMap = (current <$>) . holdMapDyn
197+
198+
199+increasingMerge :: TestPlan t m => [a] -> m (UpdatedMap t Int a)
200+increasingMerge xs = do
201+ e <- planList (zipWith Map.singleton [1..] (Just <$> xs) ++ [reset])
202+ return (UpdatedMap Map.empty e)
203+ where
204+ reset = Map.fromList $ zip [1..] (const Nothing <$> xs)
205+
206+decreasingMerge :: (TestPlan t m) => [a] -> m (UpdatedMap t Int a)
207+decreasingMerge xs = do
208+ e <- planList (zipWith Map.singleton [1..] (const Nothing <$> xs) ++ [reset])
209+ return (UpdatedMap initial e)
210+ where
211+ initial = Map.fromList $ zip [1..] xs
212+ reset = Just <$> initial
213+
214+modifyMerge :: (TestPlan t m) => [a] -> m (UpdatedMap t Int a)
215+modifyMerge xs = do
216+ e <- planList $ zipWith Map.singleton [1..] (Just <$> xs)
217+ return (UpdatedMap initial e)
218+ where
219+ initial = Map.fromList $ zip [1..] xs
220+
221+
222+countMany :: (Reflex t, MonadHold t m, MonadFix m) => [Event t a] -> m [Behavior t Int]
223+countMany = traverse (fmap current . count)
224+
225+countManyDyn :: (Reflex t, MonadHold t m, MonadFix m) => [Event t a] -> m [Dynamic t Int]
226+countManyDyn = traverse count
227+
228+
229+-- Given a function which creates a sub-network (from a single event)
230+-- Create a plan which uses a switch to substitute it
231+switches :: TestPlan t m => Word -> (forall n. (MonadHold t n, MonadFix n) => Event t Word -> n (Event t a)) -> m (Event t a)
232+switches numFrames f = do
233+ es <- events numFrames
234+ switch <$> hold never (makeEvents es)
235+
236+ where
237+ makeEvents es = pushAlways (\n -> f (fmap (+n) es)) es
238+
239+
240+
241+-- Two sets of benchmarks, one which we're interested in testing subscribe time (as well as time to fire frames)
242+-- the other, which we're only interested in time for running frames
243+subscribing :: Word -> Word -> [(String, TestCase)]
244+subscribing n frames =
245+ [ testSub "fmapFanMerge" $ return . mergeList . fmapFan n
246+ , testSub "fanMerge" $ return . fanMerge n
247+ , testSub "fmapFan/mergeTree" $ return . mergeTree 8 . fmapFan n
248+ , testSub "fmapChain" $ return . fmapChain n
249+ , testSub "switchChain" $ switchChain n
250+ , testSub "switchPromptlyChain" $ switchPromptlyChain n
251+ , testSub "switchFactors" $ switchFactors n
252+ , testSub "coincidenceChain" $ return . coinChain n
253+ ]
254+
255+ where
256+ testSub :: (Eq a, Show a, NFData a) => String -> (forall t n. (Reflex t, MonadHold t n, MonadFix n) => Event t Word -> n (Event t a)) -> (String, TestCase)
257+ testSub name test = testE name (switches frames test)
258+
259+-- Set of benchmark to test specifically merging dynamic collections
260+-- a pattern which occurs frequently in reflex-dom collections
261+merging :: Word -> [(String, TestCase)]
262+merging n =
263+ [ testE "static events" $ mergeList <$> sparse
264+ , testE "increasing events" $ switchMergeEvents =<< increasingMerge =<< sparse
265+ , testE "decreasing events" $ switchMergeEvents =<< decreasingMerge =<< sparse
266+ , testE "modify events" $ switchMergeEvents =<< modifyMerge =<< sparse
267+
268+ , testB "static behaviors" $ pull . traverse sample <$> counters
269+ , testB "increasing behaviors" $ switchMergeBehaviors =<< increasingMerge =<< counters
270+ , testB "decreasing behaviors" $ switchMergeBehaviors =<< decreasingMerge =<< counters
271+ , testB "modify behaviors" $ switchMergeBehaviors =<< modifyMerge =<< counters
272+
273+
274+ -- , testE "increasing events/switchMerge" $ switchMergeMaybe =<< increasingMerge =<< sparse
275+ -- , testE "decreasing events/switchMerge" $ switchMergeMaybe =<< decreasingMerge =<< sparse
276+ -- , testE "modify events/switchMerge" $ switchMergeMaybe =<< modifyMerge =<< sparse
277+ ]
278+
279+ where
280+ sparse :: TestPlan t m => m [Event t Word]
281+ sparse = fmap (fmap (+1)) <$> occasional n 8 n
282+
283+ counters :: TestPlan t m => m [Behavior t Int]
284+ counters = countMany =<< sparse
285+
286+
287+
288+fans :: Word -> [(String, TestCase)]
289+fans n =
290+ [ testE "fanMapChain" $ fanMergeChain n 10 <$> e
291+ , testE "fmapFanMapChain" $ fmapFanMergeChain n 10 <$> e
292+
293+ , testE "fanMerge " $ fanMerge n <$> events n
294+
295+ , testE "fmapFanMerge " $ fmapFanMerge n <$> events n
296+ , testE "triggerMerge" $ leftmost <$> for [1..n] (\i -> plan [(i, i)])
297+
298+ ]
299+ where
300+
301+ e :: TestPlan t m => m (Event t Word)
302+ e = events 100
303+
304+
305+
306+
307+dynamics :: Word -> [(String, TestCase)]
308+dynamics n =
309+ [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d
310+ , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d
311+ , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d
312+ , testE "dense mergeTree" $ fmap (updated . mergeTreeDyn 8) dense
313+ , testE "sparse mergeTree" $ fmap (updated . mergeTreeDyn 8) sparse
314+ , testE "mergeDyn" $ fmap (updated . fmap sum . mergeListDyn) sparse
315+ ] where
316+
317+ d :: TestPlan t m => m (Dynamic t Word)
318+ d = count =<< events 10
319+
320+ sparse, dense :: TestPlan t m => m [Dynamic t Int]
321+ sparse = countManyDyn =<< occasional n 8 16
322+ dense = countManyDyn =<< continuous n 2
323+
324+
325+firing :: Word -> [(String, TestCase)]
326+firing n =
327+ [ testE "fmapChain" $ fmapChain n <$> e
328+ , testE "switchChain2" $ switchChain2 n =<< e
329+ , testE "switchPromptlyChain" $ switchPromptlyChain n =<< e
330+ , testE "switchFactors" $ switchFactors n =<< e
331+ , testE "coincidenceChain" $ coinChain n <$> e
332+
333+ , testE "dense mergeTree" $ mergeTree 8 <$> dense
334+ , testE "sparse mergeTree" $ mergeTree 8 <$> sparse
335+
336+ -- Triggers test failure in Spider
337+ --, testE "runFrame" $ events n
338+
339+ , testB "sum counters" $ do
340+ counts <- counters
341+ return $ pull $ sum <$> traverse sample counts
342+
343+ , testB "pullChain" $ fmapChain n . current <$> (count =<< events 4)
344+ , testB "pullChain2" $ do
345+ es <- events 4
346+ e' <- plan [(0, ())]
347+
348+ b <- hold (constant 0) $
349+ pushAlways (const $ fmapChain n <$> hold 0 es) e'
350+
351+ return (join b)
352+ , testB "counters/pullTree" $ mergeTree 8 <$> counters
353+
354+ ]
355+ where
356+ e :: TestPlan t m => m (Event t Word)
357+ e = events 10
358+
359+ dense, sparse :: TestPlan t m => m [Event t Word]
360+ dense = continuous n 2
361+ sparse = occasional n 8 16
362+
363+ counters :: TestPlan t m => m [Behavior t Int]
364+ counters = countMany =<< sparse
365+
366+
367+
368+
369+
test/Reflex/Plan/Pure.hsnew file+72
@@ -0,0 +1,72 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE RankNTypes #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+
9+module Reflex.Plan.Pure where
10+
11+import Reflex
12+import Reflex.Pure
13+import Reflex.TestPlan
14+
15+import Control.Applicative
16+import Control.Monad.Fix
17+import Control.Monad.State
18+import Data.IntMap (IntMap)
19+import qualified Data.IntMap as IntMap
20+import Data.IntSet (IntSet)
21+import qualified Data.IntSet as IntSet
22+
23+import Data.Bifunctor
24+import Data.Maybe
25+import Data.Monoid
26+import Prelude
27+
28+
29+mapToPureEvent :: IntMap a -> Event (Pure Int) a
30+mapToPureEvent m = Event $ flip IntMap.lookup m
31+
32+type TimeM = (->) Int
33+newtype PurePlan a = PurePlan { unPlan :: StateT IntSet TimeM a } deriving (Functor, Applicative, Monad, MonadFix)
34+
35+liftPlan :: TimeM a -> PurePlan a
36+liftPlan = PurePlan . lift
37+
38+instance MonadHold (Pure Int) PurePlan where
39+ hold initial = liftPlan . hold initial
40+ holdDyn initial = liftPlan . holdDyn initial
41+ holdIncremental initial = liftPlan . holdIncremental initial
42+ buildDynamic getInitial = liftPlan . buildDynamic getInitial
43+ headE = liftPlan . headE
44+
45+instance MonadSample (Pure Int) PurePlan where
46+ sample = liftPlan . sample
47+
48+
49+instance TestPlan (Pure Int) PurePlan where
50+ plan occs = do
51+ PurePlan . modify $ IntSet.union (IntMap.keysSet m)
52+ return $ mapToPureEvent m
53+ where m = IntMap.fromList (first fromIntegral <$> occs)
54+
55+runPure :: PurePlan a -> (a, IntSet)
56+runPure (PurePlan p) = runStateT p mempty $ 0
57+
58+relavantTimes :: IntSet -> IntSet
59+relavantTimes occs = IntSet.fromList [0..l + 1]
60+ where l = fromMaybe 0 (fst <$> IntSet.maxView occs)
61+
62+testBehavior :: (Behavior (Pure Int) a, IntSet) -> IntMap a
63+testBehavior (b, occs) = IntMap.fromSet (sample b) (relavantTimes occs)
64+
65+testEvent :: (Event (Pure Int) a, IntSet) -> IntMap (Maybe a)
66+testEvent (Event readEvent, occs) = IntMap.fromSet readEvent (relavantTimes occs)
67+
68+
69+
70+
71+
72+
test/Reflex/Plan/Reflex.hsnew file+135
@@ -0,0 +1,135 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE RankNTypes #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE StandaloneDeriving #-}
10+{-# LANGUAGE UndecidableInstances #-}
11+module Reflex.Plan.Reflex
12+ ( TestPlan(..)
13+ , runPlan
14+ , Plan (..)
15+ , Schedule
16+ , Firing (..)
17+ , MonadIORef
18+
19+
20+ , readSchedule
21+ , readSchedule_
22+ , testSchedule
23+ , readEvent'
24+ , makeDense
25+
26+ , runTestE
27+ , runTestB
28+
29+ ) where
30+
31+import Reflex.Class
32+import Reflex.Host.Class
33+import Reflex.TestPlan
34+
35+import Control.Applicative
36+import Control.Monad
37+import Control.Monad.Identity
38+import Control.Monad.State.Strict
39+
40+import Control.Monad.Ref
41+import Data.Dependent.Sum (DSum (..))
42+import qualified Data.IntMap.Strict as IntMap
43+import Data.Maybe
44+import Data.Monoid
45+import Data.Traversable (sequenceA, traverse)
46+
47+import Control.DeepSeq
48+import Control.Exception
49+import Data.IntMap.Strict (IntMap)
50+import Data.IORef
51+import System.Mem
52+
53+-- Note: this import must come last to silence warnings from AMP
54+import Prelude
55+
56+type MonadIORef m = (MonadIO m, MonadRef m, Ref m ~ Ref IO)
57+
58+data Firing t where
59+ Firing :: IORef (Maybe (EventTrigger t a)) -> a -> Firing t
60+
61+
62+type Schedule t = IntMap [Firing t]
63+
64+-- Implementation of a TestPlan in terms of ReflexHost
65+newtype Plan t a = Plan (StateT (Schedule t) (HostFrame t) a)
66+
67+deriving instance ReflexHost t => Functor (Plan t)
68+deriving instance ReflexHost t => Applicative (Plan t)
69+deriving instance ReflexHost t => Monad (Plan t)
70+
71+deriving instance ReflexHost t => MonadSample t (Plan t)
72+deriving instance ReflexHost t => MonadHold t (Plan t)
73+deriving instance ReflexHost t => MonadFix (Plan t)
74+
75+
76+instance (ReflexHost t, MonadRef (HostFrame t), Ref (HostFrame t) ~ Ref IO) => TestPlan t (Plan t) where
77+ plan occurances = Plan $ do
78+ (e, ref) <- newEventWithTriggerRef
79+ modify (IntMap.unionWith mappend (firings ref))
80+ return e
81+
82+ where
83+ firings ref = IntMap.fromList (makeFiring ref <$> occurances)
84+ makeFiring ref (t, a) = (fromIntegral t, [Firing ref a])
85+
86+
87+firingTrigger :: (MonadReflexHost t m, MonadIORef m) => Firing t -> m (Maybe (DSum (EventTrigger t) Identity))
88+firingTrigger (Firing ref a) = fmap (:=> Identity a) <$> readRef ref
89+
90+runPlan :: (MonadReflexHost t m) => Plan t a -> m (a, Schedule t)
91+runPlan (Plan p) = runHostFrame $ runStateT p mempty
92+
93+
94+makeDense :: Schedule t -> Schedule t
95+makeDense s = fromMaybe (emptyRange 0) $ do
96+ (end, _) <- fst <$> IntMap.maxViewWithKey s
97+ return $ IntMap.union s (emptyRange end)
98+ where
99+ emptyRange end = IntMap.fromList (zip [0..end + 1] (repeat []))
100+
101+
102+-- For the purposes of testing, we add in a zero frame and extend one frame (to observe changes to behaviors
103+-- after the last event)
104+-- performGC is called at each frame to test for GC issues
105+testSchedule :: (MonadReflexHost t m, MonadIORef m, NFData a) => Schedule t -> ReadPhase m a -> m (IntMap a)
106+testSchedule schedule readResult = IntMap.traverseWithKey (\t occs -> liftIO performGC *> triggerFrame readResult t occs) (makeDense schedule)
107+
108+readSchedule :: (MonadReflexHost t m, MonadIORef m, NFData a) => Schedule t -> ReadPhase m a -> m (IntMap a)
109+readSchedule schedule readResult = IntMap.traverseWithKey (triggerFrame readResult) schedule
110+
111+readSchedule_ :: (MonadReflexHost t m, MonadIORef m, NFData a) => Schedule t -> ReadPhase m a -> m ()
112+readSchedule_ schedule readResult = mapM_ (uncurry $ triggerFrame readResult) $ IntMap.toList schedule
113+
114+triggerFrame :: (MonadReflexHost t m, MonadIORef m, NFData a) => ReadPhase m a -> Int -> [Firing t] -> m a
115+triggerFrame readResult _ occs = do
116+ triggers <- catMaybes <$> traverse firingTrigger occs
117+ liftIO . evaluate . force =<< fireEventsAndRead triggers readResult
118+
119+readEvent' :: MonadReadEvent t m => EventHandle t a -> m (Maybe a)
120+readEvent' = readEvent >=> sequenceA
121+
122+
123+-- Convenience functions for running tests producing Events/Behaviors
124+runTestB :: (MonadReflexHost t m, MonadIORef m, NFData a) => Plan t (Behavior t a) -> m (IntMap a)
125+runTestB p = do
126+ (b, s) <- runPlan p
127+ testSchedule s $ sample b
128+
129+runTestE :: (MonadReflexHost t m, MonadIORef m, NFData a) => Plan t (Event t a) -> m (IntMap (Maybe a))
130+runTestE p = do
131+ (e, s) <- runPlan p
132+ h <- subscribeEvent e
133+ testSchedule s (readEvent' h)
134+
135+
test/Reflex/Test.hsnew file+66
@@ -0,0 +1,66 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE RankNTypes #-}
7+
8+module Reflex.Test
9+ ( testAgreement
10+ , compareResult
11+ , runTests
12+
13+ , module Reflex.TestPlan
14+
15+ ) where
16+
17+import Reflex.Spider
18+
19+import Reflex.TestPlan
20+
21+import Reflex.Plan.Pure
22+import Reflex.Plan.Reflex
23+
24+import Control.Monad
25+import Data.Monoid
26+
27+import Data.IntMap (IntMap)
28+
29+--import Data.Foldable
30+import System.Exit
31+
32+import Prelude
33+
34+
35+testAgreement :: TestCase -> IO Bool
36+testAgreement (TestE p) = do
37+ spider <- runSpiderHost $ runTestE p
38+ let results = [("spider", spider)]
39+
40+ compareResult results (testEvent $ runPure p)
41+
42+testAgreement (TestB p) = do
43+ spider <- runSpiderHost $ runTestB p
44+ let results = [("spider", spider)]
45+
46+ compareResult results (testBehavior $ runPure p)
47+
48+
49+compareResult :: (Show a, Eq a) => [(String, IntMap a)] -> IntMap a -> IO Bool
50+compareResult results expected = fmap and $ forM results $ \(name, r) -> do
51+
52+ when (r /= expected) $ do
53+ putStrLn ("Got: " ++ show (name, r))
54+ putStrLn ("Expected: " ++ show expected)
55+ return (r == expected)
56+
57+
58+runTests :: [(String, TestCase)] -> IO ()
59+runTests testCases = do
60+ results <- forM testCases $ \(name, test) -> do
61+ putStrLn $ "Test: " <> name
62+ testAgreement test
63+ exitWith $ if and results
64+ then ExitSuccess
65+ else ExitFailure 1
66+
test/Reflex/Test/CrossImpl.hsnew file+258
@@ -0,0 +1,258 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE ExistentialQuantification #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE FunctionalDependencies #-}
6+{-# LANGUAGE GADTs #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE NoMonomorphismRestriction #-}
9+{-# LANGUAGE RankNTypes #-}
10+{-# LANGUAGE RecursiveDo #-}
11+{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TypeFamilies #-}
13+{-# LANGUAGE TypeOperators #-}
14+{-# LANGUAGE UndecidableInstances #-}
15+module Reflex.Test.CrossImpl (test) where
16+
17+import Prelude hiding (and, foldl, mapM, mapM_, sequence, sequence_)
18+
19+import Control.Monad.Ref
20+import Reflex.Class
21+import Reflex.Dynamic
22+import Reflex.Host.Class
23+import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
24+import qualified Reflex.Pure as P
25+import qualified Reflex.Spider.Internal as S
26+
27+import Control.Arrow (second, (&&&))
28+import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
29+import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
30+import Control.Monad.Writer hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
31+import Data.Dependent.Map (DMap, DSum (..))
32+import qualified Data.Dependent.Map as DMap
33+import Data.Foldable
34+import Data.Functor.Misc
35+import Data.Map.Strict (Map)
36+import qualified Data.Map.Strict as Map
37+import qualified Data.Set as Set
38+import Data.Traversable
39+import System.Exit
40+import System.Mem
41+
42+import System.IO.Unsafe
43+
44+mapToPureBehavior :: Map Int a -> Behavior PureReflexDomain a
45+mapToPureBehavior m = P.Behavior $ \t -> case Map.lookupLE t m of
46+ Nothing -> error $ "mapToPureBehavior: no value for time " <> show t
47+ Just (_, v) -> v
48+
49+mapToPureEvent :: Map Int a -> Event PureReflexDomain a
50+mapToPureEvent m = P.Event $ flip Map.lookup m
51+
52+relevantTestingTimes :: (Map Int a, Map Int b) -> [Int]
53+relevantTestingTimes (b, e) = case Set.minView &&& Set.maxView $ Map.keysSet b `Set.union` Map.keysSet e of
54+ (Just (t0, _), Just (t1, _)) -> [t0..t1+1] -- We need to go to b+1 to see the result of the final event
55+ _ -> [] -- Doesn't actually make much sense
56+
57+type PureReflexDomain = P.Pure Int
58+type TimeM = (->) Int
59+
60+testPure :: (t ~ PureReflexDomain, m ~ TimeM) => ((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)
61+testPure builder (b, e) =
62+ let (P.Behavior b', P.Event e') = ($ 0) $ builder (mapToPureBehavior b, mapToPureEvent e)
63+ relevantTimes = relevantTestingTimes (b, e)
64+ e'' = Map.mapMaybe id $ Map.fromList $ map (id &&& e') relevantTimes
65+ b'' = Map.fromList $ map (id &&& b') relevantTimes
66+ in (b'', e'')
67+
68+class MapMSignals a a' t t' | a -> t, a' -> t', a t' -> a', a' t -> a where
69+ mapMSignals :: Monad m => (forall b. Behavior t b -> m (Behavior t' b)) -> (forall b. Event t b -> m (Event t' b)) -> a -> m a'
70+
71+instance MapMSignals (Behavior t a) (Behavior t' a) t t' where
72+ mapMSignals fb _ = fb
73+
74+instance MapMSignals (Event t a) (Event t' a) t t' where
75+ mapMSignals _ fe = fe
76+
77+instance (MapMSignals a a' t t', MapMSignals b b' t t') => MapMSignals (a, b) (a', b') t t' where
78+ mapMSignals fb fe (a, b) = liftM2 (,) (mapMSignals fb fe a) (mapMSignals fb fe b)
79+
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)
81+testSpider builder (bMap, eMap) = unsafePerformIO $ S.runSpiderHost $ do
82+ (re, reTrigger) <- newEventWithTriggerRef
83+ (rb, rbTrigger) <- newEventWithTriggerRef
84+ b <- runHostFrame $ hold (error "testSpider: No value for input behavior yet") rb
85+ (b', e') <- runHostFrame $ builder (b, re)
86+ e'Handle <- subscribeEvent e' --TODO: This should be unnecessary
87+ let times = relevantTestingTimes (bMap, eMap)
88+ liftIO performGC
89+ outputs <- forM times $ \t -> do
90+ forM_ (Map.lookup t bMap) $ \val -> mapM_ (\ rbt -> fireEvents [rbt :=> Identity val]) =<< readRef rbTrigger
91+ bOutput <- sample b'
92+ eOutput <- fmap join $ forM (Map.lookup t eMap) $ \val -> do
93+ mret <- readRef reTrigger
94+ let firing = case mret of
95+ Just ret -> [ret :=> Identity val]
96+ Nothing -> []
97+ fireEventsAndRead firing $ sequence =<< readEvent e'Handle
98+ liftIO performGC
99+ return (t, (bOutput, eOutput))
100+ return (Map.fromList $ map (second fst) outputs, Map.mapMaybe id $ Map.fromList $ map (second snd) outputs)
101+
102+tracePerf :: Show a => a -> b -> b
103+tracePerf = flip const
104+
105+testAgreement :: (Eq c, Eq d, Show c, Show d) => (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) -> IO Bool
106+testAgreement builder inputs = do
107+ let identityResult = testPure builder inputs
108+ tracePerf "---------" $ return ()
109+ let spiderResult = testSpider builder inputs
110+ tracePerf "---------" $ return ()
111+ let resultsAgree = identityResult == spiderResult
112+ if resultsAgree
113+ then do --putStrLn "Success:"
114+ --print identityResult
115+ return ()
116+ else do putStrLn "Failure:"
117+ putStrLn $ "Pure result: " <> show identityResult
118+ putStrLn $ "Spider result: " <> show spiderResult
119+ return resultsAgree
120+
121+type TestCaseConstraint t m = (Reflex t, MonadSample t m, MonadHold t m, MonadFix m, MonadFix (PushM t))
122+
123+data TestCase = forall a b c d. (Eq c, Eq d, Show c, Show d) => TestCase (Map Int a, Map Int b) (forall m t. TestCaseConstraint t m => (Behavior t a, Event t b) -> m (Behavior t c, Event t d))
124+
125+testCases :: [(String, TestCase)]
126+testCases =
127+ [ (,) "hold" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(_, e) -> do
128+ b' <- hold "123" e
129+ return (b', e)
130+ , (,) "count" $ TestCase (Map.singleton 0 (), Map.fromList [(1, ()), (2, ()), (3, ())]) $ \(_, e) -> do
131+ e' <- updated <$> count e
132+ b' <- hold (0 :: Int) e'
133+ return (b', e')
134+ , (,) "headE-1" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
135+ e' <- headE $ leftmost [e, e]
136+ return (b, e')
137+ , (,) "switch-1" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
138+ let e' = fmap (const e) e
139+ b' <- hold never e'
140+ let e'' = switch b'
141+ return (b, e'')
142+ , (,) "switch-2" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
143+ let e' = flip pushAlways e $ const $ do
144+ let eab = splitRecombineEvent e
145+ switch <$> hold eab never
146+ e'' = coincidence e'
147+ return (b, e'')
148+ , (,) "switch-3" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
149+ let e' = flip pushAlways e $ const $ do
150+ let eab = splitRecombineEvent e
151+ switch <$> hold eab (fmap (const e) e)
152+ e'' = coincidence e'
153+ return (b, e'')
154+ , (,) "switch-4" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
155+ let e' = leftmost [e, e]
156+ e'' <- switch <$> hold e' (fmap (const e) e)
157+ return (b, e'')
158+ , (,) "switchHoldPromptly-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
159+ let e' = fmap (const e) e
160+ e'' <- switchHoldPromptly never e'
161+ return (b, e'')
162+ , (,) "switchHoldPromptly-2" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
163+ let e' = fmap (const e) e
164+ e'' <- switchHoldPromptly never $ leftmost [e', e']
165+ return (b, e'')
166+ , (,) "switchHoldPromptly-3" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
167+ let e' = leftmost [e, e]
168+ e'' <- switchHoldPromptly never (fmap (const e) e')
169+ return (b, e'')
170+ , (,) "switchHoldPromptly-4" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do
171+ let e' = leftmost [e, e]
172+ e'' <- switchHoldPromptly never (fmap (const e') e)
173+ return (b, e'')
174+ , (,) "switch-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
175+ let e' = leftmost [e, e]
176+ e'' <- switch <$> hold never (fmap (const e') e)
177+ return (b, e'')
178+ , (,) "switchHoldPromptly-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
179+ let e' = flip push e $ \_ -> do
180+ Just <$> headE e
181+ e'' <- switchHoldPromptly never e'
182+ return (b, e'')
183+ , (,) "switchHoldPromptly-6" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
184+ let e' = flip pushAlways e $ \_ -> do
185+ switchHoldPromptly e never
186+ e'' <- switchHoldPromptly never e'
187+ return (b, e'')
188+ , (,) "coincidence-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
189+ let e' = flip pushAlways e $ \_ -> return e
190+ e'' = coincidence e'
191+ return (b, e'')
192+ , (,) "coincidence-2" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
193+ let e' = flip pushAlways e $ \_ -> return $ leftmost [e, e]
194+ e'' = coincidence e'
195+ return (b, e'')
196+ , (,) "coincidence-3" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
197+ let e' = flip pushAlways e $ \_ -> return $ coincidence $ fmap (const e) e
198+ e'' = coincidence e'
199+ return (b, e'')
200+ , (,) "coincidence-4" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do
201+ let e' = flip pushAlways e $ \_ -> headE e
202+ e'' = coincidence e'
203+ return (b, e'')
204+ , (,) "coincidence-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer")]) $ \(b, e) -> do
205+ let eChild = flip pushAlways e $ const $ do
206+ let eNewValues = leftmost [e, e]
207+ return $ coincidence $ fmap (const eNewValues) eNewValues
208+ e' = coincidence eChild
209+ return (b, e')
210+ , (,) "coincidence-6" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer")]) $ \(b, e) -> do
211+ let eChild = flip pushAlways e $ const $ do
212+ let e' = coincidence $ fmap (const e) e
213+ return $ leftmost [e', e']
214+ e'' = coincidence eChild
215+ return (b, e'')
216+ , (,) "coincidence-7" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do
217+ let e' = leftmost [e, e]
218+ eCoincidences = coincidence $ fmap (const e') e
219+ return (b, eCoincidences)
220+ , (,) "holdWhileFiring" $ TestCase (Map.singleton 0 "zxc", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
221+ eo <- headE e
222+ bb <- hold b $ pushAlways (const $ hold "asdf" eo) eo
223+ let b' = pull $ sample =<< sample bb
224+ return (b', e)
225+ , (,) "joinDyn" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
226+ bb <- hold "b" e
227+ bd <- hold never . fmap (const e) =<< headE e
228+ eOuter <- pushAlways sample . fmap (const bb) <$> headE e
229+ let eInner = switch bd
230+ e' = leftmost [eOuter, eInner]
231+ return (b, e')
232+ , (,) "holdUniqDyn-laziness" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList (zip [1 :: Int ..] [1 :: Int, 2, 2, 3, 3, 3, 4, 4, 4, 4])) $ \(_, e :: Event t Int) -> do
233+ rec result <- holdUniqDyn d
234+ d <- holdDyn (0 :: Int) e
235+ return (current result, updated result)
236+ {-
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
238+ x <- holdIncremental (DMap.singleton LeftTag $ void e) $ PatchDMapWithMove.mapPatchDMapWithMove (\(Const2 _) -> void e) <$> e
239+ let e' = mergeIncrementalWithMove x :: Event t (DMap (EitherTag () ()) Identity)
240+ return (b, e')
241+ -}
242+ ]
243+
244+splitRecombineEvent :: Reflex t => Event t a -> Event t String
245+splitRecombineEvent e =
246+ let ea = "a" <$ e
247+ eb = "b" <$ e
248+ in leftmost [ea, eb]
249+
250+
251+test :: IO ()
252+test = do
253+ results <- forM testCases $ \(name, TestCase inputs builder) -> do
254+ putStrLn $ "Test: " <> name
255+ testAgreement builder inputs
256+ exitWith $ if and results
257+ then ExitSuccess
258+ else ExitFailure 1
test/Reflex/Test/Micro.hsnew file+285
@@ -0,0 +1,285 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE GADTs #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE RankNTypes #-}
8+{-# LANGUAGE RecursiveDo #-}
9+
10+module Reflex.Test.Micro (testCases) where
11+
12+import Reflex
13+import Reflex.TestPlan
14+
15+import Control.Applicative
16+import Control.Monad
17+import Control.Monad.Fix
18+import Data.Char
19+import Data.Foldable
20+import Data.Functor.Misc
21+import qualified Data.Map as Map
22+import Data.Monoid
23+
24+import Prelude
25+
26+{-# ANN testCases "HLint: ignore Functor law" #-}
27+testCases :: [(String, TestCase)]
28+testCases =
29+ [ testB "hold" $ hold "0" =<< events1
30+
31+ , testB "count" $ do
32+ b <- current <$> (count =<< events2)
33+ return $ (+ (0::Int)) <$> b
34+
35+ , testB "pull-1" $ do
36+ b <- hold "0" =<< events1
37+ return (pull $ sample $ pull $ sample b)
38+
39+ , testB "pull-2" $ do
40+ b1 <- behavior1
41+ return (pull $ liftA2 (<>) (sample b1) (sample b1))
42+
43+ , testB "pull-3" $ do
44+ b1 <- behavior1
45+ b2 <- behavior2
46+ return (pull $ liftA2 (<>) (sample b1) (sample b2))
47+
48+ , testB "pull-4" $ do
49+ es <- planList ["a", "b", "c"]
50+ e <- plan [(0, ())]
51+ b <- hold (constant "") $
52+ pushAlways (const $ hold "z" es) e
53+ return (join b)
54+
55+ , testE "id" $ do
56+ events2
57+
58+ , testE "fmap-id" $ do
59+ e <- events2
60+ return $ fmap id e
61+
62+ , testE "tag-1" $ do
63+ b1 <- behavior1
64+ e <- events2
65+ return (tag b1 e)
66+
67+ , testE "tag-2" $ do
68+ b1 <- behavior1
69+ e <- events2
70+ return (tag (map toUpper <$> b1) e)
71+
72+ , testE "attach-1" $ do
73+ b1 <- behavior1
74+ e <- events2
75+ return (attachWith (++) (map toUpper <$> b1) e)
76+
77+ , testE "leftmost" $ liftA2 leftmost2 events1 events2
78+
79+ , testE "appendEvents-1" $ liftA2 mappend events1 events2
80+
81+ , testE "appendEvents-2" $ liftA2 mappend events3 events2
82+
83+ , testE "merge-1" $ do
84+ e <- events1
85+ return $ leftmost ["x" <$ e, "y" <$ e]
86+
87+ , testE "merge-2" $ do
88+ e <- events1
89+ let m = mergeMap $ Map.fromList [(1::Int, "y" <$ e), (2, "z" <$ e)]
90+ let ee = flip pushAlways e $ const $ return m
91+ return $ coincidence ee
92+
93+ , testE "headE-1" $ do
94+ e <- events1
95+ headE $ leftmost [e, e]
96+
97+ , testE "headE-2" $ do
98+ e <- events1
99+ b <- hold never (e <$ e)
100+ headE $ switch b
101+
102+ , testE "switch-1" $ do
103+ e <- events1
104+ b <- hold never (e <$ e)
105+ return $ switch b
106+
107+ , testE "switch-2" $ do
108+ e <- events1
109+ return $ coincidence $ flip pushAlways e $ const $ do
110+ switch <$> hold (leftmost ["x" <$ e, "y" <$ e, "z" <$ e]) (e <$ e)
111+
112+ , testE "switch-3" $ do
113+ e <- events1
114+ return $ coincidence $ flip pushAlways e $ const $ do
115+ switch <$> hold (leftmost ["x" <$ e, "y" <$ e, "z" <$ e]) never
116+
117+ , testE "switch-4" $ do
118+ e <- events1
119+ switch <$> hold (deep e) (e <$ e)
120+
121+ , testE "switch-5" $ do
122+ e <- events1
123+ return $ coincidence $ flip pushAlways e $ const $
124+ return $ leftmost ["x" <$ e, "y" <$ e, "z" <$ e]
125+
126+ , testE "switch-6" $ do
127+ e <- events1
128+ return $ coincidence $ flip pushAlways e $ const $ do
129+ switch <$> hold ("x" <$ e) (e <$ e)
130+
131+ , testE "switchHoldPromptly-1" $ do
132+ e <- events1
133+ let e' = e <$ e
134+ switchHoldPromptly never $ e <$ e'
135+
136+ , testE "switchHoldPromptly-2" $ do
137+ e <- events1
138+ switchHoldPromptly never $ deep (e <$ e)
139+
140+ , testE "switchHoldPromptly-3" $ do
141+ e <- events1
142+ switchHoldPromptly never $ (e <$ deep e)
143+
144+ , testE "switchHoldPromptly-4" $ do
145+ e <- events1
146+ switchHoldPromptly never $ (deep e <$ e)
147+
148+ , testE "switch-5" $ do
149+ e <- events1
150+ switch <$> hold never (deep e <$ e)
151+
152+ , testE "switchHoldPromptly-5" $ do
153+ e <- events1
154+ switchHoldPromptly never $ flip push e $
155+ const (Just <$> headE e)
156+
157+ , testE "switchHoldPromptly-6" $ do
158+ e <- events1
159+ switchHoldPromptly never $ flip pushAlways e $
160+ const (switchHoldPromptly e never)
161+
162+ , testE "coincidence-1" $ do
163+ e <- events1
164+ return $ coincidence $ flip pushAlways e $
165+ const $ return e
166+
167+ , testE "coincidence-2" $ do
168+ e <- events1
169+ return $ coincidence $ flip pushAlways e $
170+ const $ return (deep e)
171+
172+ , testE "coincidence-3" $ do
173+ e <- events1
174+ return $ coincidence $ flip pushAlways e $
175+ const $ return (coincidence (e <$ e))
176+
177+ , testE "coincidence-4" $ do
178+ e <- events1
179+ return $ coincidence $ flip pushAlways e $
180+ const (headE e)
181+
182+ , testE "coincidence-5" $ do
183+ e <- events1
184+ return $ coincidence $ flip pushAlways e $ const $ do
185+ let e' = deep e
186+ return (coincidence (e' <$ e'))
187+
188+ , testE "coincidence-6" $ do
189+ e <- events1
190+ return $ coincidence $ flip pushAlways e $ const $ do
191+ let e' = coincidence (e <$ e)
192+ return $ deep e'
193+
194+ , testE "coincidence-7" $ do
195+ e <- events1
196+ return $ coincidence (deep e <$ e)
197+
198+ , testB "holdWhileFiring" $ do
199+ e <- events1
200+ eo <- headE e
201+ bb <- hold (constant "x") $ pushAlways (const $ hold "a" eo) eo
202+ return $ pull $ sample =<< sample bb
203+
204+ , testE "joinDyn" $ do
205+ e <- events1
206+ bb <- hold "b" e
207+ bd <- hold never . fmap (const e) =<< headE e
208+
209+ eOuter <- pushAlways sample . fmap (const bb) <$> headE e
210+ let eInner = switch bd
211+ return $ leftmost [eOuter, eInner]
212+
213+ , testB "foldDyn" $ do
214+ d <- foldDyn (++) "0" =<< events1
215+ return (current d)
216+
217+ , testB "mapDyn" $ do
218+ d <- foldDyn (++) "0" =<< events1
219+ return $ current $ fmap (map toUpper) d
220+
221+ , testB "combineDyn" $ do
222+ d1 <- foldDyn (++) "0" =<< events1
223+ d2 <- fmap (fmap (map toUpper)) $ foldDyn (++) "0" =<< events2
224+
225+ return $ current $ zipDynWith (<>) d1 d2
226+ , testE "fan-1" $ do
227+ e <- fmap toMap <$> events1
228+ let es = select (fanMap e) . Const2 <$> values
229+
230+ return (mergeList es)
231+
232+ , testE "fan-2" $ do
233+ e <- fmap toMap <$> events3
234+ let es = select (fanMap e) . Const2 <$> values
235+
236+ return (mergeList es)
237+
238+ , testE "fan-3" $ do
239+ f <- fanMap . fmap toMap <$> events3
240+ return $ select f (Const2 'c')
241+
242+ , testE "fan-4" $ do
243+ e <- fmap toMap <$> events1
244+ return $ toUpper <$> select (fanMap e) (Const2 'a')
245+
246+ , testE "fan-5" $ do
247+ e <- fmap toMap <$> events2
248+ return $ toUpper <$> select (fanMap e) (Const2 'c')
249+
250+ , testE "fan-6" $ do
251+ f <- fanMap . fmap toMap <$> events1
252+ return $ toList <$> mergeList [ select f (Const2 'b'), select f (Const2 'b'), select f (Const2 'e'), select f (Const2 'e') ]
253+
254+ , testE "difference" $ do
255+ e1 <- events1
256+ e2 <- events2
257+ return $ e1 `difference ` e2
258+
259+ , testE "lazy-hold" $ do
260+ let lazyHold :: forall t m. (Reflex t, MonadHold t m, MonadFix m) => m (Event t ())
261+ lazyHold = do
262+ rec !b <- hold never e
263+ let e = never <$ switch b
264+ return $ void e
265+ lazyHold
266+
267+ ] where
268+
269+ events1, events2, events3 :: TestPlan t m => m (Event t String)
270+ events1 = plan [(1, "a"), (2, "b"), (5, "c"), (7, "d"), (8, "e")]
271+ events2 = plan [(1, "e"), (3, "d"), (4, "c"), (6, "b"), (7, "a")]
272+
273+ events3 = liftA2 mappend events1 events2
274+
275+ values = "abcde"
276+ toMap str = Map.fromList $ map (\c -> (c, c)) str
277+
278+ behavior1, behavior2 :: forall t m. TestPlan t m => m (Behavior t String)
279+ behavior1 = hold "1" =<< events1
280+ behavior2 = hold "2" =<< events2
281+
282+ deep e = leftmost [e, e]
283+ leftmost2 e1 e2 = leftmost [e1, e2]
284+
285+
test/Reflex/TestPlan.hsnew file+52
@@ -0,0 +1,52 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE RankNTypes #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE UndecidableInstances #-}
9+module Reflex.TestPlan
10+ ( TestPlan(..)
11+
12+ , TestCase (..)
13+ , testE, testB
14+ , TestE, TestB
15+
16+ , planList
17+
18+ ) where
19+
20+import Control.DeepSeq
21+import Control.Monad.Fix
22+import Data.Word
23+import Reflex.Class
24+
25+
26+import Prelude
27+
28+class (Reflex t, MonadHold t m, MonadFix m) => TestPlan t m where
29+ -- | Speicify a plan of an input Event firing
30+ -- Occurances must be in the future (i.e. Time > 0)
31+ -- Initial specification is
32+
33+ plan :: [(Word, a)] -> m (Event t a)
34+
35+
36+planList :: TestPlan t m => [a] -> m (Event t a)
37+planList xs = plan $ zip [1..] xs
38+
39+type TestE a = forall t m. TestPlan t m => m (Event t a)
40+type TestB a = forall t m. TestPlan t m => m (Behavior t a)
41+
42+data TestCase where
43+ TestE :: (Show a, Eq a, NFData a) => TestE a -> TestCase
44+ TestB :: (Show a, Eq a, NFData a) => TestB a -> TestCase
45+
46+-- Helpers to declare test cases
47+testE :: (Eq a, Show a, NFData a) => String -> TestE a -> (String, TestCase)
48+testE name test = (name, TestE test)
49+
50+testB :: (Eq a, Show a, NFData a) => String -> TestB a -> (String, TestCase)
51+testB name test = (name, TestB test)
52+
test/RequesterT.hsnew file+68
@@ -0,0 +1,68 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE GADTs #-}
3+{-# LANGUAGE RankNTypes #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+module Main where
6+
7+import Control.Lens
8+import Control.Monad
9+import qualified Data.Dependent.Map as DMap
10+import Data.Dependent.Sum
11+import Data.These
12+
13+import Reflex
14+import Reflex.Requester.Base
15+import Reflex.Requester.Class
16+import Test.Run
17+
18+data RequestInt a where
19+ RequestInt :: Int -> RequestInt Int
20+
21+main :: IO ()
22+main = do
23+ os1@[[Just [10,9,8,7,6,5,4,3,2,1]]] <- runApp' (unwrapApp testOrdering) $
24+ [ Just ()
25+ ]
26+ print os1
27+ os2@[[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]]
28+ <- runApp' (unwrapApp testSimultaneous) $ map Just $
29+ [ This ()
30+ , That ()
31+ , This ()
32+ , These () ()
33+ ]
34+ print os2
35+ return ()
36+
37+unwrapRequest :: DSum tag RequestInt -> Int
38+unwrapRequest (_ :=> RequestInt i) = i
39+
40+unwrapApp :: ( Reflex t, Monad m )
41+ => (a -> RequesterT t RequestInt Identity m ())
42+ -> a
43+ -> m (Event t [Int])
44+unwrapApp x appIn = do
45+ ((), e) <- runRequesterT (x appIn) never
46+ return $ fmap (map unwrapRequest . DMap.toList) e
47+
48+testOrdering :: ( Response m ~ Identity
49+ , Request m ~ RequestInt
50+ , Requester t m
51+ , Adjustable t m)
52+ => Event t ()
53+ -> m ()
54+testOrdering pulse = do
55+ forM_ [10,9..1] $ \i -> requestingIdentity (RequestInt i <$ pulse)
56+ return ()
57+
58+testSimultaneous :: ( Response m ~ Identity
59+ , Request m ~ RequestInt
60+ , Requester t m
61+ , Adjustable t m)
62+ => Event t (These () ())
63+ -> m ()
64+testSimultaneous pulse = do
65+ let tellE = fmapMaybe (^? here) pulse
66+ switchE = fmapMaybe (^? there) pulse
67+ forM_ [1,3..9] $ \i -> runWithReplace (requestingIdentity (RequestInt i <$ tellE)) $ ffor switchE $ \_ ->
68+ requestingIdentity (RequestInt (i+1) <$ tellE)
test/Test/Run.hsnew file+66
@@ -0,0 +1,66 @@
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)
test/hlint.hs+9−5
@@ -1,7 +1,7 @@
1module Main where
1module Main where
2
2
3import Control.Monad
3import Control.Monad
4−import Language.Haskell.HLint (hlint)
4+import Language.Haskell.HLint3 (hlint)
5import System.Directory
5import System.Directory
6import System.Exit (exitFailure, exitSuccess)
6import System.Exit (exitFailure, exitSuccess)
7import System.FilePath
7import System.FilePath
@@ -20,10 +20,7 @@ main = do
20 , "--ignore=Use >=>"
20 , "--ignore=Use >=>"
21 , "--ignore=Use ."
21 , "--ignore=Use ."
22 , "--ignore=Use unless"
22 , "--ignore=Use unless"
23− , "--ignore=Reduce duplication"
24 , "--cpp-define=USE_TEMPLATE_HASKELL"
23 , "--cpp-define=USE_TEMPLATE_HASKELL"
25− , "--ignore=Use tuple-section"
26− , "--ignore=Unused LANGUAGE pragma" -- hlint3 falsely believes that TypeOperators is not needed
27 ]
24 ]
28 recurseInto = and <$> sequence
25 recurseInto = and <$> sequence
29 [ fileType ==? Directory
26 [ fileType ==? Directory
@@ -31,9 +28,16 @@ main = do
31 ]
28 ]
32 matchFile = and <$> sequence
29 matchFile = and <$> sequence
33 [ extension ==? ".hs"
30 [ extension ==? ".hs"
31+ , let notElem' = liftOp notElem
32+ in filePath `notElem'` filePathExceptions pwd
34 ]
33 ]
35− files <- find recurseInto matchFile (pwd </> "src") --TODO: Someday fix all hints in tests, etc.
34+ files <- find recurseInto matchFile pwd
36 ideas <- fmap concat $ forM files $ \f -> do
35 ideas <- fmap concat $ forM files $ \f -> do
37 putStr $ "linting file " ++ drop (length pwd + 1) f ++ "... "
36 putStr $ "linting file " ++ drop (length pwd + 1) f ++ "... "
38 runHlint f
37 runHlint f
39 if null ideas then exitSuccess else exitFailure
38 if null ideas then exitSuccess else exitFailure
39+
40+filePathExceptions :: FilePath -> [FilePath]
41+filePathExceptions pwd = map (pwd </>) $
42+ [ "src/Data/AppendMap.hs" -- parse error when hlint runs
43+ ]
test/rootCleanup.hsnew file+25
@@ -0,0 +1,25 @@
1+import Control.Concurrent
2+import Control.Monad
3+import Data.IORef
4+import Reflex
5+import Reflex.Host.Class
6+import System.Exit
7+import System.Mem
8+
9+main :: IO ()
10+main = do
11+ numSubscriptions <- newIORef 0
12+ replicateM_ 1000 $ do
13+ runSpiderHost $ do
14+ e <- newEventWithTrigger $ \_ -> do
15+ modifyIORef' numSubscriptions succ
16+ return $ modifyIORef' numSubscriptions pred
17+ _ <- hold () e
18+ return ()
19+ replicateM_ 100 $ do
20+ performMajorGC
21+ threadDelay 1
22+ n <- readIORef numSubscriptions
23+ if n == 0
24+ then putStrLn "Succeeded"
25+ else putStrLn "Failed" >> exitFailure
test/semantics.hsnew file+49
@@ -0,0 +1,49 @@
1+{-# LANGUAGE ConstraintKinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE RankNTypes #-}
7+
8+module Main (main) where
9+
10+import Reflex.Test
11+
12+import Data.Bifunctor
13+import Data.Functor
14+import Data.List
15+import qualified Reflex.Bench.Focused as Focused
16+import qualified Reflex.Test.Micro as Micro
17+
18+import System.Environment
19+import System.Exit
20+
21+import Prelude
22+
23+matchPrefixes :: [String] -> (String -> Bool)
24+matchPrefixes [] = const True
25+matchPrefixes args = \name -> any (`isPrefixOf` name) args
26+
27+
28+main :: IO ()
29+main = do
30+ args <- getArgs
31+
32+ case args of
33+ ["--list"] -> mapM_ putStrLn (fst <$> allTests) >> exitWith (ExitFailure 1)
34+ _ -> case filter (matchPrefixes args . fst) allTests of
35+ [] -> putStrLn "filter did not match any tests" >> exitWith (ExitFailure 1)
36+ tests -> runTests tests
37+
38+ where
39+ allTests = concat
40+ [ makeGroup "micro" Micro.testCases
41+ , makeGroup "subscribing (100,40)" (Focused.subscribing 100 40)
42+ , makeGroup "firing 1000" (Focused.firing 1000)
43+ , makeGroup "merge 100" (Focused.merging 100)
44+ , makeGroup "fan 50" (Focused.fans 50)
45+ ]
46+
47+ makeGroup name tests = first (\test -> intercalate "/" [name, test]) <$> tests
48+
49+
test/tests.hsdeleted−43
@@ -1,43 +0,0 @@
1−{-# LANGUAGE TemplateHaskell #-}
2−module Main where
3−
4−import Test.HUnit (runTestTT, (~:), assertEqual, errors, failures, test)
5−import Data.Patch ( Patch(apply) )
6−import Data.Patch.MapWithMove ( patchThatChangesMap )
7−import Data.Map as Map ( Map, fromList, singleton )
8−import Hedgehog (checkParallel, discover, Property, property, forAll, PropertyT, (===))
9−import Hedgehog.Gen as Gen ( int )
10−import Hedgehog.Range as Range ( linear )
11−import Control.Monad (replicateM)
12−import System.Exit (exitFailure, exitSuccess)
13−import Data.Sequence as Seq ( foldMapWithIndex, replicateM )
14−
15−main :: IO ()
16−main = do
17− counts <- runTestTT $ test [
18− "Simple Move" ~: (do
19− let mapBefore = Map.fromList [(0,1)]
20− mapAfter = Map.fromList [(0,0),(1,1)]
21− patch = patchThatChangesMap mapBefore mapAfter
22− afterPatch = apply patch mapBefore
23− assertEqual "Patch creates the same Map" (Just mapAfter) afterPatch),
24− "Property Checks" ~: propertyChecks
25− ]
26− if errors counts + failures counts == 0 then exitSuccess else exitFailure
27−
28−propertyChecks :: IO Bool
29−propertyChecks = checkParallel $$(discover)
30−
31−prop_patchThatChangesMap :: Property
32−prop_patchThatChangesMap = property $ do
33− mapBefore <- makeRandomIntMap
34− mapAfter <- makeRandomIntMap
35− let patch = patchThatChangesMap mapBefore mapAfter
36− Just mapAfter === apply patch mapBefore
37−
38−makeRandomIntMap :: Monad m => PropertyT m (Map Int Int)
39−makeRandomIntMap = do
40− let genNum = Gen.int (Range.linear 0 100)
41− length <- forAll genNum
42− listOfNumbers <- forAll $ Seq.replicateM length genNum
43− pure $ Seq.foldMapWithIndex Map.singleton listOfNumbers