git.iko.soy/patch
on e52ce57 help sign in
b6af869
swap
0 ahead, 550 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+39
@@ -0,0 +1,39 @@
1+{ mkDerivation, ghc, base, bifunctors, containers, deepseq
2+, dependent-map, dependent-sum, exception-transformers
3+, haskell-src-exts, haskell-src-meta, hlint, lens, MemoTrie
4+, monad-control, mtl, primitive, random, ref-tf
5+, semigroupoids , semigroups, split, stdenv, stm, syb
6+, template-haskell , these, time, transformers
7+, transformers-compat, unbounded-delays, prim-uniq
8+, data-default, filepath, directory, filemanip, ghcjs-base
9+, monoidal-containers
10+, useTemplateHaskell ? true
11+}:
12+mkDerivation {
13+ pname = "reflex";
14+ version = "0.5.0";
15+ src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.;
16+ libraryHaskellDepends = [
17+ base bifunctors containers dependent-map dependent-sum
18+ exception-transformers lens
19+ MemoTrie monad-control mtl primitive ref-tf semigroupoids
20+ semigroups stm syb template-haskell these transformers
21+ transformers-compat prim-uniq
22+ base bifunctors containers deepseq dependent-map dependent-sum
23+ mtl ref-tf split transformers data-default
24+ random time unbounded-delays monoidal-containers
25+ ] ++ (if ghc.isGhcjs or false then [
26+ ghcjs-base
27+ ] else []) ++ (if !useTemplateHaskell then [] else [
28+ haskell-src-exts haskell-src-meta
29+ ]);
30+ testHaskellDepends = if ghc.isGhcjs or false then [] else [
31+ hlint filepath directory filemanip
32+ ];
33+ configureFlags = if useTemplateHaskell then [] else [
34+ "-f-use-template-haskell"
35+ ];
36+ homepage = "https://github.com/reflex-frp/reflex";
37+ description = "Higher-order Functional Reactive Programming";
38+ license = stdenv.lib.licenses.bsd3;
39+}
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+298
@@ -0,0 +1,298 @@
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://reflex-frp.org
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+ monoidal-containers >= 0.3.0.2 && < 0.4,
50+ mtl >= 2.1 && < 2.3,
51+ prim-uniq >= 0.1.0.1 && < 0.2,
52+ primitive >= 0.5 && < 0.7,
53+ random == 1.1.*,
54+ ref-tf == 0.4.*,
55+ reflection == 2.1.*,
56+ semigroupoids >= 4.0 && < 6,
57+ semigroups >= 0.16 && < 0.19,
58+ stm == 2.4.*,
59+ syb >= 0.5 && < 0.8,
60+ these >= 0.4 && < 0.8,
61+ time >= 1.4 && < 1.9,
62+ transformers >= 0.2,
63+ transformers-compat >= 0.3,
64+ unbounded-delays >= 0.1.0.0 && < 0.2
65+
66+ exposed-modules:
67+ Data.AppendMap,
68+ Data.FastMutableIntMap,
69+ Data.FastWeakBag,
70+ Data.Functor.Misc,
71+ Data.Map.Misc,
72+ Data.WeakBag,
73+ Reflex,
74+ Reflex.Class,
75+ Reflex.Adjustable.Class,
76+ Reflex.Collection,
77+ Reflex.Dynamic,
78+ Reflex.Dynamic.Uniq,
79+ Reflex.DynamicWriter,
80+ Reflex.DynamicWriter.Base,
81+ Reflex.DynamicWriter.Class,
82+ Reflex.EventWriter,
83+ Reflex.EventWriter.Base,
84+ Reflex.EventWriter.Class,
85+ Reflex.FastWeak,
86+ Reflex.FunctorMaybe,
87+ Reflex.Host.Class,
88+ Reflex.Network,
89+ Reflex.NotReady.Class,
90+ Reflex.Patch,
91+ Reflex.Patch.Class,
92+ Reflex.Patch.DMap,
93+ Reflex.Patch.DMapWithMove,
94+ Reflex.Patch.IntMap,
95+ Reflex.Patch.Map,
96+ Reflex.Patch.MapWithMove,
97+ Reflex.PerformEvent.Base,
98+ Reflex.PerformEvent.Class,
99+ Reflex.PostBuild.Base,
100+ Reflex.PostBuild.Class,
101+ Reflex.Profiled,
102+ Reflex.Pure,
103+ Reflex.Query.Base,
104+ Reflex.Query.Class,
105+ Reflex.Requester.Base,
106+ Reflex.Requester.Class,
107+ Reflex.Spider,
108+ Reflex.Spider.Internal,
109+ Reflex.Time,
110+ Reflex.TriggerEvent.Base,
111+ Reflex.TriggerEvent.Class,
112+ Reflex.Widget.Basic,
113+ Reflex.Workflow
114+
115+ ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively -ddump-simpl -ddump-to-file -dsuppress-coercions -dsuppress-idinfo
116+ ghc-prof-options: -fprof-auto
117+
118+ if flag(debug-trace-events)
119+ cpp-options: -DDEBUG_TRACE_EVENTS
120+ build-depends: bytestring
121+
122+ if flag(use-reflex-optimizer)
123+ cpp-options: -DUSE_REFLEX_OPTIMIZER
124+ build-depends: ghc
125+ exposed-modules: Reflex.Optimizer
126+
127+ if flag(use-template-haskell)
128+ cpp-options: -DUSE_TEMPLATE_HASKELL
129+ build-depends:
130+ dependent-sum >= 0.3 && < 0.5,
131+ haskell-src-exts >= 1.16 && < 1.21,
132+ haskell-src-meta >= 0.6 && < 0.9,
133+ template-haskell >= 2.9 && < 2.14
134+ exposed-modules:
135+ Reflex.Dynamic.TH
136+ other-extensions: TemplateHaskell
137+ else
138+ build-depends:
139+ dependent-sum == 0.4.*
140+
141+ if flag(fast-weak) && impl(ghcjs)
142+ ghc-options: -DGHCJS_FAST_WEAK
143+
144+ if impl(ghcjs)
145+ build-depends: ghcjs-base
146+
147+test-suite semantics
148+ type: exitcode-stdio-1.0
149+ main-is: semantics.hs
150+ hs-source-dirs: test
151+ ghc-options: -O2 -Wall -rtsopts
152+ build-depends:
153+ base,
154+ bifunctors,
155+ containers,
156+ deepseq >= 1.3 && < 1.5,
157+ dependent-map,
158+ dependent-sum,
159+ mtl,
160+ ref-tf,
161+ reflex,
162+ split,
163+ transformers >= 0.3
164+
165+test-suite CrossImpl
166+ type: exitcode-stdio-1.0
167+ main-is: Reflex/Test/CrossImpl.hs
168+ hs-source-dirs: test
169+ ghc-options: -O2 -Wall -rtsopts -main-is Reflex.Test.CrossImpl.test
170+ build-depends:
171+ base,
172+ containers,
173+ dependent-map,
174+ mtl,
175+ ref-tf,
176+ reflex
177+
178+test-suite hlint
179+ type: exitcode-stdio-1.0
180+ main-is: hlint.hs
181+ hs-source-dirs: test
182+ build-depends: base
183+ , directory
184+ , filepath
185+ , filemanip
186+ , hlint
187+ if impl(ghcjs)
188+ buildable: False
189+
190+test-suite EventWriterT
191+ type: exitcode-stdio-1.0
192+ main-is: EventWriterT.hs
193+ hs-source-dirs: test
194+ build-depends: base
195+ , dependent-sum
196+ , lens
197+ , these
198+ , transformers
199+ , reflex
200+ , ref-tf
201+
202+test-suite RequesterT
203+ type: exitcode-stdio-1.0
204+ main-is: RequesterT.hs
205+ hs-source-dirs: test
206+ build-depends: base
207+ , dependent-sum
208+ , dependent-map
209+ , lens
210+ , these
211+ , transformers
212+ , reflex
213+ , ref-tf
214+ buildable: False
215+
216+test-suite QueryT
217+ type: exitcode-stdio-1.0
218+ main-is: QueryT.hs
219+ hs-source-dirs: test
220+ build-depends: base
221+ , containers
222+ , dependent-map
223+ , dependent-sum
224+ , lens
225+ , monoidal-containers
226+ , ref-tf
227+ , reflex
228+ , semigroups
229+ , these
230+ , transformers
231+ other-modules: Test.Run
232+
233+test-suite GC-Semantics
234+ type: exitcode-stdio-1.0
235+ main-is: GC.hs
236+ hs-source-dirs: test
237+ build-depends: base
238+ , dependent-sum
239+ , dependent-map
240+ , these
241+ , transformers
242+ , reflex
243+ , ref-tf
244+ if impl(ghc < 8)
245+ build-depends: semigroups
246+
247+test-suite rootCleanup
248+ type: exitcode-stdio-1.0
249+ main-is: rootCleanup.hs
250+ hs-source-dirs: test
251+ build-depends: base
252+ , reflex
253+
254+benchmark spider-bench
255+ type: exitcode-stdio-1.0
256+ hs-source-dirs: bench
257+ main-is: Main.hs
258+ ghc-options: -Wall -O2 -rtsopts
259+ build-depends:
260+ base,
261+ criterion == 1.1.*,
262+ deepseq >= 1.3 && < 1.5,
263+ dependent-map,
264+ dependent-sum,
265+ mtl,
266+ primitive,
267+ reflex,
268+ stm,
269+ transformers >= 0.3
270+
271+benchmark saulzar-bench
272+ type: exitcode-stdio-1.0
273+ hs-source-dirs: bench test
274+ c-sources: bench-cbits/checkCapability.c
275+ main-is: RunAll.hs
276+ ghc-options: -Wall -O2 -rtsopts -threaded
277+ ghc-prof-options: -fprof-auto
278+ build-depends:
279+ base,
280+ containers == 0.5.*,
281+ criterion == 1.1.*,
282+ deepseq >= 1.3 && < 1.5,
283+ dependent-map,
284+ dependent-sum,
285+ loch-th,
286+ mtl,
287+ primitive,
288+ process,
289+ ref-tf,
290+ reflex,
291+ split,
292+ stm,
293+ time,
294+ transformers >= 0.3
295+
296+source-repository head
297+ type: git
298+ 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+370
@@ -0,0 +1,370 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveFunctor #-}
3+{-# LANGUAGE DeriveGeneric #-}
4+{-# LANGUAGE DeriveTraversable #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
9+{-# LANGUAGE PatternSynonyms #-}
10+{-# LANGUAGE RoleAnnotations #-}
11+{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE StandaloneDeriving #-}
13+{-# LANGUAGE TypeFamilies #-}
14+{-# OPTIONS_GHC -fno-warn-orphans #-}
15+-- | 'Data.Map' with a better 'Monoid' instance
16+--
17+-- 'Data.Map' has @mappend = union@, which is left-biased. AppendMap has
18+-- @mappend = unionWith mappend@ instead.
19+module Data.AppendMap
20+ ( module Data.AppendMap
21+ , module Data.Map.Monoidal
22+ ) where
23+
24+import Prelude hiding (map)
25+
26+import Data.Align
27+import Data.Coerce
28+import Data.Default
29+import Data.Map (Map)
30+import qualified Data.Map as Map
31+import Data.Map.Monoidal
32+import Data.Semigroup
33+import Data.Set (Set)
34+import Reflex.Class (FunctorMaybe (..))
35+import Reflex.Patch (Additive, Group (..))
36+
37+{-# DEPRECATED AppendMap "Use 'MonoidalMap' instead" #-}
38+type AppendMap = MonoidalMap
39+
40+{-# DEPRECATED _unAppendMap "Use 'getMonoidalMap' instead" #-}
41+_unAppendMap :: MonoidalMap k v -> Map k v
42+_unAppendMap = getMonoidalMap
43+
44+pattern AppendMap :: Map k v -> MonoidalMap k v
45+pattern AppendMap m = MonoidalMap m
46+
47+deriving instance Ord k => Align (MonoidalMap k)
48+
49+instance FunctorMaybe (MonoidalMap k) where
50+ fmapMaybe = mapMaybe
51+
52+-- | Deletes a key, returning 'Nothing' if the result is empty.
53+nonEmptyDelete :: Ord k => k -> MonoidalMap k a -> Maybe (MonoidalMap k a)
54+nonEmptyDelete k vs =
55+ let deleted = delete k vs
56+ in if Data.AppendMap.null deleted
57+ then Nothing
58+ else Just deleted
59+
60+mapMaybeNoNull :: (a -> Maybe b)
61+ -> MonoidalMap token a
62+ -> Maybe (MonoidalMap token b)
63+mapMaybeNoNull f as =
64+ let bs = fmapMaybe f as
65+ in if Data.AppendMap.null bs
66+ then Nothing
67+ else Just bs
68+
69+#if !MIN_VERSION_monoidal_containers(0,3,1)
70+instance (Ord k, Semigroup v) => Semigroup (MonoidalMap k v) where
71+ MonoidalMap a <> MonoidalMap b = MonoidalMap $ Map.unionWith (<>) a b
72+#endif
73+
74+instance (Ord k, Group q) => Group (MonoidalMap k q) where
75+ negateG = map negateG
76+
77+instance (Ord k, Additive q) => Additive (MonoidalMap k q)
78+
79+(!) :: forall k a. Ord k => MonoidalMap k a -> k -> a
80+(!) = coerce ((Map.!) :: Map k a -> k -> a)
81+infixl 9 !
82+
83+(\\) :: forall k a b. Ord k => MonoidalMap k a -> MonoidalMap k b -> MonoidalMap k a
84+(\\) = coerce ((Map.\\) :: Map k a -> Map k b -> Map k a)
85+infixl 9 {-"-} \\ {-"-} --These comments prevent the C preprocssor from complaining
86+
87+null :: forall k a. MonoidalMap k a -> Bool
88+null = coerce (Map.null :: Map k a -> Bool)
89+
90+lookup :: forall k a. Ord k => k -> MonoidalMap k a -> Maybe a
91+lookup = coerce (Map.lookup :: k -> Map k a -> Maybe a)
92+
93+lookupLT :: forall k a. Ord k => k -> MonoidalMap k a -> Maybe (k, a)
94+lookupLT = coerce (Map.lookupLT :: k -> Map k a -> Maybe (k,a))
95+
96+lookupGT :: forall k a. Ord k => k -> MonoidalMap k a -> Maybe (k, a)
97+lookupGT = coerce (Map.lookupGT :: k -> Map k a -> Maybe (k,a))
98+
99+lookupLE :: forall k a. Ord k => k -> MonoidalMap k a -> Maybe (k, a)
100+lookupLE = coerce (Map.lookupLE :: k -> Map k a -> Maybe (k,a))
101+
102+lookupGE :: forall k a. Ord k => k -> MonoidalMap k a -> Maybe (k, a)
103+lookupGE = coerce (Map.lookupGE :: k -> Map k a -> Maybe (k,a))
104+
105+empty :: forall k a. MonoidalMap k a
106+empty = coerce (Map.empty :: Map k a)
107+
108+insert :: forall k a. Ord k => k -> a -> MonoidalMap k a -> MonoidalMap k a
109+insert = coerce (Map.insert :: k -> a -> Map k a -> Map k a)
110+
111+insertWith :: forall k a. Ord k => (a -> a -> a) -> k -> a -> MonoidalMap k a -> MonoidalMap k a
112+insertWith = coerce (Map.insertWith :: (a -> a -> a) -> k -> a -> Map k a -> Map k a)
113+
114+insertWithKey :: forall k a. Ord k => (k -> a -> a -> a) -> k -> a -> MonoidalMap k a -> MonoidalMap k a
115+insertWithKey = coerce (Map.insertWithKey :: (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a)
116+
117+insertLookupWithKey :: forall k a. Ord k => (k -> a -> a -> a) -> k -> a -> MonoidalMap k a -> (Maybe a, MonoidalMap k a)
118+insertLookupWithKey = coerce (Map.insertLookupWithKey :: (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a))
119+
120+delete :: forall k a. Ord k => k -> MonoidalMap k a -> MonoidalMap k a
121+delete = coerce (Map.delete :: k -> Map k a -> Map k a)
122+
123+adjust :: forall k a. Ord k => (a -> a) -> k -> MonoidalMap k a -> MonoidalMap k a
124+adjust = coerce (Map.adjust :: (a -> a) -> k -> Map k a -> Map k a)
125+
126+adjustWithKey :: forall k a. Ord k => (k -> a -> a) -> k -> MonoidalMap k a -> MonoidalMap k a
127+adjustWithKey = coerce (Map.adjustWithKey :: (k -> a -> a) -> k -> Map k a -> Map k a)
128+
129+update :: forall k a. Ord k => (a -> Maybe a) -> k -> MonoidalMap k a -> MonoidalMap k a
130+update = coerce (Map.update :: (a -> Maybe a) -> k -> Map k a -> Map k a)
131+
132+updateWithKey :: forall k a. Ord k => (k -> a -> Maybe a) -> k -> MonoidalMap k a -> MonoidalMap k a
133+updateWithKey = coerce (Map.updateWithKey :: (k -> a -> Maybe a) -> k -> Map k a -> Map k a)
134+
135+updateLookupWithKey :: forall k a. Ord k => (k -> a -> Maybe a) -> k -> MonoidalMap k a -> (Maybe a, MonoidalMap k a)
136+updateLookupWithKey = coerce (Map.updateLookupWithKey :: (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a))
137+
138+alter :: forall k a. Ord k => (Maybe a -> Maybe a) -> k -> MonoidalMap k a -> MonoidalMap k a
139+alter = coerce (Map.alter :: (Maybe a -> Maybe a) -> k -> Map k a -> Map k a)
140+
141+unionWith :: forall k a. Ord k => (a -> a -> a) -> MonoidalMap k a -> MonoidalMap k a -> MonoidalMap k a
142+unionWith = coerce (Map.unionWith :: (a -> a -> a) -> Map k a -> Map k a -> Map k a)
143+
144+unionWithKey :: forall k a. Ord k => (k -> a -> a -> a) -> MonoidalMap k a -> MonoidalMap k a -> MonoidalMap k a
145+unionWithKey = coerce (Map.unionWithKey :: (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a)
146+
147+unionsWith :: forall k a. Ord k => (a -> a -> a) -> [MonoidalMap k a] -> MonoidalMap k a
148+unionsWith = coerce (Map.unionsWith :: (a -> a -> a) -> [Map k a] -> Map k a)
149+
150+difference :: forall k a b. Ord k => MonoidalMap k a -> MonoidalMap k b -> MonoidalMap k a
151+difference = (\\)
152+
153+differenceWith :: forall k a b. Ord k => (a -> b -> Maybe a) -> MonoidalMap k a -> MonoidalMap k b -> MonoidalMap k a
154+differenceWith = coerce (Map.differenceWith :: (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a)
155+
156+differenceWithKey :: forall k a b. Ord k => (k -> a -> b -> Maybe a) -> MonoidalMap k a -> MonoidalMap k b -> MonoidalMap k a
157+differenceWithKey = coerce (Map.differenceWithKey :: (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a)
158+
159+intersectionWith :: forall k a b c. Ord k => (a -> b -> c) -> MonoidalMap k a -> MonoidalMap k b -> MonoidalMap k c
160+intersectionWith = coerce (Map.intersectionWith :: (a -> b -> c) -> Map k a -> Map k b -> Map k c)
161+
162+intersectionWithKey :: forall k a b c. Ord k => (k -> a -> b -> c) -> MonoidalMap k a -> MonoidalMap k b -> MonoidalMap k c
163+intersectionWithKey = coerce (Map.intersectionWithKey :: (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c)
164+
165+mergeWithKey :: forall k a b c. Ord k => (k -> a -> b -> Maybe c) -> (MonoidalMap k a -> MonoidalMap k c) -> (MonoidalMap k b -> MonoidalMap k c) -> MonoidalMap k a -> MonoidalMap k b -> MonoidalMap k c
166+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)
167+
168+map :: (a -> b) -> MonoidalMap k a -> MonoidalMap k b
169+map = fmap
170+
171+mapWithKey :: (k -> a -> b) -> MonoidalMap k a -> MonoidalMap k b
172+mapWithKey f (MonoidalMap m) = MonoidalMap $ Map.mapWithKey f m
173+
174+traverseWithKey :: Applicative t => (k -> a -> t b) -> MonoidalMap k a -> t (MonoidalMap k b)
175+traverseWithKey f (MonoidalMap m) = MonoidalMap <$> Map.traverseWithKey f m
176+
177+mapAccum :: forall k a b c. (a -> b -> (a, c)) -> a -> MonoidalMap k b -> (a, MonoidalMap k c)
178+mapAccum = coerce (Map.mapAccum :: (a -> b -> (a, c)) -> a -> Map k b -> (a, Map k c))
179+
180+mapAccumWithKey :: forall k a b c. (a -> k -> b -> (a, c)) -> a -> MonoidalMap k b -> (a, MonoidalMap k c)
181+mapAccumWithKey = coerce (Map.mapAccumWithKey :: (a -> k -> b -> (a, c)) -> a -> Map k b -> (a, Map k c))
182+
183+mapAccumRWithKey :: forall k a b c. (a -> k -> b -> (a, c)) -> a -> MonoidalMap k b -> (a, MonoidalMap k c)
184+mapAccumRWithKey = coerce (Map.mapAccumRWithKey :: (a -> k -> b -> (a, c)) -> a -> Map k b -> (a, Map k c))
185+
186+mapKeys :: forall k1 k2 a. Ord k2 => (k1 -> k2) -> MonoidalMap k1 a -> MonoidalMap k2 a
187+mapKeys = coerce (Map.mapKeys :: (k1 -> k2) -> Map k1 a -> Map k2 a)
188+
189+mapKeysWith :: forall k1 k2 a. Ord k2 => (a -> a -> a) -> (k1 -> k2) -> MonoidalMap k1 a -> MonoidalMap k2 a
190+mapKeysWith = coerce (Map.mapKeysWith :: (a -> a -> a) -> (k1 -> k2) -> Map k1 a -> Map k2 a)
191+
192+mapKeysMonotonic :: forall k1 k2 a. (k1 -> k2) -> MonoidalMap k1 a -> MonoidalMap k2 a
193+mapKeysMonotonic = coerce (Map.mapKeysMonotonic :: (k1 -> k2) -> Map k1 a -> Map k2 a)
194+
195+foldr :: forall k a b. (a -> b -> b) -> b -> MonoidalMap k a -> b
196+foldr = coerce (Map.foldr :: (a -> b -> b) -> b -> Map k a -> b)
197+
198+foldl :: forall k a b. (a -> b -> a) -> a -> MonoidalMap k b -> a
199+foldl = coerce (Map.foldl :: (a -> b -> a) -> a -> Map k b -> a)
200+
201+foldrWithKey :: forall k a b. (k -> a -> b -> b) -> b -> MonoidalMap k a -> b
202+foldrWithKey = coerce (Map.foldrWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b)
203+
204+foldlWithKey :: forall k a b. (a -> k -> b -> a) -> a -> MonoidalMap k b -> a
205+foldlWithKey = coerce (Map.foldlWithKey :: (a -> k -> b -> a) -> a -> Map k b -> a)
206+
207+foldMapWithKey :: forall k a m. Monoid m => (k -> a -> m) -> MonoidalMap k a -> m
208+foldMapWithKey = coerce (Map.foldMapWithKey :: (k -> a -> m) -> Map k a -> m)
209+
210+foldr' :: forall k a b. (a -> b -> b) -> b -> MonoidalMap k a -> b
211+foldr' = coerce (Map.foldr' :: (a -> b -> b) -> b -> Map k a -> b)
212+
213+foldl' :: forall k a b. (a -> b -> a) -> a -> MonoidalMap k b -> a
214+foldl' = coerce (Map.foldl' :: (a -> b -> a) -> a -> Map k b -> a)
215+
216+foldrWithKey' :: forall k a b. (k -> a -> b -> b) -> b -> MonoidalMap k a -> b
217+foldrWithKey' = coerce (Map.foldrWithKey' :: (k -> a -> b -> b) -> b -> Map k a -> b)
218+
219+foldlWithKey' :: forall k a b. (a -> k -> b -> a) -> a -> MonoidalMap k b -> a
220+foldlWithKey' = coerce (Map.foldlWithKey' :: (a -> k -> b -> a) -> a -> Map k b -> a)
221+
222+keysSet :: forall k a. MonoidalMap k a -> Set k
223+keysSet = coerce (Map.keysSet :: Map k a -> Set k)
224+
225+fromSet :: forall k a. (k -> a) -> Set k -> MonoidalMap k a
226+fromSet = coerce (Map.fromSet :: (k -> a) -> Set k -> Map k a)
227+
228+toList :: forall k a. MonoidalMap k a -> [(k, a)]
229+toList = coerce (Map.toList :: Map k a -> [(k, a)])
230+
231+fromList :: forall k a. Ord k => [(k, a)] -> MonoidalMap k a
232+fromList = coerce (Map.fromList :: [(k, a)] -> Map k a)
233+
234+fromListWith :: forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> MonoidalMap k a
235+fromListWith = coerce (Map.fromListWith :: (a -> a -> a) -> [(k, a)] -> Map k a)
236+
237+fromListWithKey :: forall k a. Ord k => (k -> a -> a -> a) -> [(k, a)] -> MonoidalMap k a
238+fromListWithKey = coerce (Map.fromListWithKey :: (k -> a -> a -> a) -> [(k, a)] -> Map k a)
239+
240+toAscList :: forall k a. MonoidalMap k a -> [(k, a)]
241+toAscList = coerce (Map.toAscList :: Map k a -> [(k, a)])
242+
243+toDescList :: forall k a. MonoidalMap k a -> [(k, a)]
244+toDescList = coerce (Map.toDescList :: Map k a -> [(k, a)])
245+
246+fromAscList :: forall k a. Eq k => [(k, a)] -> MonoidalMap k a
247+fromAscList = coerce (Map.fromAscList :: [(k, a)] -> Map k a)
248+
249+fromAscListWith :: forall k a. Eq k => (a -> a -> a) -> [(k, a)] -> MonoidalMap k a
250+fromAscListWith = coerce (Map.fromAscListWith :: (a -> a -> a) -> [(k, a)] -> Map k a)
251+
252+fromAscListWithKey :: forall k a. Eq k => (k -> a -> a -> a) -> [(k, a)] -> MonoidalMap k a
253+fromAscListWithKey = coerce (Map.fromAscListWithKey :: (k -> a -> a -> a) -> [(k, a)] -> Map k a)
254+
255+fromDistinctAscList :: forall k a. [(k, a)] -> MonoidalMap k a
256+fromDistinctAscList = coerce (Map.fromDistinctAscList :: [(k, a)] -> Map k a)
257+
258+filter :: forall k a. (a -> Bool) -> MonoidalMap k a -> MonoidalMap k a
259+filter = coerce (Map.filter :: (a -> Bool) -> Map k a -> Map k a)
260+
261+filterWithKey :: forall k a. (k -> a -> Bool) -> MonoidalMap k a -> MonoidalMap k a
262+filterWithKey = coerce (Map.filterWithKey :: (k -> a -> Bool) -> Map k a -> Map k a)
263+
264+partition :: forall k a. (a -> Bool) -> MonoidalMap k a -> (MonoidalMap k a, MonoidalMap k a)
265+partition = coerce (Map.partition :: (a -> Bool) -> Map k a -> (Map k a, Map k a))
266+
267+partitionWithKey :: forall k a. (k -> a -> Bool) -> MonoidalMap k a -> (MonoidalMap k a, MonoidalMap k a)
268+partitionWithKey = coerce (Map.partitionWithKey :: (k -> a -> Bool) -> Map k a -> (Map k a, Map k a))
269+
270+mapMaybe :: forall k a b. (a -> Maybe b) -> MonoidalMap k a -> MonoidalMap k b
271+mapMaybe = coerce (Map.mapMaybe :: (a -> Maybe b) -> Map k a -> Map k b)
272+
273+mapMaybeWithKey :: forall k a b. (k -> a -> Maybe b) -> MonoidalMap k a -> MonoidalMap k b
274+mapMaybeWithKey = coerce (Map.mapMaybeWithKey :: (k -> a -> Maybe b) -> Map k a -> Map k b)
275+
276+mapEither :: forall k a b c. (a -> Either b c) -> MonoidalMap k a -> (MonoidalMap k b, MonoidalMap k c)
277+mapEither = coerce (Map.mapEither :: (a -> Either b c) -> Map k a -> (Map k b, Map k c))
278+
279+mapEitherWithKey :: forall k a b c. (k -> a -> Either b c) -> MonoidalMap k a -> (MonoidalMap k b, MonoidalMap k c)
280+mapEitherWithKey = coerce (Map.mapEitherWithKey :: (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c))
281+
282+split :: forall k a. Ord k => k -> MonoidalMap k a -> (MonoidalMap k a, MonoidalMap k a)
283+split = coerce (Map.split :: k -> Map k a -> (Map k a, Map k a))
284+
285+splitLookup :: forall k a. Ord k => k -> MonoidalMap k a -> (MonoidalMap k a, Maybe a, MonoidalMap k a)
286+splitLookup = coerce (Map.splitLookup :: k -> Map k a -> (Map k a, Maybe a, Map k a))
287+
288+splitRoot :: forall k a. MonoidalMap k a -> [MonoidalMap k a]
289+splitRoot = coerce (Map.splitRoot :: Map k a -> [Map k a])
290+
291+isSubmapOf :: forall k a. (Ord k, Eq a) => MonoidalMap k a -> MonoidalMap k a -> Bool
292+isSubmapOf = coerce (Map.isSubmapOf :: Map k a -> Map k a -> Bool)
293+
294+isSubmapOfBy :: forall k a b. Ord k => (a -> b -> Bool) -> MonoidalMap k a -> MonoidalMap k b -> Bool
295+isSubmapOfBy = coerce (Map.isSubmapOfBy :: (a -> b -> Bool) -> Map k a -> Map k b -> Bool)
296+
297+isProperSubmapOf :: forall k a. (Ord k, Eq a) => MonoidalMap k a -> MonoidalMap k a -> Bool
298+isProperSubmapOf = coerce (Map.isProperSubmapOf :: Map k a -> Map k a -> Bool)
299+
300+isProperSubmapOfBy :: forall k a b. Ord k => (a -> b -> Bool) -> MonoidalMap k a -> MonoidalMap k b -> Bool
301+isProperSubmapOfBy = coerce (Map.isProperSubmapOfBy :: (a -> b -> Bool) -> Map k a -> Map k b -> Bool)
302+
303+lookupIndex :: forall k a. Ord k => k -> MonoidalMap k a -> Maybe Int
304+lookupIndex = coerce (Map.lookupIndex :: k -> Map k a -> Maybe Int)
305+
306+findIndex :: forall k a. Ord k => k -> MonoidalMap k a -> Int
307+findIndex = coerce (Map.findIndex :: k -> Map k a -> Int)
308+
309+elemAt :: forall k a. Int -> MonoidalMap k a -> (k, a)
310+elemAt = coerce (Map.elemAt :: Int -> Map k a -> (k, a))
311+
312+updateAt :: forall k a. (k -> a -> Maybe a) -> Int -> MonoidalMap k a -> MonoidalMap k a
313+updateAt = coerce (Map.updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a)
314+
315+deleteAt :: forall k a. Int -> MonoidalMap k a -> MonoidalMap k a
316+deleteAt = coerce (Map.deleteAt :: Int -> Map k a -> Map k a)
317+
318+findMin :: forall k a. MonoidalMap k a -> (k, a)
319+findMin = coerce (Map.findMin :: Map k a -> (k, a))
320+
321+findMax :: forall k a. MonoidalMap k a -> (k, a)
322+findMax = coerce (Map.findMax :: Map k a -> (k, a))
323+
324+deleteMin :: forall k a. MonoidalMap k a -> MonoidalMap k a
325+deleteMin = coerce (Map.deleteMin :: Map k a -> Map k a)
326+
327+deleteMax :: forall k a. MonoidalMap k a -> MonoidalMap k a
328+deleteMax = coerce (Map.deleteMax :: Map k a -> Map k a)
329+
330+deleteFindMin :: forall k a. MonoidalMap k a -> ((k, a), MonoidalMap k a)
331+deleteFindMin = coerce (Map.deleteFindMin :: Map k a -> ((k, a), Map k a))
332+
333+deleteFindMax :: forall k a. MonoidalMap k a -> ((k, a), MonoidalMap k a)
334+deleteFindMax = coerce (Map.deleteFindMax :: Map k a -> ((k, a), Map k a))
335+
336+updateMin :: forall k a. (a -> Maybe a) -> MonoidalMap k a -> MonoidalMap k a
337+updateMin = coerce (Map.updateMin :: (a -> Maybe a) -> Map k a -> Map k a)
338+
339+updateMax :: forall k a. (a -> Maybe a) -> MonoidalMap k a -> MonoidalMap k a
340+updateMax = coerce (Map.updateMax :: (a -> Maybe a) -> Map k a -> Map k a)
341+
342+updateMinWithKey :: forall k a. (k -> a -> Maybe a) -> MonoidalMap k a -> MonoidalMap k a
343+updateMinWithKey = coerce (Map.updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a)
344+
345+updateMaxWithKey :: forall k a. (k -> a -> Maybe a) -> MonoidalMap k a -> MonoidalMap k a
346+updateMaxWithKey = coerce (Map.updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a)
347+
348+minView :: forall k a. MonoidalMap k a -> Maybe (a, MonoidalMap k a)
349+minView = coerce (Map.minView :: Map k a -> Maybe (a, Map k a))
350+
351+maxView :: forall k a. MonoidalMap k a -> Maybe (a, MonoidalMap k a)
352+maxView = coerce (Map.maxView :: Map k a -> Maybe (a, Map k a))
353+
354+minViewWithKey :: forall k a. MonoidalMap k a -> Maybe ((k, a), MonoidalMap k a)
355+minViewWithKey = coerce (Map.minViewWithKey :: Map k a -> Maybe ((k, a), Map k a))
356+
357+maxViewWithKey :: forall k a. MonoidalMap k a -> Maybe ((k, a), MonoidalMap k a)
358+maxViewWithKey = coerce (Map.maxViewWithKey :: Map k a -> Maybe ((k, a), Map k a))
359+
360+showTree :: forall k a. (Show k, Show a) => MonoidalMap k a -> String
361+showTree = coerce (Map.showTree :: Map k a -> String)
362+
363+showTreeWith :: forall k a. (k -> a -> String) -> Bool -> Bool -> MonoidalMap k a -> String
364+showTreeWith = coerce (Map.showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String)
365+
366+valid :: forall k a. Ord k => MonoidalMap k a -> Bool
367+valid = coerce (Map.valid :: Map k a -> Bool)
368+
369+instance Default (MonoidalMap k a) where
370+ def = empty
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 Prelude hiding (lookup)
26+
27+import Control.Monad.IO.Class
28+import Data.Foldable (traverse_)
29+import Data.IntMap.Strict (IntMap)
30+import qualified Data.IntMap.Strict as IntMap
31+import Data.IORef
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+156
@@ -0,0 +1,156 @@
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 Prelude hiding (traverse)
30+
31+import Control.Monad
32+import Control.Monad.IO.Class
33+
34+#ifdef GHCJS_FAST_WEAK
35+import GHCJS.Types
36+import Reflex.FastWeak (js_isNull, unsafeFromRawJSVal, unsafeToRawJSVal)
37+#else
38+import Control.Exception
39+import Data.IntMap.Strict (IntMap)
40+import qualified Data.IntMap.Strict as IntMap
41+import Data.IORef
42+import System.Mem.Weak
43+#endif
44+
45+-- | A @FastWeakBag a@ holds a set of values of type @a@, but does not retain them -
46+-- that is, they can still be garbage-collected. As long as the @a@s remain
47+-- alive, the 'FastWeakBag' will continue to refer to them.
48+#ifdef GHCJS_FAST_WEAK
49+newtype FastWeakBag a = FastWeakBag JSVal
50+#else
51+data FastWeakBag a = FastWeakBag
52+ { _weakBag_nextId :: {-# UNPACK #-} !(IORef Int) --TODO: what if this wraps around?
53+ , _weakBag_children :: {-# UNPACK #-} !(IORef (IntMap (Weak a)))
54+ }
55+#endif
56+
57+-- | When inserting an item into a 'FastWeakBag', a 'FastWeakBagTicket' is returned. If
58+-- the caller retains the ticket, the item is guranteed to stay in memory (and
59+-- thus in the 'FastWeakBag'). The ticket can also be used to remove the item from
60+-- the 'FastWeakBag' prematurely (i.e. while it is still alive), using 'remove'.
61+#ifdef GHCJS_FAST_WEAK
62+newtype FastWeakBagTicket a = FastWeakBagTicket JSVal
63+#else
64+data FastWeakBagTicket a = FastWeakBagTicket
65+ { _weakBagTicket_weakItem :: {-# UNPACK #-} !(Weak a)
66+ , _weakBagTicket_item :: {-# NOUNPACK #-} !a
67+ }
68+#endif
69+
70+-- | Insert an item into a 'FastWeakBag'.
71+{-# INLINE insert #-}
72+insert :: a -- ^ The item
73+ -> FastWeakBag a -- ^ The 'FastWeakBag' to insert into
74+ -> IO (FastWeakBagTicket a) -- ^ Returns a 'FastWeakBagTicket' that ensures the item
75+ -- is retained and allows the item to be removed.
76+#ifdef GHCJS_FAST_WEAK
77+insert a wb = js_insert (unsafeToRawJSVal a) wb
78+foreign import javascript unsafe "$r = new h$FastWeakBagTicket($2, $1);" js_insert :: JSVal -> FastWeakBag a -> IO (FastWeakBagTicket a)
79+#else
80+insert a (FastWeakBag nextId children) = {-# SCC "insert" #-} do
81+ a' <- evaluate a
82+ myId <- atomicModifyIORef' nextId $ \n -> (succ n, n)
83+ let cleanup = atomicModifyIORef' children $ \cs -> (IntMap.delete myId cs, ())
84+ wa <- mkWeakPtr a' $ Just cleanup
85+ atomicModifyIORef' children $ \cs -> (IntMap.insert myId wa cs, ())
86+ return $ FastWeakBagTicket
87+ { _weakBagTicket_weakItem = wa
88+ , _weakBagTicket_item = a'
89+ }
90+#endif
91+
92+-- | Create an empty 'FastWeakBag'.
93+{-# INLINE empty #-}
94+empty :: IO (FastWeakBag a)
95+#ifdef GHCJS_FAST_WEAK
96+empty = js_empty
97+foreign import javascript unsafe "$r = new h$FastWeakBag();" js_empty :: IO (FastWeakBag a)
98+#else
99+empty = {-# SCC "empty" #-} do
100+ nextId <- newIORef 1
101+ children <- newIORef IntMap.empty
102+ let bag = FastWeakBag
103+ { _weakBag_nextId = nextId
104+ , _weakBag_children = children
105+ }
106+ return bag
107+#endif
108+
109+-- | Check whether a 'FastWeakBag' is empty.
110+{-# INLINE isEmpty #-}
111+isEmpty :: FastWeakBag a -> IO Bool
112+#ifdef GHCJS_FAST_WEAK
113+isEmpty = js_isEmpty
114+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
115+#else
116+isEmpty bag = {-# SCC "isEmpty" #-} IntMap.null <$> readIORef (_weakBag_children bag)
117+#endif
118+
119+{-# INLINE traverse #-}
120+-- | Visit every node in the given list. If new nodes are appended during the
121+-- traversal, they will not be visited. Every live node that was in the list
122+-- when the traversal began will be visited exactly once; however, no guarantee
123+-- is made about the order of the traversal.
124+traverse :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m ()
125+#ifdef GHCJS_FAST_WEAK
126+traverse wb f = do
127+ let go cursor = when (not $ js_isNull cursor) $ do
128+ val <- liftIO $ js_getTicketValue cursor
129+ f $ unsafeFromRawJSVal val
130+ go =<< liftIO (js_getNext (FastWeakBagTicket cursor))
131+ go =<< liftIO (js_getInitial wb)
132+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
133+foreign import javascript unsafe "$r = $1.val;" js_getTicketValue :: JSVal -> IO JSVal
134+--TODO: Fix the race condition where if a cursor is deleted (presumably using 'remove', below) while we're holding it, it can't find its way back to the correct bag
135+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
136+#else
137+traverse (FastWeakBag _ children) f = {-# SCC "traverse" #-} do
138+ cs <- liftIO $ readIORef children
139+ forM_ cs $ \c -> do
140+ ma <- liftIO $ deRefWeak c
141+ mapM_ f ma
142+#endif
143+
144+-- | Remove an item from the 'FastWeakBag'; does nothing if invoked multiple times
145+-- on the same 'FastWeakBagTicket'.
146+{-# INLINE remove #-}
147+remove :: FastWeakBagTicket a -> IO ()
148+#ifdef GHCJS_FAST_WEAK
149+remove = js_remove
150+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
151+#else
152+remove (FastWeakBagTicket w _) = {-# SCC "remove" #-} finalize w
153+#endif
154+--TODO: Should 'remove' also drop the reference to the item?
155+
156+--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 (isLeft)
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+121
@@ -0,0 +1,121 @@
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 Prelude hiding (traverse)
25+
26+import Control.Exception
27+import Control.Monad
28+import Control.Monad.IO.Class
29+import Data.IntMap.Strict (IntMap)
30+import qualified Data.IntMap.Strict as IntMap
31+import Data.IORef
32+import System.Mem.Weak
33+
34+-- | A @WeakBag a@ holds a set of values of type @a@, but does not retain them -
35+-- that is, they can still be garbage-collected. As long as the @a@s remain
36+-- alive, the 'WeakBag' will continue to refer to them.
37+data WeakBag a = WeakBag
38+ { _weakBag_nextId :: {-# UNPACK #-} !(IORef Int) --TODO: what if this wraps around?
39+ , _weakBag_children :: {-# UNPACK #-} !(IORef (IntMap (Weak a))) -- ^ The items referenced by the WeakBag
40+ }
41+
42+-- | When inserting an item into a 'WeakBag', a 'WeakBagTicket' is returned. If
43+-- the caller retains the ticket, the item is guranteed to stay in memory (and
44+-- thus in the 'WeakBag'). The ticket can also be used to remove the item from
45+-- the 'WeakBag' prematurely (i.e. while it is still alive), using 'remove'.
46+data WeakBagTicket = forall a. WeakBagTicket
47+ { _weakBagTicket_weakItem :: {-# UNPACK #-} !(Weak a)
48+ , _weakBagTicket_item :: {-# NOUNPACK #-} !a
49+ }
50+
51+-- | Insert an item into a 'WeakBag'.
52+{-# INLINE insert #-}
53+insert :: a -- ^ The item
54+ -> WeakBag a -- ^ The 'WeakBag' to insert into
55+ -> IORef (Weak b) -- ^ An arbitrary value to be used in the following
56+ -- callback
57+ -> (b -> IO ()) -- ^ A callback to be invoked when the item is removed
58+ -- (whether automatically by the item being garbage
59+ -- collected or manually via 'remove')
60+ -> IO WeakBagTicket -- ^ Returns a 'WeakBagTicket' that ensures the item
61+ -- is retained and allows the item to be removed.
62+insert a (WeakBag nextId children) wbRef finalizer = {-# SCC "insert" #-} do
63+ a' <- evaluate a
64+ wbRef' <- evaluate wbRef
65+ myId <- atomicModifyIORef' nextId $ \n -> (succ n, n)
66+ let cleanup = do
67+ wb <- readIORef wbRef'
68+ mb <- deRefWeak wb
69+ forM_ mb $ \b -> do
70+ csWithoutMe <- atomicModifyIORef children $ \cs ->
71+ let !csWithoutMe = IntMap.delete myId cs
72+ in (csWithoutMe, csWithoutMe)
73+ when (IntMap.null csWithoutMe) $ finalizer b
74+ wa <- mkWeakPtr a' $ Just cleanup
75+ atomicModifyIORef' children $ \cs -> (IntMap.insert myId wa cs, ())
76+ return $ WeakBagTicket
77+ { _weakBagTicket_weakItem = wa
78+ , _weakBagTicket_item = a'
79+ }
80+
81+-- | Create an empty 'WeakBag'.
82+{-# INLINE empty #-}
83+empty :: IO (WeakBag a)
84+empty = {-# SCC "empty" #-} do
85+ nextId <- newIORef 1
86+ children <- newIORef IntMap.empty
87+ let bag = WeakBag
88+ { _weakBag_nextId = nextId
89+ , _weakBag_children = children
90+ }
91+ return bag
92+
93+-- | Create a 'WeakBag' with one item; equivalent to creating the 'WeakBag' with
94+-- 'empty', then using 'insert'.
95+{-# INLINE singleton #-}
96+singleton :: a -> IORef (Weak b) -> (b -> IO ()) -> IO (WeakBag a, WeakBagTicket)
97+singleton a wbRef finalizer = {-# SCC "singleton" #-} do
98+ bag <- empty
99+ ticket <- insert a bag wbRef finalizer
100+ return (bag, ticket)
101+
102+{-# INLINE traverse #-}
103+-- | Visit every node in the given list. If new nodes are appended during the
104+-- traversal, they will not be visited. Every live node that was in the list
105+-- when the traversal began will be visited exactly once; however, no guarantee
106+-- is made about the order of the traversal.
107+traverse :: MonadIO m => WeakBag a -> (a -> m ()) -> m ()
108+traverse (WeakBag _ children) f = {-# SCC "traverse" #-} do
109+ cs <- liftIO $ readIORef children
110+ forM_ cs $ \c -> do
111+ ma <- liftIO $ deRefWeak c
112+ mapM_ f ma
113+
114+-- | Remove an item from the 'WeakBag'; does nothing if invoked multiple times
115+-- on the same 'WeakBagTicket'.
116+{-# INLINE remove #-}
117+remove :: WeakBagTicket -> IO ()
118+remove (WeakBagTicket w _) = {-# SCC "remove" #-} finalize w
119+--TODO: Should 'remove' also drop the reference to the item?
120+
121+--TODO: can/should we provide a null WeakBagTicket?
src/Reflex.hsnew file+32
@@ -0,0 +1,32 @@
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.Adjustable.Class as X
10+import Reflex.Collection as X
11+import Reflex.Dynamic as X
12+import Reflex.EventWriter.Base as X
13+import Reflex.EventWriter.Class as X
14+#ifdef USE_TEMPLATE_HASKELL
15+import Reflex.Dynamic.TH as X
16+#endif
17+import Reflex.Dynamic.Uniq as X
18+import Reflex.DynamicWriter.Base as X
19+import Reflex.DynamicWriter.Class as X
20+import Reflex.PerformEvent.Base as X
21+import Reflex.PerformEvent.Class as X
22+import Reflex.PostBuild.Base as X
23+import Reflex.PostBuild.Class as X
24+import Reflex.Profiled as X
25+import Reflex.Query.Base as X
26+import Reflex.Query.Class as X
27+import Reflex.Requester.Base as X
28+import Reflex.Requester.Class as X
29+import Reflex.Spider as X
30+import Reflex.Time as X
31+import Reflex.TriggerEvent.Base as X
32+import Reflex.TriggerEvent.Class as X
src/Reflex/Adjustable/Class.hsnew file+77
@@ -0,0 +1,77 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ConstraintKinds #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE FunctionalDependencies #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE RankNTypes #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeFamilies #-}
9+{-# LANGUAGE UndecidableInstances #-}
10+#ifdef USE_REFLEX_OPTIMIZER
11+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
12+#endif
13+module Reflex.Adjustable.Class
14+ (
15+ -- * The Adjustable typeclass
16+ Adjustable(..)
17+ , sequenceDMapWithAdjust
18+ , sequenceDMapWithAdjustWithMove
19+ , mapMapWithAdjustWithMove
20+ -- * Deprecated aliases
21+ , MonadAdjust
22+ ) where
23+
24+import Control.Monad.Identity
25+import Control.Monad.Reader
26+import Data.Dependent.Map (DMap, GCompare (..))
27+import Data.Functor.Constant
28+import Data.Functor.Misc
29+import Data.IntMap.Strict (IntMap)
30+import qualified Data.IntMap.Strict as IntMap
31+import Data.Map (Map)
32+
33+import Reflex.Class
34+
35+-- | A 'Monad' that supports adjustment over time. After an action has been
36+-- run, if the given events fire, it will adjust itself so that its net effect
37+-- is as though it had originally been run with the new value. Note that there
38+-- is some issue here with persistent side-effects: obviously, IO (and some
39+-- other side-effects) cannot be undone, so it is up to the instance implementer
40+-- to determine what the best meaning for this class is in such cases.
41+class (Reflex t, Monad m) => Adjustable t m | m -> t where
42+ runWithReplace :: m a -> Event t (m b) -> m (a, Event t b)
43+ traverseIntMapWithKeyWithAdjust :: (IntMap.Key -> v -> m v') -> IntMap v -> Event t (PatchIntMap v) -> m (IntMap v', Event t (PatchIntMap v'))
44+ 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'))
45+ 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'))
46+
47+instance Adjustable t m => Adjustable t (ReaderT r m) where
48+ runWithReplace a0 a' = do
49+ r <- ask
50+ lift $ runWithReplace (runReaderT a0 r) $ fmap (`runReaderT` r) a'
51+ traverseIntMapWithKeyWithAdjust f dm0 dm' = do
52+ r <- ask
53+ lift $ traverseIntMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'
54+ traverseDMapWithKeyWithAdjust f dm0 dm' = do
55+ r <- ask
56+ lift $ traverseDMapWithKeyWithAdjust (\k v -> runReaderT (f k v) r) dm0 dm'
57+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do
58+ r <- ask
59+ lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runReaderT (f k v) r) dm0 dm'
60+
61+sequenceDMapWithAdjust :: (GCompare k, Adjustable t m) => DMap k m -> Event t (PatchDMap k m) -> m (DMap k Identity, Event t (PatchDMap k Identity))
62+sequenceDMapWithAdjust = traverseDMapWithKeyWithAdjust $ \_ -> fmap Identity
63+
64+sequenceDMapWithAdjustWithMove :: (GCompare k, Adjustable t m) => DMap k m -> Event t (PatchDMapWithMove k m) -> m (DMap k Identity, Event t (PatchDMapWithMove k Identity))
65+sequenceDMapWithAdjustWithMove = traverseDMapWithKeyWithAdjustWithMove $ \_ -> fmap Identity
66+
67+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'))
68+mapMapWithAdjustWithMove f m0 m' = do
69+ (out0 :: DMap (Const2 k v) (Constant v'), out') <- traverseDMapWithKeyWithAdjustWithMove (\(Const2 k) (Identity v) -> Constant <$> f k v) (mapToDMap m0) (const2PatchDMapWithMoveWith Identity <$> m')
70+ return (dmapToMapWith (\(Constant v') -> v') out0, patchDMapWithMoveToPatchMapWithMoveWith (\(Constant v') -> v') <$> out')
71+
72+--------------------------------------------------------------------------------
73+-- Deprecated functions
74+--------------------------------------------------------------------------------
75+
76+{-# DEPRECATED MonadAdjust "Use Adjustable instead" #-}
77+type MonadAdjust = Adjustable
src/Reflex/Class.hsnew file+1133
@@ -0,0 +1,1133 @@
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+ -- * Miscellaneous convenience functions
124+ , ffor
125+ -- * Deprecated functions
126+ , appendEvents
127+ , onceE
128+ , sequenceThese
129+ , fmapMaybeCheap
130+ , fmapCheap
131+ , fforCheap
132+ , fforMaybeCheap
133+ , pushAlwaysCheap
134+ , tagCheap
135+ , mergeWithCheap
136+ , mergeWithCheap'
137+ , switchPromptly
138+ , switchPromptOnly
139+ -- * Slow, but general, implementations
140+ , slowHeadE
141+ ) where
142+
143+import Control.Applicative
144+import Control.Monad.Identity
145+import Control.Monad.Reader
146+import Control.Monad.State.Strict
147+import Control.Monad.Trans.Cont (ContT)
148+import Control.Monad.Trans.Except (ExceptT)
149+import Control.Monad.Trans.RWS (RWST)
150+import Control.Monad.Trans.Writer (WriterT)
151+import Data.Align
152+import Data.Bifunctor
153+import Data.Coerce
154+import Data.Default
155+import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
156+import qualified Data.Dependent.Map as DMap
157+import Data.FastMutableIntMap (PatchIntMap)
158+import Data.Foldable
159+import Data.Functor.Bind
160+import Data.Functor.Misc
161+import Data.Functor.Plus
162+import Data.IntMap.Strict (IntMap)
163+import qualified Data.IntMap.Strict as IntMap
164+import Data.List.NonEmpty (NonEmpty (..))
165+import Data.Map (Map)
166+import Data.Semigroup (Semigroup, sconcat, stimes, (<>))
167+import Data.String
168+import Data.These
169+import Data.Type.Coercion
170+import Reflex.FunctorMaybe
171+import Reflex.Patch
172+
173+import Debug.Trace (trace)
174+
175+-- | The 'Reflex' class contains all the primitive functionality needed for
176+-- Functional Reactive Programming (FRP). The @t@ type parameter indicates
177+-- which "timeline" is in use. Timelines are fully-independent FRP contexts,
178+-- and the type of the timeline determines the FRP engine to be used. For most
179+-- purposes, the 'Reflex.Spider' implementation is recommended.
180+class ( MonadHold t (PushM t)
181+ , MonadSample t (PullM t)
182+ , MonadFix (PushM t)
183+ , Functor (Dynamic t)
184+ , Applicative (Dynamic t) -- Necessary for GHC <= 7.8
185+ , Monad (Dynamic t)
186+ ) => Reflex t where
187+ -- | A container for a value that can change over time. 'Behavior's can be
188+ -- sampled at will, but it is not possible to be notified when they change
189+ data Behavior t :: * -> *
190+ -- | A stream of occurrences. During any given frame, an 'Event' is either
191+ -- occurring or not occurring; if it is occurring, it will contain a value of
192+ -- the given type (its "occurrence type")
193+ data Event t :: * -> *
194+ -- | A container for a value that can change over time and allows
195+ -- notifications on changes. Basically a combination of a 'Behavior' and an
196+ -- 'Event', with a rule that the 'Behavior' will change if and only if the
197+ -- 'Event' fires.
198+ data Dynamic t :: * -> *
199+ -- | An 'Incremental' is a more general form of a 'Dynamic'.
200+ -- Instead of always fully replacing the value, only parts of it can be patched.
201+ -- This is only needed for performance critical code via `mergeIncremental` to make small
202+ -- changes to large values.
203+ data Incremental t :: * -> *
204+ -- | A monad for doing complex push-based calculations efficiently
205+ type PushM t :: * -> *
206+ -- | A monad for doing complex pull-based calculations efficiently
207+ type PullM t :: * -> *
208+ -- | An 'Event' with no occurrences
209+ never :: Event t a
210+ -- | Create a 'Behavior' that always has the given value
211+ 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
212+ -- | Create an 'Event' from another 'Event'; the provided function can sample
213+ -- 'Behavior's and hold 'Event's, and use the results to produce a occurring
214+ -- (Just) or non-occurring (Nothing) result
215+ push :: (a -> PushM t (Maybe b)) -> Event t a -> Event t b
216+ -- | 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.
217+ pushCheap :: (a -> PushM t (Maybe b)) -> Event t a -> Event t b
218+ -- | Create a 'Behavior' by reading from other 'Behavior's; the result will be
219+ -- recomputed whenever any of the read 'Behavior's changes
220+ pull :: PullM t a -> Behavior t a
221+ -- | Merge a collection of events; the resulting 'Event' will only occur if at
222+ -- least one input event is occurring, and will contain all of the input keys
223+ -- that are occurring simultaneously
224+ 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
225+ -- | Efficiently fan-out an event to many destinations. This function should
226+ -- be partially applied, and then the result applied repeatedly to create
227+ -- child events
228+ 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
229+ -- | Create an 'Event' that will occur whenever the currently-selected input
230+ -- 'Event' occurs
231+ switch :: Behavior t (Event t a) -> Event t a
232+ -- | Create an 'Event' that will occur whenever the input event is occurring
233+ -- and its occurrence value, another 'Event', is also occurring
234+ coincidence :: Event t (Event t a) -> Event t a
235+ -- | Extract the 'Behavior' of a 'Dynamic'.
236+ current :: Dynamic t a -> Behavior t a
237+ -- | Extract the 'Event' of the 'Dynamic'.
238+ updated :: Dynamic t a -> Event t a
239+ -- | Create a new 'Dynamic'. The given 'PullM' must always return the most
240+ -- recent firing of the given 'Event', if any.
241+ unsafeBuildDynamic :: PullM t a -> Event t a -> Dynamic t a
242+ -- | Create a new 'Incremental'. The given 'PullM''s value must always change
243+ -- in the same way that the accumulated application of patches would change
244+ -- that value.
245+ unsafeBuildIncremental :: Patch p => PullM t (PatchTarget p) -> Event t p -> Incremental t p
246+ -- | Create a merge whose parents can change over time
247+ mergeIncremental :: GCompare k => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)
248+ -- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental
249+ mergeIncrementalWithMove :: GCompare k => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity)
250+ -- | Extract the 'Behavior' component of an 'Incremental'
251+ currentIncremental :: Patch p => Incremental t p -> Behavior t (PatchTarget p)
252+ -- | Extract the 'Event' component of an 'Incremental'
253+ updatedIncremental :: Patch p => Incremental t p -> Event t p
254+ -- | Convert an 'Incremental' to a 'Dynamic'
255+ incrementalToDynamic :: Patch p => Incremental t p -> Dynamic t (PatchTarget p)
256+ -- | Construct a 'Coercion' for a 'Behavior' given an 'Coercion' for its
257+ -- occurrence type
258+ behaviorCoercion :: Coercion a b -> Coercion (Behavior t a) (Behavior t b)
259+ -- | Construct a 'Coercion' for an 'Event' given an 'Coercion' for its
260+ -- occurrence type
261+ eventCoercion :: Coercion a b -> Coercion (Event t a) (Event t b)
262+ -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its
263+ -- occurrence type
264+ dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)
265+ mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)
266+ fanInt :: Event t (IntMap a) -> EventSelectorInt t a
267+
268+--TODO: Specialize this so that we can take advantage of knowing that there's no changing going on
269+mergeInt :: Reflex t => IntMap (Event t a) -> Event t (IntMap a)
270+mergeInt m = mergeIntIncremental $ unsafeBuildIncremental (return m) never
271+
272+-- | Coerce a 'Behavior' between representationally-equivalent value types
273+coerceBehavior :: (Reflex t, Coercible a b) => Behavior t a -> Behavior t b
274+coerceBehavior = coerceWith $ behaviorCoercion Coercion
275+
276+-- | Coerce an 'Event' between representationally-equivalent occurrence types
277+coerceEvent :: (Reflex t, Coercible a b) => Event t a -> Event t b
278+coerceEvent = coerceWith $ eventCoercion Coercion
279+
280+-- | Coerce a 'Dynamic' between representationally-equivalent value types
281+coerceDynamic :: (Reflex t, Coercible a b) => Dynamic t a -> Dynamic t b
282+coerceDynamic = coerceWith $ dynamicCoercion Coercion
283+
284+-- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'. The 'Behavior'
285+-- _must_ change when and only when the 'Event' fires, such that the
286+-- 'Behavior''s value is always equal to the most recent firing of the 'Event';
287+-- if this is not the case, the resulting 'Dynamic' will behave
288+-- nondeterministically.
289+unsafeDynamic :: Reflex t => Behavior t a -> Event t a -> Dynamic t a
290+unsafeDynamic = unsafeBuildDynamic . sample
291+
292+-- | Construct a 'Dynamic' value that never changes
293+constDyn :: Reflex t => a -> Dynamic t a
294+constDyn = pure
295+
296+instance (Reflex t, Default a) => Default (Dynamic t a) where
297+ def = pure def
298+
299+-- | 'MonadSample' designates monads that can read the current value of a
300+-- 'Behavior'. This includes both 'PullM' and 'PushM'.
301+class (Applicative m, Monad m) => MonadSample t m | m -> t where
302+ -- | Get the current value in the 'Behavior'
303+ sample :: Behavior t a -> m a
304+
305+-- | 'MonadHold' designates monads that can create new 'Behavior's based on
306+-- 'Event's; usually this will be 'PushM' or a monad based on it. 'MonadHold'
307+-- is required to create any stateful computations with Reflex.
308+class MonadSample t m => MonadHold t m where
309+ -- | Create a new 'Behavior' whose value will initially be equal to the given
310+ -- value and will be updated whenever the given 'Event' occurs. The update
311+ -- takes effect immediately after the 'Event' occurs; if the occurrence that
312+ -- sets the 'Behavior' (or one that is simultaneous with it) is used to sample
313+ -- the 'Behavior', it will see the _old_ value of the 'Behavior', not the new
314+ -- one.
315+ hold :: a -> Event t a -> m (Behavior t a)
316+ default hold :: (m ~ f m', MonadTrans f, MonadHold t m') => a -> Event t a -> m (Behavior t a)
317+ hold v0 = lift . hold v0
318+ -- | Create a 'Dynamic' value using the given initial value that changes every
319+ -- time the 'Event' occurs.
320+ holdDyn :: a -> Event t a -> m (Dynamic t a)
321+ default holdDyn :: (m ~ f m', MonadTrans f, MonadHold t m') => a -> Event t a -> m (Dynamic t a)
322+ holdDyn v0 = lift . holdDyn v0
323+ -- | Create an 'Incremental' value using the given initial value that changes
324+ -- every time the 'Event' occurs.
325+ holdIncremental :: Patch p => PatchTarget p -> Event t p -> m (Incremental t p)
326+ default holdIncremental :: (Patch p, m ~ f m', MonadTrans f, MonadHold t m') => PatchTarget p -> Event t p -> m (Incremental t p)
327+ holdIncremental v0 = lift . holdIncremental v0
328+ buildDynamic :: PullM t a -> Event t a -> m (Dynamic t a)
329+ {-
330+ default buildDynamic :: (m ~ f m', MonadTrans f, MonadHold t m') => PullM t a -> Event t a -> m (Dynamic t a)
331+ buildDynamic getV0 = lift . buildDynamic getV0
332+ -}
333+ -- | Create a new 'Event' that only occurs only once, on the first occurrence of
334+ -- the supplied 'Event'.
335+ headE :: Event t a -> m (Event t a)
336+
337+
338+slowHeadE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a)
339+slowHeadE e = do
340+ rec be <- hold e $ fmapCheap (const never) e'
341+ let e' = switch be
342+ return e'
343+
344+-- | An 'EventSelector' allows you to efficiently 'select' an 'Event' based on a
345+-- key. This is much more efficient than filtering for each key with
346+-- 'fmapMaybe'.
347+newtype EventSelector t k = EventSelector
348+ { -- | Retrieve the 'Event' for the given key. The type of the 'Event' is
349+ -- determined by the type of the key, so this can be used to fan-out
350+ -- 'Event's whose sub-'Event's have different types.
351+ --
352+ -- Using 'EventSelector's and the 'fan' primitive is far more efficient than
353+ -- (but equivalent to) using 'fmapMaybe' to select only the relevant
354+ -- occurrences of an 'Event'.
355+ select :: forall a. k a -> Event t a
356+ }
357+
358+newtype EventSelectorInt t a = EventSelectorInt { selectInt :: Int -> Event t a }
359+
360+--------------------------------------------------------------------------------
361+-- Instances
362+--------------------------------------------------------------------------------
363+
364+instance MonadSample t m => MonadSample t (ReaderT r m) where
365+ sample = lift . sample
366+
367+instance MonadHold t m => MonadHold t (ReaderT r m) where
368+ hold a0 = lift . hold a0
369+ holdDyn a0 = lift . holdDyn a0
370+ holdIncremental a0 = lift . holdIncremental a0
371+ buildDynamic a0 = lift . buildDynamic a0
372+ headE = lift . headE
373+
374+instance (MonadSample t m, Monoid r) => MonadSample t (WriterT r m) where
375+ sample = lift . sample
376+
377+instance (MonadHold t m, Monoid r) => MonadHold t (WriterT r m) where
378+ hold a0 = lift . hold a0
379+ holdDyn a0 = lift . holdDyn a0
380+ holdIncremental a0 = lift . holdIncremental a0
381+ buildDynamic a0 = lift . buildDynamic a0
382+ headE = lift . headE
383+
384+instance MonadSample t m => MonadSample t (StateT s m) where
385+ sample = lift . sample
386+
387+instance MonadHold t m => MonadHold t (StateT s m) where
388+ hold a0 = lift . hold a0
389+ holdDyn a0 = lift . holdDyn a0
390+ holdIncremental a0 = lift . holdIncremental a0
391+ buildDynamic a0 = lift . buildDynamic a0
392+ headE = lift . headE
393+
394+instance MonadSample t m => MonadSample t (ExceptT e m) where
395+ sample = lift . sample
396+
397+instance MonadHold t m => MonadHold t (ExceptT e m) where
398+ hold a0 = lift . hold a0
399+ holdDyn a0 = lift . holdDyn a0
400+ holdIncremental a0 = lift . holdIncremental a0
401+ buildDynamic a0 = lift . buildDynamic a0
402+ headE = lift . headE
403+
404+instance (MonadSample t m, Monoid w) => MonadSample t (RWST r w s m) where
405+ sample = lift . sample
406+
407+instance (MonadHold t m, Monoid w) => MonadHold t (RWST r w s m) where
408+ hold a0 = lift . hold a0
409+ holdDyn a0 = lift . holdDyn a0
410+ holdIncremental a0 = lift . holdIncremental a0
411+ buildDynamic a0 = lift . buildDynamic a0
412+ headE = lift . headE
413+
414+instance MonadSample t m => MonadSample t (ContT r m) where
415+ sample = lift . sample
416+
417+instance MonadHold t m => MonadHold t (ContT r m) where
418+ hold a0 = lift . hold a0
419+ holdDyn a0 = lift . holdDyn a0
420+ holdIncremental a0 = lift . holdIncremental a0
421+ buildDynamic a0 = lift . buildDynamic a0
422+ headE = lift . headE
423+
424+--------------------------------------------------------------------------------
425+-- Convenience functions
426+--------------------------------------------------------------------------------
427+
428+-- | Create an 'Event' from another 'Event'. The provided function can sample
429+-- 'Behavior's and hold 'Event's.
430+pushAlways :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b
431+pushAlways f = push (fmap Just . f)
432+
433+-- | Flipped version of 'fmap'.
434+ffor :: Functor f => f a -> (a -> b) -> f b
435+ffor = flip fmap
436+
437+instance Reflex t => Applicative (Behavior t) where
438+ pure = constant
439+ f <*> x = pull $ sample f `ap` sample x
440+ _ *> b = b
441+ a <* _ = a
442+
443+instance Reflex t => Apply (Behavior t) where
444+ (<.>) = (<*>)
445+
446+instance Reflex t => Bind (Behavior t) where
447+ (>>-) = (>>=)
448+
449+instance (Reflex t, Fractional a) => Fractional (Behavior t a) where
450+ (/) = liftA2 (/)
451+ fromRational = pure . fromRational
452+ recip = fmap recip
453+
454+instance Reflex t => Functor (Behavior t) where
455+ fmap f = pull . fmap f . sample
456+
457+instance (Reflex t, IsString a) => IsString (Behavior t a) where
458+ fromString = pure . fromString
459+
460+instance Reflex t => Monad (Behavior t) where
461+ a >>= f = pull $ sample a >>= sample . f
462+ -- 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.
463+ return = constant
464+ fail = error "Monad (Behavior t) does not support fail"
465+
466+instance (Reflex t, Monoid a) => Monoid (Behavior t a) where
467+ mempty = constant mempty
468+ mappend a b = pull $ liftM2 mappend (sample a) (sample b)
469+ mconcat = pull . fmap mconcat . mapM sample
470+
471+instance (Reflex t, Num a) => Num (Behavior t a) where
472+ (+) = liftA2 (+)
473+ (-) = liftA2 (-)
474+ (*) = liftA2 (*)
475+ abs = fmap abs
476+ fromInteger = pure . fromInteger
477+ negate = fmap negate
478+ signum = fmap signum
479+
480+instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where
481+ a <> b = pull $ liftM2 (<>) (sample a) (sample b)
482+ sconcat = pull . fmap sconcat . mapM sample
483+#if MIN_VERSION_semigroups(0,17,0)
484+ stimes n = fmap $ stimes n
485+#else
486+ times1p n = fmap $ times1p n
487+#endif
488+
489+-- | Flipped version of 'fmapMaybe'.
490+fforMaybe :: FunctorMaybe f => f a -> (a -> Maybe b) -> f b
491+fforMaybe = flip fmapMaybe
492+
493+-- | Filter 'f a' using the provided predicate.
494+-- Relies on 'fforMaybe'.
495+ffilter :: FunctorMaybe f => (a -> Bool) -> f a -> f a
496+ffilter f = fmapMaybe $ \x -> if f x then Just x else Nothing
497+
498+-- | Filter 'Left's from 'f (Either a b)' into 'a'.
499+filterLeft :: FunctorMaybe f => f (Either a b) -> f a
500+filterLeft = fmapMaybe (either Just (const Nothing))
501+
502+-- | Filter 'Right's from 'f (Either a b)' into 'b'.
503+filterRight :: FunctorMaybe f => f (Either a b) -> f b
504+filterRight = fmapMaybe (either (const Nothing) Just)
505+
506+-- | Left-biased event union (prefers left event on simultaneous
507+-- occurrence).
508+instance Reflex t => Alt (Event t) where
509+ ev1 <!> ev2 = leftmost [ev1, ev2]
510+
511+-- | 'Event' intersection (convenient interface to 'coincidence').
512+instance Reflex t => Apply (Event t) where
513+ evf <.> evx = coincidence (fmap (<$> evx) evf)
514+
515+-- | 'Event' intersection (convenient interface to 'coincidence').
516+instance Reflex t => Bind (Event t) where
517+ evx >>- f = coincidence (f <$> evx)
518+ join = coincidence
519+
520+instance Reflex t => Functor (Event t) where
521+ {-# INLINE fmap #-}
522+ fmap f = fmapMaybe $ Just . f
523+ {-# INLINE (<$) #-}
524+ x <$ e = fmapCheap (const x) e
525+
526+instance Reflex t => FunctorMaybe (Event t) where
527+ {-# INLINE fmapMaybe #-}
528+ fmapMaybe f = push $ return . f
529+
530+-- | Never: @'zero' = 'never'@.
531+instance Reflex t => Plus (Event t) where
532+ zero = never
533+
534+-- | Replace each occurrence value of the 'Event' with the value of the
535+-- 'Behavior' at the time of that occurrence.
536+tag :: Reflex t => Behavior t b -> Event t a -> Event t b
537+tag b = pushAlways $ \_ -> sample b
538+
539+-- | Create a new 'Event' that combines occurrences of supplied 'Event' with the
540+-- current value of the 'Behavior'.
541+attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b)
542+attach = attachWith (,)
543+
544+-- | Create a new 'Event' that occurs when the supplied 'Event' occurs by
545+-- combining it with the current value of the 'Behavior'.
546+attachWith :: Reflex t => (a -> b -> c) -> Behavior t a -> Event t b -> Event t c
547+attachWith f = attachWithMaybe $ \a b -> Just $ f a b
548+
549+-- | Create a new 'Event' by combining each occurrence with the current value of
550+-- the 'Behavior'. The occurrence is discarded if the combining function returns
551+-- Nothing
552+attachWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c
553+attachWithMaybe f b e = flip push e $ \o -> (`f` o) <$> sample b
554+
555+-- | Create a new 'Event' that occurs on all but the first occurrence of the
556+-- supplied 'Event'.
557+tailE :: (Reflex t, MonadHold t m) => Event t a -> m (Event t a)
558+tailE e = snd <$> headTailE e
559+
560+-- | Create a tuple of two 'Event's with the first one occurring only the first
561+-- time the supplied 'Event' occurs and the second occurring on all but the first
562+-- occurrence.
563+headTailE :: (Reflex t, MonadHold t m) => Event t a -> m (Event t a, Event t a)
564+headTailE e = do
565+ eHead <- headE e
566+ be <- hold never $ fmap (const e) eHead
567+ return (eHead, switch be)
568+
569+-- | Starting at the current time, fire all the occurrences of the 'Event' for
570+-- which the given predicate returns 'True'. When 'False' is returned, do not
571+-- fire, and permanently stop firing, even if 'True' values are encountered
572+-- later.
573+takeWhileE :: forall t m a. (Reflex t, MonadFix m, MonadHold t m) => (a -> Bool) -> Event t a -> m (Event t a)
574+takeWhileE f e = do
575+ rec let (eFalse, eTrue) = fanEither $ ffor e' $ \a -> if f a
576+ then Right a
577+ else Left never
578+ be <- hold e eFalse
579+ let e' = switch be
580+ return eTrue
581+
582+-- | Split the supplied 'Event' into two individual 'Event's occurring at the
583+-- same time with the respective values from the tuple.
584+splitE :: Reflex t => Event t (a, b) -> (Event t a, Event t b)
585+splitE e = (fmap fst e, fmap snd e)
586+
587+-- | Print the supplied 'String' and the value of the 'Event' on each
588+-- occurrence. This should /only/ be used for debugging.
589+--
590+-- Note: As with Debug.Trace.trace, the message will only be printed if the
591+-- 'Event' is actually used.
592+traceEvent :: (Reflex t, Show a) => String -> Event t a -> Event t a
593+traceEvent s = traceEventWith $ \x -> s <> ": " <> show x
594+
595+-- | Print the output of the supplied function on each occurrence of the
596+-- 'Event'. This should /only/ be used for debugging.
597+--
598+-- Note: As with Debug.Trace.trace, the message will only be printed if the
599+-- 'Event' is actually used.
600+traceEventWith :: Reflex t => (a -> String) -> Event t a -> Event t a
601+traceEventWith f = push $ \x -> trace (f x) $ return $ Just x
602+
603+instance (Semigroup a, Reflex t) => Semigroup (Event t a) where
604+ (<>) = alignWith (mergeThese (<>))
605+ sconcat = fmap sconcat . mergeList . toList
606+#if MIN_VERSION_semigroups(0,17,0)
607+ stimes n = fmap $ stimes n
608+#else
609+ times1p n = fmap $ times1p n
610+#endif
611+
612+instance (Semigroup a, Reflex t) => Monoid (Event t a) where
613+ mempty = never
614+ mappend = (<>)
615+ mconcat = fmap sconcat . mergeList
616+
617+-- | Create a new 'Event' that occurs if at least one of the 'Event's in the
618+-- list occurs. If multiple occur at the same time they are folded from the left
619+-- with the given function.
620+{-# INLINE mergeWith #-}
621+mergeWith :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a
622+mergeWith = mergeWith' id
623+
624+{-# INLINE mergeWith' #-}
625+mergeWith' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b
626+mergeWith' f g es = fmap (Prelude.foldl1 g . fmap f)
627+ . mergeInt
628+ . IntMap.fromDistinctAscList
629+ $ zip [0 :: Int ..] es
630+
631+-- | Create a new 'Event' that occurs if at least one of the 'Event's in the
632+-- list occurs. If multiple occur at the same time the value is the value of the
633+-- leftmost event.
634+{-# INLINE leftmost #-}
635+leftmost :: Reflex t => [Event t a] -> Event t a
636+leftmost = mergeWith const
637+
638+-- | Create a new 'Event' that occurs if at least one of the 'Event's in the
639+-- list occurs and has a list of the values of all 'Event's occurring at that
640+-- time.
641+mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a)
642+mergeList [] = never
643+mergeList es = mergeWithFoldCheap' id es
644+
645+unsafeMapIncremental :: (Reflex t, Patch p, Patch p') => (PatchTarget p -> PatchTarget p') -> (p -> p') -> Incremental t p -> Incremental t p'
646+unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ g <$> updatedIncremental a
647+
648+-- | Create a new 'Event' combining the map of 'Event's into an 'Event' that
649+-- occurs if at least one of them occurs and has a map of values of all 'Event's
650+-- occurring at that time.
651+mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a)
652+mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap
653+
654+-- | Create a merge whose parents can change over time
655+mergeMapIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Event t a)) -> Event t (Map k a)
656+mergeMapIncremental = fmap dmapToMap . mergeIncremental . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWith id)
657+
658+-- | Create a merge whose parents can change over time
659+mergeIntMapIncremental :: Reflex t => Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)
660+mergeIntMapIncremental = fmap dmapToIntMap . mergeIncremental . unsafeMapIncremental intMapWithFunctorToDMap (const2IntPatchDMapWith id)
661+
662+-- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental
663+mergeMapIncrementalWithMove :: (Reflex t, Ord k) => Incremental t (PatchMapWithMove k (Event t a)) -> Event t (Map k a)
664+mergeMapIncrementalWithMove = fmap dmapToMap . mergeIncrementalWithMove . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWithMoveWith id)
665+
666+-- | Split the event into separate events for 'Left' and 'Right' values.
667+fanEither :: Reflex t => Event t (Either a b) -> (Event t a, Event t b)
668+fanEither e =
669+ let justLeft = either Just (const Nothing)
670+ justRight = either (const Nothing) Just
671+ in (fmapMaybe justLeft e, fmapMaybe justRight e)
672+
673+-- | Split the event into separate events for 'This' and 'That' values,
674+-- allowing them to fire simultaneously when the input value is 'These'.
675+fanThese :: Reflex t => Event t (These a b) -> (Event t a, Event t b)
676+fanThese e =
677+ let this (This x) = Just x
678+ this (These x _) = Just x
679+ this _ = Nothing
680+ that (That y) = Just y
681+ that (These _ y) = Just y
682+ that _ = Nothing
683+ in (fmapMaybe this e, fmapMaybe that e)
684+
685+-- | Split the event into an 'EventSelector' that allows efficient selection of
686+-- the individual 'Event's.
687+fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a)
688+fanMap = fan . fmap mapToDMap
689+
690+-- | Switches to the new event whenever it receives one. Only the old event is
691+-- considered the moment a new one is switched in; the output event will fire at
692+-- that moment if only if the old event does.
693+--
694+-- Because the simultaneous firing case is irrelevant, this function imposes
695+-- laxer "timing requirements" on the overall circuit, avoiding many potential
696+-- cyclic dependency / metastability failures. It's also more performant. Use
697+-- this rather than 'switchHoldPromptly' and 'switchHoldPromptOnly' unless you
698+-- are absolutely sure you need to act on the new event in the coincidental
699+-- case.
700+switchHold :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)
701+switchHold ea0 eea = switch <$> hold ea0 eea
702+
703+-- | Switches to the new event whenever it receives one. Whenever a new event is
704+-- provided, if it is firing, its value will be the resulting event's value; if
705+-- it is not firing, but the old one is, the old one's value will be used.
706+--
707+-- 'switchHold', by always forwarding the old event the moment it is switched
708+-- out, avoids many potential cyclic dependency problems / metastability
709+-- problems. It's also more performant. Use it instead unless you are sure you
710+-- cannot.
711+switchHoldPromptly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)
712+switchHoldPromptly ea0 eea = do
713+ bea <- hold ea0 eea
714+ let eLag = switch bea
715+ eCoincidences = coincidence eea
716+ return $ leftmost [eCoincidences, eLag]
717+
718+-- | switches to a new event whenever it receives one. At the moment of
719+-- switching, the old event will be ignored if it fires, and the new one will be
720+-- used if it fires; this is the opposite of 'switch', which will use only the
721+-- old value.
722+--
723+-- 'switchHold', by always forwarding the old event the moment it is switched
724+-- out, avoids many potential cyclic dependency problems / metastability
725+-- problems. It's also more performant. Use it instead unless you are sure you
726+-- cannot.
727+switchHoldPromptOnly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)
728+switchHoldPromptOnly e0 e' = do
729+ eLag <- switch <$> hold e0 e'
730+ return $ coincidence $ leftmost [e', eLag <$ eLag]
731+
732+instance Reflex t => Align (Event t) where
733+ nil = never
734+ align = alignEventWithMaybe Just
735+
736+-- | Create a new 'Event' that only occurs if the supplied 'Event' occurs and
737+-- the 'Behavior' is true at the time of occurrence.
738+gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a
739+gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing
740+
741+-- | Create a new behavior given a starting behavior and switch to a the behvior
742+-- carried by the event when it fires.
743+switcher :: (Reflex t, MonadHold t m)
744+ => Behavior t a -> Event t (Behavior t a) -> m (Behavior t a)
745+switcher b eb = pull . (sample <=< sample) <$> hold b eb
746+
747+instance (Reflex t, IsString a) => IsString (Dynamic t a) where
748+ fromString = pure . fromString
749+
750+-- | Combine two 'Dynamic's. The result will change whenever either (or both)
751+-- input 'Dynamic' changes. Equivalent to @zipDynWith (,)@.
752+zipDyn :: Reflex t => Dynamic t a -> Dynamic t b -> Dynamic t (a, b)
753+zipDyn = zipDynWith (,)
754+
755+-- | Combine two 'Dynamic's with a combining function. The result will change
756+-- whenever either (or both) input 'Dynamic' changes.
757+-- More efficient than liftA2.
758+zipDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> Dynamic t c
759+zipDynWith f da db =
760+ let eab = align (updated da) (updated db)
761+ ec = flip push eab $ \o -> do
762+ (a, b) <- case o of
763+ This a -> do
764+ b <- sample $ current db
765+ return (a, b)
766+ That b -> do
767+ a <- sample $ current da
768+ return (a, b)
769+ These a b -> return (a, b)
770+ return $ Just $ f a b
771+ in unsafeBuildDynamic (f <$> sample (current da) <*> sample (current db)) ec
772+
773+instance (Reflex t, Semigroup a) => Semigroup (Dynamic t a) where
774+ (<>) = zipDynWith (<>)
775+#if MIN_VERSION_semigroups(0,17,0)
776+ stimes n = fmap $ stimes n
777+#else
778+ times1p n = fmap $ times1p n
779+#endif
780+
781+instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where
782+ mconcat = distributeListOverDynWith mconcat
783+ mempty = constDyn mempty
784+ mappend = zipDynWith mappend
785+
786+-- | This function converts a 'DMap' whose elements are 'Dynamic's into a
787+-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same
788+-- through the use of multiple uses of 'zipWithDyn' or 'Applicative' operators.
789+distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity)
790+distributeDMapOverDynPure dm = case DMap.toList dm of
791+ [] -> constDyn DMap.empty
792+ [k :=> v] -> fmap (DMap.singleton k . Identity) v
793+ _ ->
794+ let getInitial = DMap.traverseWithKey (\_ -> fmap Identity . sample . current) dm
795+ edmPre = merge $ DMap.map updated dm
796+ result = unsafeBuildDynamic getInitial $ flip pushAlways edmPre $ \news -> do
797+ olds <- sample $ current result
798+ return $ DMap.unionWithKey (\_ _ new -> new) olds news
799+ in result
800+
801+-- | Convert a list of 'Dynamic's into a 'Dynamic' list.
802+distributeListOverDyn :: Reflex t => [Dynamic t a] -> Dynamic t [a]
803+distributeListOverDyn = distributeListOverDynWith id
804+
805+-- | Create a new 'Dynamic' by applying a combining function to a list of 'Dynamic's
806+distributeListOverDynWith :: Reflex t => ([a] -> b) -> [Dynamic t a] -> Dynamic t b
807+distributeListOverDynWith f = fmap (f . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList) . distributeDMapOverDynPure . DMap.fromList . map (\(k, v) -> Const2 k :=> v) . zip [0 :: Int ..]
808+
809+-- | Create a new 'Event' that occurs when the first supplied 'Event' occurs
810+-- unless the second supplied 'Event' occurs simultaneously.
811+difference :: Reflex t => Event t a -> Event t b -> Event t a
812+difference = alignEventWithMaybe $ \case
813+ This a -> Just a
814+ _ -> Nothing
815+
816+alignEventWithMaybe :: Reflex t => (These a b -> Maybe c) -> Event t a -> Event t b -> Event t c
817+alignEventWithMaybe f ea eb =
818+ fmapMaybe (f <=< dmapToThese)
819+ $ merge
820+ $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]
821+
822+
823+--------------------------------------------------------------------------------
824+-- Accumulator
825+--------------------------------------------------------------------------------
826+
827+-- | An 'Accumulator' type can be built by accumulating occurrences of an
828+-- 'Event'.
829+#if __GLASGOW_HASKELL__ < 802
830+{-# WARNING accum "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-}
831+{-# WARNING accumM "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-}
832+{-# WARNING accumMaybe "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-}
833+{-# WARNING accumMaybeM "ghc < 8.2.1 doesn't seem to be able to specialize functions in this class, which can lead to poor performance" #-}
834+#endif
835+class Reflex t => Accumulator t f | f -> t where
836+ accum :: (MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (f a)
837+ accum f = accumMaybe $ \v o -> Just $ f v o
838+ accumM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t a) -> a -> Event t b -> m (f a)
839+ accumM f = accumMaybeM $ \v o -> Just <$> f v o
840+ accumMaybe :: (MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (f a)
841+ accumMaybe f = accumMaybeM $ \v o -> return $ f v o
842+ accumMaybeM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (f a)
843+ mapAccum :: (MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (f a, Event t c)
844+ mapAccum f = mapAccumMaybe $ \v o -> bimap Just Just $ f v o
845+ mapAccumM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (f a, Event t c)
846+ mapAccumM f = mapAccumMaybeM $ \v o -> bimap Just Just <$> f v o
847+ mapAccumMaybe :: (MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (f a, Event t c)
848+ mapAccumMaybe f = mapAccumMaybeM $ \v o -> return $ f v o
849+ mapAccumMaybeM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (f a, Event t c)
850+
851+accumDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (Dynamic t a)
852+accumDyn f = accumMaybeDyn $ \v o -> Just $ f v o
853+accumMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t a) -> a -> Event t b -> m (Dynamic t a)
854+accumMDyn f = accumMaybeMDyn $ \v o -> Just <$> f v o
855+accumMaybeDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (Dynamic t a)
856+accumMaybeDyn f = accumMaybeMDyn $ \v o -> return $ f v o
857+accumMaybeMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (Dynamic t a)
858+accumMaybeMDyn f z e = do
859+ rec let e' = flip push e $ \o -> do
860+ v <- sample $ current d'
861+ f v o
862+ d' <- holdDyn z e'
863+ return d'
864+mapAccumDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (Dynamic t a, Event t c)
865+mapAccumDyn f = mapAccumMaybeDyn $ \v o -> bimap Just Just $ f v o
866+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)
867+mapAccumMDyn f = mapAccumMaybeMDyn $ \v o -> bimap Just Just <$> f v o
868+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)
869+mapAccumMaybeDyn f = mapAccumMaybeMDyn $ \v o -> return $ f v o
870+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)
871+mapAccumMaybeMDyn f z e = do
872+ rec let e' = flip push e $ \o -> do
873+ v <- sample $ current d'
874+ result <- f v o
875+ return $ case result of
876+ (Nothing, Nothing) -> Nothing
877+ _ -> Just result
878+ d' <- holdDyn z $ fmapMaybe fst e'
879+ return (d', fmapMaybe snd e')
880+
881+{-# INLINE accumB #-}
882+accumB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (Behavior t a)
883+accumB f = accumMaybeB $ \v o -> Just $ f v o
884+{-# INLINE accumMB #-}
885+accumMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t a) -> a -> Event t b -> m (Behavior t a)
886+accumMB f = accumMaybeMB $ \v o -> Just <$> f v o
887+{-# INLINE accumMaybeB #-}
888+accumMaybeB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (Behavior t a)
889+accumMaybeB f = accumMaybeMB $ \v o -> return $ f v o
890+{-# INLINE accumMaybeMB #-}
891+accumMaybeMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (Behavior t a)
892+accumMaybeMB f z e = do
893+ rec let e' = flip push e $ \o -> do
894+ v <- sample d'
895+ f v o
896+ d' <- hold z e'
897+ return d'
898+{-# INLINE mapAccumB #-}
899+mapAccumB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (Behavior t a, Event t c)
900+mapAccumB f = mapAccumMaybeB $ \v o -> bimap Just Just $ f v o
901+{-# INLINE mapAccumMB #-}
902+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)
903+mapAccumMB f = mapAccumMaybeMB $ \v o -> bimap Just Just <$> f v o
904+{-# INLINE mapAccumMaybeB #-}
905+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)
906+mapAccumMaybeB f = mapAccumMaybeMB $ \v o -> return $ f v o
907+
908+{-# INLINE mapAccumMaybeMB #-}
909+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)
910+mapAccumMaybeMB f z e = do
911+ rec let e' = flip push e $ \o -> do
912+ v <- sample d'
913+ result <- f v o
914+ return $ case result of
915+ (Nothing, Nothing) -> Nothing
916+ _ -> Just result
917+ d' <- hold z $ fmapMaybe fst e'
918+ return (d', fmapMaybe snd e')
919+
920+-- | Accumulate occurrences of an 'Event', producing an output occurrence each
921+-- time. Discard the underlying 'Accumulator'.
922+{-# INLINE mapAccum_ #-}
923+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)
924+mapAccum_ f z e = do
925+ (_, result) <- mapAccumB f z e
926+ return result
927+
928+-- | Accumulate occurrences of an 'Event', possibly producing an output
929+-- occurrence each time. Discard the underlying 'Accumulator'.
930+{-# INLINE mapAccumMaybe_ #-}
931+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)
932+mapAccumMaybe_ f z e = do
933+ (_, result) <- mapAccumMaybeB f z e
934+ return result
935+
936+-- | Accumulate occurrences of an 'Event', using a 'PushM' action and producing
937+-- an output occurrence each time. Discard the underlying 'Accumulator'.
938+{-# INLINE mapAccumM_ #-}
939+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)
940+mapAccumM_ f z e = do
941+ (_, result) <- mapAccumMB f z e
942+ return result
943+
944+-- | Accumulate occurrences of an 'Event', using a 'PushM' action and possibly
945+-- producing an output occurrence each time. Discard the underlying
946+-- 'Accumulator'.
947+{-# INLINE mapAccumMaybeM_ #-}
948+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)
949+mapAccumMaybeM_ f z e = do
950+ (_, result) <- mapAccumMaybeMB f z e
951+ return result
952+
953+instance Reflex t => Accumulator t (Dynamic t) where
954+ accumMaybeM = accumMaybeMDyn
955+ mapAccumMaybeM = mapAccumMaybeMDyn
956+
957+instance Reflex t => Accumulator t (Behavior t) where
958+ accumMaybeM = accumMaybeMB
959+ mapAccumMaybeM = mapAccumMaybeMB
960+
961+instance Reflex t => Accumulator t (Event t) where
962+ accumMaybeM f z e = updated <$> accumMaybeM f z e
963+ mapAccumMaybeM f z e = first updated <$> mapAccumMaybeM f z e
964+
965+-- | Create a new 'Event' by combining each occurrence with the next value of the
966+-- list using the supplied function. If the list runs out of items, all
967+-- subsequent 'Event' occurrences will be ignored.
968+zipListWithEvent :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> c) -> [a] -> Event t b -> m (Event t c)
969+zipListWithEvent f l e = do
970+ let f' a b = case a of
971+ h:t -> (Just t, Just $ f h b)
972+ _ -> (Nothing, Nothing) --TODO: Unsubscribe the event?
973+ mapAccumMaybe_ f' l e
974+
975+-- | Assign a number to each occurrence of the given 'Event', starting from 0
976+{-# INLINE numberOccurrences #-}
977+numberOccurrences :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Event t (b, a))
978+numberOccurrences = numberOccurrencesFrom 0
979+
980+-- | Assign a number to each occurrence of the given 'Event'
981+{-# INLINE numberOccurrencesFrom #-}
982+numberOccurrencesFrom :: (Reflex t, MonadHold t m, MonadFix m, Num b) => b -> Event t a -> m (Event t (b, a))
983+numberOccurrencesFrom = mapAccum_ (\n a -> let !next = n + 1 in (next, (n, a)))
984+
985+-- | Assign a number to each occurrence of the given 'Event'; discard the occurrences' values
986+{-# INLINE numberOccurrencesFrom_ #-}
987+numberOccurrencesFrom_ :: (Reflex t, MonadHold t m, MonadFix m, Num b) => b -> Event t a -> m (Event t b)
988+numberOccurrencesFrom_ = mapAccum_ (\n _ -> let !next = n + 1 in (next, n))
989+
990+-- | This is used to sample the value of a 'Behavior' using an 'Event'.
991+--
992+-- The '<@>' operator is intended to be used in conjunction with
993+-- the 'Applicative' instance for 'Behavior'.
994+--
995+-- This is useful when we want to combine the values of one 'Event' and
996+-- the value of several 'Behavior's at the time the 'Event' is firing.
997+--
998+-- If we have:
999+--
1000+-- > f :: a -> b -> c -> d
1001+-- > b1 :: Behavior t a
1002+-- > b2 :: Behavior t b
1003+-- > e :: Event t c
1004+--
1005+-- then we can do:
1006+--
1007+-- > f <$> b1 <*> b2 <@> e :: Event t d
1008+--
1009+-- in order to apply the function 'f' to the relevant values.
1010+--
1011+-- The alternative would be something like:
1012+--
1013+-- > attachWith (\(x1, x2) y -> f x1 x2 y) ((,) <$> b1 <*> b2) e :: Event t d
1014+--
1015+-- or a variation involing a custom data type to hold the combination of
1016+-- 'Behavior's even when that combination might only ever be used by 'f'.
1017+--
1018+-- A more suggestive example might be:
1019+--
1020+-- > handleMouse <$> bPlayerState <*> bMousePosition <@> eMouseClick :: Event t (GameState -> GameState)
1021+--
1022+(<@>) :: Reflex t => Behavior t (a -> b) -> Event t a -> Event t b
1023+(<@>) b = push $ \x -> do
1024+ f <- sample b
1025+ return . Just . f $ x
1026+infixl 4 <@>
1027+
1028+-- | An version of '<@>' that does not use the value of the 'Event'.
1029+--
1030+-- Alternatively, it is 'tag' in operator form.
1031+--
1032+-- This is useful when we want to combine the values of several
1033+-- 'Behavior's at particular points in time using an 'Applicative'
1034+-- style syntax.
1035+--
1036+-- If we have:
1037+--
1038+-- > g :: a -> b -> d
1039+-- > b1 :: Behavior t a
1040+-- > b2 :: Behavior t b
1041+-- > e :: Event t c
1042+--
1043+-- where 'e' is firing at the points in time of interest.
1044+--
1045+-- Then we can use '<@':
1046+--
1047+-- > g <$> b1 <*> b2 <@ e :: Event t d
1048+--
1049+-- to combine the values of 'b1' and 'b2' at each of those points of time,
1050+-- with the function 'g' being used to combine the values.
1051+--
1052+-- This is the same as '<@>' except that the 'Event' is being used only
1053+-- to act as a trigger.
1054+(<@) :: (Reflex t) => Behavior t b -> Event t a -> Event t b
1055+(<@) = tag
1056+infixl 4 <@
1057+
1058+------------------
1059+-- Cheap Functions
1060+------------------
1061+
1062+{-# INLINE pushAlwaysCheap #-}
1063+pushAlwaysCheap :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b
1064+pushAlwaysCheap f = pushCheap (fmap Just . f)
1065+
1066+{-# INLINE fmapMaybeCheap #-}
1067+fmapMaybeCheap :: Reflex t => (a -> Maybe b) -> Event t a -> Event t b
1068+fmapMaybeCheap f = pushCheap $ return . f
1069+
1070+{-# INLINE fforMaybeCheap #-}
1071+fforMaybeCheap :: Reflex t => Event t a -> (a -> Maybe b) -> Event t b
1072+fforMaybeCheap = flip fmapMaybeCheap
1073+
1074+{-# INLINE fforCheap #-}
1075+fforCheap :: Reflex t => Event t a -> (a -> b) -> Event t b
1076+fforCheap = flip fmapCheap
1077+
1078+{-# INLINE fmapCheap #-}
1079+fmapCheap :: Reflex t => (a -> b) -> Event t a -> Event t b
1080+fmapCheap f = pushCheap $ return . Just . f
1081+
1082+{-# INLINE tagCheap #-}
1083+tagCheap :: Reflex t => Behavior t b -> Event t a -> Event t b
1084+tagCheap b = pushAlwaysCheap $ \_ -> sample b
1085+
1086+{-# INLINE mergeWithCheap #-}
1087+mergeWithCheap :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a
1088+mergeWithCheap = mergeWithCheap' id
1089+
1090+{-# INLINE mergeWithCheap' #-}
1091+mergeWithCheap' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b
1092+mergeWithCheap' f g = mergeWithFoldCheap' $ foldl1 g . fmap f
1093+
1094+{-# INLINE mergeWithFoldCheap' #-}
1095+mergeWithFoldCheap' :: Reflex t => (NonEmpty a -> b) -> [Event t a] -> Event t b
1096+mergeWithFoldCheap' f es =
1097+ fmapCheap (f . (\(h : t) -> h :| t) . IntMap.elems)
1098+ . mergeInt
1099+ . IntMap.fromDistinctAscList
1100+ $ zip [0 :: Int ..] es
1101+
1102+--------------------------------------------------------------------------------
1103+-- Deprecated functions
1104+--------------------------------------------------------------------------------
1105+
1106+-- | Create a new 'Event' that occurs if at least one of the supplied 'Event's
1107+-- occurs. If both occur at the same time they are combined using 'mappend'.
1108+{-# DEPRECATED appendEvents "If a 'Semigroup a' instance is available, use 'mappend'; otherwise, use 'alignWith (mergeThese mappend)' instead" #-}
1109+appendEvents :: (Reflex t, Monoid a) => Event t a -> Event t a -> Event t a
1110+appendEvents = alignWith $ mergeThese mappend
1111+
1112+-- | Alias for 'headE'
1113+{-# DEPRECATED onceE "Use 'headE' instead" #-}
1114+onceE :: MonadHold t m => Event t a -> m (Event t a)
1115+onceE = headE
1116+
1117+-- | Run both sides of a 'These' monadically, combining the results.
1118+{-# DEPRECATED sequenceThese "Use bisequenceA or bisequence from the bifunctors package instead" #-}
1119+#ifdef USE_TEMPLATE_HASKELL
1120+{-# ANN sequenceThese "HLint: ignore Use fmap" #-}
1121+#endif
1122+sequenceThese :: Monad m => These (m a) (m b) -> m (These a b)
1123+sequenceThese t = case t of
1124+ This ma -> fmap This ma
1125+ These ma mb -> liftM2 These ma mb
1126+ That mb -> fmap That mb
1127+
1128+{-# 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'. " #-}
1129+switchPromptly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)
1130+switchPromptly = switchHoldPromptly
1131+{-# 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'. " #-}
1132+switchPromptOnly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a)
1133+switchPromptOnly = switchHoldPromptOnly
src/Reflex/Collection.hsnew file+121
@@ -0,0 +1,121 @@
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
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.Adjustable.Class
38+import Reflex.Dynamic
39+import Reflex.PostBuild.Class
40+
41+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))
42+listHoldWithKey m0 m' f = do
43+ let dm0 = mapWithFunctorToDMap $ Map.mapWithKey f m0
44+ dm' = fmap (PatchDMap . mapWithFunctorToDMap . Map.mapWithKey (\k v -> ComposeMaybe $ fmap (f k) v)) m'
45+ (a0, a') <- sequenceDMapWithAdjust dm0 dm'
46+ fmap dmapToMap . incrementalToDynamic <$> holdIncremental a0 a' --TODO: Move the dmapToMap to the righthand side so it doesn't get fully redone every time
47+
48+--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
49+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))
50+listWithKey vals mkChild = do
51+ postBuild <- getPostBuild
52+ let childValChangedSelector = fanMap $ updated vals
53+ -- We keep track of changes to children values in the mkChild function we pass to listHoldWithKey
54+ -- The other changes we need to keep track of are child insertions and deletions. diffOnlyKeyChanges
55+ -- keeps track of insertions and deletions but ignores value changes, since they're already accounted for.
56+ diffOnlyKeyChanges olds news = flip Map.mapMaybe (align olds news) $ \case
57+ This _ -> Just Nothing
58+ These _ _ -> Nothing
59+ That new -> Just $ Just new
60+ rec sentVals :: Dynamic t (Map k v) <- foldDyn applyMap Map.empty changeVals
61+ let changeVals :: Event t (Map k (Maybe v))
62+ changeVals = attachWith diffOnlyKeyChanges (current sentVals) $ leftmost
63+ [ updated vals
64+ , 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
65+ ]
66+ listHoldWithKey Map.empty changeVals $ \k v ->
67+ mkChild k =<< holdDyn v (select childValChangedSelector $ Const2 k)
68+
69+{-# DEPRECATED listWithKey' "listWithKey' has been renamed to listWithKeyShallowDiff; also, its behavior has changed to fix a bug where children were always rebuilt (never updated)" #-}
70+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))
71+listWithKey' = listWithKeyShallowDiff
72+
73+-- | 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.
74+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))
75+listWithKeyShallowDiff initialVals valsChanged mkChild = do
76+ let childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged
77+ sentVals <- foldDyn applyMap (void initialVals) $ fmap (fmap void) valsChanged
78+ let relevantPatch patch _ = case patch of
79+ 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
80+ Just _ -> Nothing -- We don't want to let spurious re-creations of items through
81+ listHoldWithKey initialVals (attachWith (flip (Map.differenceWith relevantPatch)) (current sentVals) valsChanged) $ \k v ->
82+ mkChild k v $ select childValChangedSelector $ Const2 k
83+
84+--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
85+-- | Create a dynamically-changing set of Event-valued widgets.
86+-- 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'.
87+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))
88+listViewWithKey vals mkChild = switch . fmap mergeMap <$> listViewWithKey' vals mkChild
89+
90+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))
91+listViewWithKey' vals mkChild = current <$> listWithKey vals mkChild
92+
93+-- | Create a dynamically-changing set of widgets, one of which is selected at any time.
94+selectViewListWithKey :: forall t m k v a. (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)
95+ => Dynamic t k -- ^ Current selection key
96+ -> Dynamic t (Map k v) -- ^ Dynamic key/value map
97+ -> (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
98+ -> m (Event t (k, a)) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.
99+selectViewListWithKey selection vals mkChild = do
100+ let selectionDemux = demux selection -- For good performance, this value must be shared across all children
101+ selectChild <- listWithKey vals $ \k v -> do
102+ let selected = demuxed selectionDemux k
103+ selectSelf <- mkChild k v selected
104+ return $ fmap ((,) k) selectSelf
105+ return $ switchPromptlyDyn $ leftmost . Map.elems <$> selectChild
106+
107+selectViewListWithKey_ :: forall t m k v a. (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m)
108+ => Dynamic t k -- ^ Current selection key
109+ -> Dynamic t (Map k v) -- ^ Dynamic key/value map
110+ -> (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
111+ -> m (Event t k) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget.
112+selectViewListWithKey_ selection vals mkChild = fmap fst <$> selectViewListWithKey selection vals mkChild
113+
114+-- | Create a dynamically-changing set of widgets from a Dynamic key/value map.
115+-- Unlike the 'withKey' variants, the child widgets are insensitive to which key they're associated with.
116+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))
117+list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
118+
119+-- | Create a dynamically-changing set of widgets from a Dynamic list.
120+simpleList :: (Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m) => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])
121+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 occurrences 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 occurrence 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+216
@@ -0,0 +1,216 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE GADTs #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+{-# LANGUAGE LambdaCase #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE RankNTypes #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE TupleSections #-}
10+{-# LANGUAGE TypeFamilies #-}
11+{-# LANGUAGE UndecidableInstances #-}
12+#ifdef USE_REFLEX_OPTIMIZER
13+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
14+#endif
15+module Reflex.DynamicWriter.Base
16+ ( DynamicWriterT (..)
17+ , runDynamicWriterT
18+ , withDynamicWriterT
19+ ) where
20+
21+import Control.Monad.Exception
22+import Control.Monad.Identity
23+import Control.Monad.IO.Class
24+import Control.Monad.Reader
25+import Control.Monad.Ref
26+import Control.Monad.State.Strict
27+import Data.Align
28+import Data.Dependent.Map (DMap)
29+import qualified Data.Dependent.Map as DMap
30+import Data.FastMutableIntMap
31+import Data.Functor.Misc
32+import Data.IntMap (IntMap)
33+import qualified Data.IntMap as IntMap
34+import Data.Map (Map)
35+import qualified Data.Map as Map
36+import Data.Semigroup
37+import Data.Some (Some)
38+import Data.These
39+
40+import Reflex.Class
41+import Reflex.Adjustable.Class
42+import Reflex.DynamicWriter.Class
43+import Reflex.Host.Class
44+import qualified Reflex.Patch.MapWithMove as MapWithMove
45+import Reflex.PerformEvent.Class
46+import Reflex.PostBuild.Class
47+import Reflex.Requester.Class
48+import Reflex.TriggerEvent.Class
49+
50+instance MonadTrans (DynamicWriterT t w) where
51+ lift = DynamicWriterT . lift
52+
53+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')
54+mapIncrementalMapValues f = unsafeMapIncremental (fmap f) (fmap f)
55+
56+mergeDynIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Dynamic t v)) -> Incremental t (PatchMap k v)
57+mergeDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues
58+ where changedValues = fmap (PatchMap . fmap Just) $ mergeMapIncremental $ mapIncrementalMapValues updated a
59+ addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchMap m) -> PatchMap <$> mapM (mapM (sample . current)) m
60+
61+mergeIntMapDynIncremental :: Reflex t => Incremental t (PatchIntMap (Dynamic t v)) -> Incremental t (PatchIntMap v)
62+mergeIntMapDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues
63+ where changedValues = fmap (PatchIntMap . fmap Just) $ mergeIntMapIncremental $ mapIncrementalMapValues updated a
64+ addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchIntMap m) -> PatchIntMap <$> mapM (mapM (sample . current)) m
65+
66+mergeDynIncrementalWithMove :: forall t k v. (Reflex t, Ord k) => Incremental t (PatchMapWithMove k (Dynamic t v)) -> Incremental t (PatchMapWithMove k v)
67+mergeDynIncrementalWithMove a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ alignWith f addedAndRemovedValues changedValues
68+ where changedValues = mergeMapIncrementalWithMove $ mapIncrementalMapValues updated a
69+ addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ fmap unsafePatchMapWithMove . mapM (mapM (sample . current)) . unPatchMapWithMove
70+ f :: These (PatchMapWithMove k v) (Map k v) -> PatchMapWithMove k v
71+ f x = unsafePatchMapWithMove $
72+ let (p, changed) = case x of
73+ This p_ -> (unPatchMapWithMove p_, mempty)
74+ That c -> (mempty, c)
75+ These p_ c -> (unPatchMapWithMove p_, c)
76+ (pWithNewVals, noLongerMoved) = flip runState [] $ forM p $ MapWithMove.nodeInfoMapMFrom $ \case
77+ MapWithMove.From_Insert v -> return $ MapWithMove.From_Insert v
78+ MapWithMove.From_Delete -> return MapWithMove.From_Delete
79+ MapWithMove.From_Move k -> case Map.lookup k changed of
80+ Nothing -> return $ MapWithMove.From_Move k
81+ Just v -> do
82+ modify (k:)
83+ return $ MapWithMove.From_Insert v
84+ noLongerMovedMap = Map.fromList $ fmap (, ()) noLongerMoved
85+ in Map.differenceWith (\e _ -> Just $ MapWithMove.nodeInfoSetTo Nothing e) pWithNewVals noLongerMovedMap --TODO: Check if any in the second map are not covered?
86+
87+-- | A basic implementation of 'MonadDynamicWriter'.
88+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
89+
90+instance MonadRef m => MonadRef (DynamicWriterT t w m) where
91+ type Ref (DynamicWriterT t w m) = Ref m
92+ newRef = lift . newRef
93+ readRef = lift . readRef
94+ writeRef r = lift . writeRef r
95+
96+instance MonadAtomicRef m => MonadAtomicRef (DynamicWriterT t w m) where
97+ atomicModifyRef r = lift . atomicModifyRef r
98+
99+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (DynamicWriterT t w m) where
100+ newEventWithTrigger = lift . newEventWithTrigger
101+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
102+
103+-- | Run a 'DynamicWriterT' action. The dynamic writer output will be provided
104+-- along with the result of the action.
105+runDynamicWriterT :: (MonadFix m, Reflex t, Monoid w) => DynamicWriterT t w m a -> m (a, Dynamic t w)
106+runDynamicWriterT (DynamicWriterT a) = do
107+ (result, ws) <- runStateT a []
108+ return (result, mconcat $ reverse ws)
109+
110+instance (Monad m, Monoid w, Reflex t) => MonadDynamicWriter t w (DynamicWriterT t w m) where
111+ tellDyn w = DynamicWriterT $ modify (w :)
112+
113+instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where
114+ ask = lift ask
115+ local f (DynamicWriterT a) = DynamicWriterT $ mapStateT (local f) a
116+ reader = lift . reader
117+
118+instance PerformEvent t m => PerformEvent t (DynamicWriterT t w m) where
119+ type Performable (DynamicWriterT t w m) = Performable m
120+ performEvent_ = lift . performEvent_
121+ performEvent = lift . performEvent
122+
123+instance TriggerEvent t m => TriggerEvent t (DynamicWriterT t w m) where
124+ newTriggerEvent = lift newTriggerEvent
125+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
126+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
127+
128+instance PostBuild t m => PostBuild t (DynamicWriterT t w m) where
129+ getPostBuild = lift getPostBuild
130+
131+instance MonadState s m => MonadState s (DynamicWriterT t w m) where
132+ get = lift get
133+ put = lift . put
134+
135+newtype DynamicWriterTLoweredResult t w v a = DynamicWriterTLoweredResult (v a, Dynamic t w)
136+
137+-- | When the execution of a 'DynamicWriterT' action is adjusted using
138+-- 'Adjustable', the 'Dynamic' output of that action will also be updated to
139+-- match.
140+instance (Adjustable t m, MonadFix m, Monoid w, MonadHold t m, Reflex t) => Adjustable t (DynamicWriterT t w m) where
141+ runWithReplace a0 a' = do
142+ (result0, result') <- lift $ runWithReplace (runDynamicWriterT a0) $ runDynamicWriterT <$> a'
143+ tellDyn . join =<< holdDyn (snd result0) (snd <$> result')
144+ return (fst result0, fst <$> result')
145+ traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustImpl traverseIntMapWithKeyWithAdjust mergeIntMapDynIncremental
146+ traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap weakenPatchDMapWith mergeDynIncremental
147+ traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove weakenPatchDMapWithMoveWith mergeDynIncrementalWithMove
148+
149+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)
150+ => ( (forall a. k a -> v a -> m (DynamicWriterTLoweredResult t w v' a))
151+ -> DMap k v
152+ -> Event t (p k v)
153+ -> m (DMap k (DynamicWriterTLoweredResult t w v'), Event t (p k (DynamicWriterTLoweredResult t w v')))
154+ )
155+ -> ((forall a. DynamicWriterTLoweredResult t w v' a -> v' a) -> p k (DynamicWriterTLoweredResult t w v') -> p k v')
156+ -> ((forall a. DynamicWriterTLoweredResult t w v' a -> Dynamic t w) -> p k (DynamicWriterTLoweredResult t w v') -> p' (Some k) (Dynamic t w))
157+ -> (Incremental t (p' (Some k) (Dynamic t w)) -> Incremental t (p' (Some k) w))
158+ -> (forall a. k a -> v a -> DynamicWriterT t w m (v' a))
159+ -> DMap k v
160+ -> Event t (p k v)
161+ -> DynamicWriterT t w m (DMap k v', Event t (p k v'))
162+traverseDMapWithKeyWithAdjustImpl base mapPatch weakenPatchWith mergeMyDynIncremental f (dm0 :: DMap k v) dm' = do
163+ (result0, result') <- lift $ base (\k v -> fmap DynamicWriterTLoweredResult $ runDynamicWriterT $ f k v) dm0 dm'
164+ let getValue (DynamicWriterTLoweredResult (v, _)) = v
165+ getWritten (DynamicWriterTLoweredResult (_, w)) = w
166+ liftedResult0 = DMap.map getValue result0
167+ liftedResult' = ffor result' $ mapPatch getValue
168+ liftedWritten0 :: Map (Some k) (Dynamic t w)
169+ liftedWritten0 = weakenDMapWith getWritten result0
170+ liftedWritten' = ffor result' $ weakenPatchWith getWritten
171+ --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics
172+ i <- holdIncremental liftedWritten0 liftedWritten'
173+ tellDyn $ fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeMyDynIncremental i
174+ return (liftedResult0, liftedResult')
175+
176+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')
177+ => ( (IntMap.Key -> v -> m (v', Dynamic t w))
178+ -> IntMap v
179+ -> Event t (p v)
180+ -> m (IntMap (v', Dynamic t w), Event t (p (v', Dynamic t w)))
181+ )
182+ -> (Incremental t (p' (Dynamic t w)) -> Incremental t (p' w))
183+ -> (IntMap.Key -> v -> DynamicWriterT t w m v')
184+ -> IntMap v
185+ -> Event t (p v)
186+ -> DynamicWriterT t w m (IntMap v', Event t (p v'))
187+traverseIntMapWithKeyWithAdjustImpl base mergeMyDynIncremental f (dm0 :: IntMap v) dm' = do
188+ (result0, result') <- lift $ base (\k v -> runDynamicWriterT $ f k v) dm0 dm'
189+ let liftedResult0 = fmap fst result0
190+ liftedResult' = fmap (fmap fst) result'
191+ liftedWritten0 :: IntMap (Dynamic t w)
192+ liftedWritten0 = fmap snd result0
193+ liftedWritten' = fmap (fmap snd) result'
194+ --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics
195+ i <- holdIncremental liftedWritten0 liftedWritten'
196+ tellDyn $ fmap (mconcat . IntMap.elems) $ incrementalToDynamic $ mergeMyDynIncremental i
197+ return (liftedResult0, liftedResult')
198+
199+-- | Map a function over the output of a 'DynamicWriterT'.
200+withDynamicWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m, MonadFix m)
201+ => (w -> w')
202+ -> DynamicWriterT t w m a
203+ -> DynamicWriterT t w' m a
204+withDynamicWriterT f dw = do
205+ (r, d) <- lift $ do
206+ (r, d) <- runDynamicWriterT dw
207+ let d' = fmap f d
208+ return (r, d')
209+ tellDyn d
210+ return r
211+
212+instance Requester t m => Requester t (DynamicWriterT t w m) where
213+ type Request (DynamicWriterT t w m) = Request m
214+ type Response (DynamicWriterT t w m) = Response m
215+ requesting = lift . requesting
216+ 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+287
@@ -0,0 +1,287 @@
1+-- | This module provides 'EventWriterT', the standard implementation of
2+-- 'EventWriter'.
3+{-# LANGUAGE CPP #-}
4+{-# LANGUAGE ExistentialQuantification #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
8+{-# LANGUAGE Rank2Types #-}
9+{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TypeFamilies #-}
11+{-# LANGUAGE TypeOperators #-}
12+{-# LANGUAGE UndecidableInstances #-}
13+#ifdef USE_REFLEX_OPTIMIZER
14+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
15+#endif
16+module Reflex.EventWriter.Base
17+ ( EventWriterT (..)
18+ , runEventWriterT
19+ , runWithReplaceEventWriterTWith
20+ , sequenceDMapWithAdjustEventWriterTWith
21+ , mapEventWriterT
22+ , withEventWriterT
23+ ) where
24+
25+import Reflex.Class
26+import Reflex.Adjustable.Class
27+import Reflex.EventWriter.Class (EventWriter, tellEvent)
28+import Reflex.Host.Class
29+import Reflex.PerformEvent.Class
30+import Reflex.PostBuild.Class
31+import Reflex.Query.Class
32+import Reflex.Requester.Class
33+import Reflex.TriggerEvent.Class
34+
35+import Control.Monad.Exception
36+import Control.Monad.Identity
37+import Control.Monad.Reader
38+import Control.Monad.Ref
39+import Control.Monad.State.Strict
40+import Data.Dependent.Map (DMap, DSum (..))
41+import qualified Data.Dependent.Map as DMap
42+import Data.Foldable
43+import Data.Functor.Compose
44+import Data.Functor.Misc
45+import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..))
46+import Data.IntMap.Strict (IntMap)
47+import qualified Data.IntMap.Strict as IntMap
48+import Data.List.NonEmpty (NonEmpty (..))
49+import Data.Map (Map)
50+import Data.Semigroup
51+import Data.Some (Some)
52+import Data.Tuple
53+import Data.Type.Equality
54+
55+import Unsafe.Coerce
56+
57+{-# DEPRECATED TellId "Do not construct this directly; use tellId instead" #-}
58+newtype TellId w x
59+ = TellId Int -- ^ WARNING: Do not construct this directly; use 'TellId' instead
60+ deriving (Show, Eq, Ord, Enum)
61+
62+tellId :: Int -> TellId w w
63+tellId = TellId
64+{-# INLINE tellId #-}
65+
66+tellIdRefl :: TellId w x -> w :~: x
67+tellIdRefl _ = unsafeCoerce Refl
68+
69+withTellIdRefl :: TellId w x -> (w ~ x => r) -> r
70+withTellIdRefl tid r = case tellIdRefl tid of
71+ Refl -> r
72+
73+instance GEq (TellId w) where
74+ a `geq` b =
75+ withTellIdRefl a $
76+ withTellIdRefl b $
77+ if a == b
78+ then Just Refl
79+ else Nothing
80+
81+instance GCompare (TellId w) where
82+ a `gcompare` b =
83+ withTellIdRefl a $
84+ withTellIdRefl b $
85+ case a `compare` b of
86+ LT -> GLT
87+ EQ -> GEQ
88+ GT -> GGT
89+
90+data EventWriterState t w = EventWriterState
91+ { _eventWriterState_nextId :: {-# UNPACK #-} !Int -- Always negative (and decreasing over time)
92+ , _eventWriterState_told :: ![DSum (TellId w) (Event t)] -- In increasing order
93+ }
94+
95+-- | A basic implementation of 'EventWriter'.
96+newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (EventWriterState t w) m a }
97+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
98+
99+-- | Run a 'EventWriterT' action.
100+runEventWriterT :: forall t m w a. (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)
101+runEventWriterT (EventWriterT a) = do
102+ (result, requests) <- runStateT a $ EventWriterState (-1) []
103+ let combineResults :: DMap (TellId w) Identity -> w
104+ combineResults = sconcat
105+ . (\(h : t) -> h :| t) -- Unconditional; 'merge' guarantees that it will only fire with non-empty DMaps
106+ . 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
107+ 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
108+
109+instance (Reflex t, Monad m, Semigroup w) => EventWriter t w (EventWriterT t w m) where
110+ tellEvent w = EventWriterT $ modify $ \old ->
111+ let myId = _eventWriterState_nextId old
112+ in EventWriterState
113+ { _eventWriterState_nextId = pred myId
114+ , _eventWriterState_told = (tellId myId :=> w) : _eventWriterState_told old
115+ }
116+
117+instance MonadTrans (EventWriterT t w) where
118+ lift = EventWriterT . lift
119+
120+instance MonadSample t m => MonadSample t (EventWriterT t w m) where
121+ sample = lift . sample
122+
123+instance MonadHold t m => MonadHold t (EventWriterT t w m) where
124+ {-# INLINABLE hold #-}
125+ hold v0 = lift . hold v0
126+ {-# INLINABLE holdDyn #-}
127+ holdDyn v0 = lift . holdDyn v0
128+ {-# INLINABLE holdIncremental #-}
129+ holdIncremental v0 = lift . holdIncremental v0
130+ {-# INLINABLE buildDynamic #-}
131+ buildDynamic a0 = lift . buildDynamic a0
132+ {-# INLINABLE headE #-}
133+ headE = lift . headE
134+
135+instance (Reflex t, Adjustable t m, MonadHold t m, Semigroup w) => Adjustable t (EventWriterT t w m) where
136+ runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
137+ traverseIntMapWithKeyWithAdjust = sequenceIntMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElements mergeIntIncremental
138+ traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElements mergeMapIncremental
139+ traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElements mergeMapIncrementalWithMove
140+
141+instance Requester t m => Requester t (EventWriterT t w m) where
142+ type Request (EventWriterT t w m) = Request m
143+ type Response (EventWriterT t w m) = Response m
144+ requesting = lift . requesting
145+ requesting_ = lift . requesting_
146+
147+-- | Given a function like 'runWithReplace' for the underlying monad, implement
148+-- 'runWithReplace' for 'EventWriterT'. This is necessary when the underlying
149+-- monad doesn't have a 'Adjustable' instance or to override the default
150+-- 'Adjustable' behavior.
151+runWithReplaceEventWriterTWith :: forall m t w a b. (Reflex t, MonadHold t m, Semigroup w)
152+ => (forall a' b'. m a' -> Event t (m b') -> EventWriterT t w m (a', Event t b'))
153+ -> EventWriterT t w m a
154+ -> Event t (EventWriterT t w m b)
155+ -> EventWriterT t w m (a, Event t b)
156+runWithReplaceEventWriterTWith f a0 a' = do
157+ (result0, result') <- f (runEventWriterT a0) $ fmapCheap runEventWriterT a'
158+ tellEvent =<< switchHoldPromptOnly (snd result0) (fmapCheap snd result')
159+ return (fst result0, fmapCheap fst result')
160+
161+-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceIntMapWithAdjust'.
162+sequenceIntMapWithAdjustEventWriterTWith :: forall t m p w v v'. (Reflex t, MonadHold t m, Semigroup w, Functor p, Patch (p (Event t w)), PatchTarget (p (Event t w)) ~ IntMap (Event t w))
163+ => ( (IntMap.Key -> v -> m (Event t w, v'))
164+ -> IntMap v
165+ -> Event t (p v)
166+ -> EventWriterT t w m (IntMap (Event t w, v'), Event t (p (Event t w, v')))
167+ )
168+ -> (p (Event t w) -> [Event t w])
169+ -> (Incremental t (p (Event t w)) -> Event t (IntMap w))
170+ -> (IntMap.Key -> v -> EventWriterT t w m v')
171+ -> IntMap v
172+ -> Event t (p v)
173+ -> EventWriterT t w m (IntMap v', Event t (p v'))
174+sequenceIntMapWithAdjustEventWriterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do
175+ let f' :: IntMap.Key -> v -> m (Event t w, v')
176+ f' k v = swap <$> runEventWriterT (f k v)
177+ (children0, children') <- base f' dm0 dm'
178+ let result0 = fmap snd children0
179+ result' = fmapCheap (fmap snd) children'
180+ requests0 :: IntMap (Event t w)
181+ requests0 = fmap fst children0
182+ requests' :: Event t (p (Event t w))
183+ requests' = fmapCheap (fmap fst) children'
184+ childRequestMap :: Incremental t (p (Event t w)) <- holdIncremental requests0 requests'
185+ tellEventsPromptly requests' patchNewElements $ mergePatchIncremental childRequestMap
186+ return (result0, result')
187+
188+-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.
189+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))
190+ => ( (forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a))
191+ -> DMap k v
192+ -> Event t (p k v)
193+ -> EventWriterT t w m (DMap k (Compose ((,) (Event t w)) v'), Event t (p k (Compose ((,) (Event t w)) v')))
194+ )
195+ -> ((forall a. Compose ((,) (Event t w)) v' a -> v' a) -> p k (Compose ((,) (Event t w)) v') -> p k v')
196+ -> ((forall a. Compose ((,) (Event t w)) v' a -> Event t w) -> p k (Compose ((,) (Event t w)) v') -> p' (Some k) (Event t w))
197+ -> (p' (Some k) (Event t w) -> [Event t w])
198+ -> (Incremental t (p' (Some k) (Event t w)) -> Event t (Map (Some k) w))
199+ -> (forall a. k a -> v a -> EventWriterT t w m (v' a))
200+ -> DMap k v
201+ -> Event t (p k v)
202+ -> EventWriterT t w m (DMap k v', Event t (p k v'))
203+sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do
204+ let f' :: forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a)
205+ f' k v = Compose . swap <$> runEventWriterT (f k v)
206+ (children0, children') <- base f' dm0 dm'
207+ let result0 = DMap.map (snd . getCompose) children0
208+ result' = fforCheap children' $ mapPatch $ snd . getCompose
209+ requests0 :: Map (Some k) (Event t w)
210+ requests0 = weakenDMapWith (fst . getCompose) children0
211+ requests' :: Event t (p' (Some k) (Event t w))
212+ requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose
213+ childRequestMap :: Incremental t (p' (Some k) (Event t w)) <- holdIncremental requests0 requests'
214+ tellEventsPromptly requests' patchNewElements $ mergePatchIncremental childRequestMap
215+ return (result0, result')
216+
217+tellEventsPromptly
218+ :: ( Foldable f
219+ , Reflex t
220+ , MonadHold t m
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+ let patch0 = fforMaybeCheap mergedChildRequestMap $ \m -> case toList m of
229+ [] -> Nothing
230+ h : t -> Just $ sconcat $ h :| t
231+ tellEvent =<< switchHoldPromptOnly patch0 (fmapCheap (mconcat . patchNewElements) requests')
232+
233+instance PerformEvent t m => PerformEvent t (EventWriterT t w m) where
234+ type Performable (EventWriterT t w m) = Performable m
235+ performEvent_ = lift . performEvent_
236+ performEvent = lift . performEvent
237+
238+instance PostBuild t m => PostBuild t (EventWriterT t w m) where
239+ getPostBuild = lift getPostBuild
240+
241+instance TriggerEvent t m => TriggerEvent t (EventWriterT t w m) where
242+ newTriggerEvent = lift newTriggerEvent
243+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
244+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
245+
246+instance MonadReader r m => MonadReader r (EventWriterT t w m) where
247+ ask = lift ask
248+ local f (EventWriterT a) = EventWriterT $ mapStateT (local f) a
249+ reader = lift . reader
250+
251+instance MonadRef m => MonadRef (EventWriterT t w m) where
252+ type Ref (EventWriterT t w m) = Ref m
253+ newRef = lift . newRef
254+ readRef = lift . readRef
255+ writeRef r = lift . writeRef r
256+
257+instance MonadAtomicRef m => MonadAtomicRef (EventWriterT t w m) where
258+ atomicModifyRef r = lift . atomicModifyRef r
259+
260+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (EventWriterT t w m) where
261+ newEventWithTrigger = lift . newEventWithTrigger
262+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
263+
264+instance (MonadQuery t q m, Monad m) => MonadQuery t q (EventWriterT t w m) where
265+ tellQueryIncremental = lift . tellQueryIncremental
266+ askQueryResult = lift askQueryResult
267+ queryIncremental = lift . queryIncremental
268+
269+-- | Map a function over the output of a 'EventWriterT'.
270+withEventWriterT :: (Semigroup w, Semigroup w', Reflex t, MonadHold t m)
271+ => (w -> w')
272+ -> EventWriterT t w m a
273+ -> EventWriterT t w' m a
274+withEventWriterT f ew = do
275+ (r, e) <- lift $ do
276+ (r, e) <- runEventWriterT ew
277+ let e' = fmap f e
278+ return (r, e')
279+ tellEvent e
280+ return r
281+
282+-- | Change the monad underlying an EventWriterT
283+mapEventWriterT
284+ :: (forall x. m x -> n x)
285+ -> EventWriterT t w m a
286+ -> EventWriterT t w n a
287+mapEventWriterT f (EventWriterT a) = EventWriterT $ mapStateT f a
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+280
@@ -0,0 +1,280 @@
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.Monad.Fix
34+import Control.Monad.Identity
35+import Control.Monad.Ref
36+import Control.Monad.Trans
37+import Control.Monad.Trans.Cont (ContT)
38+import Control.Monad.Trans.Except (ExceptT)
39+import Control.Monad.Trans.Reader (ReaderT)
40+import Control.Monad.Trans.RWS (RWST)
41+import Control.Monad.Trans.State (StateT)
42+import qualified Control.Monad.Trans.State.Strict as Strict
43+import Control.Monad.Trans.Writer (WriterT)
44+import Data.Dependent.Sum (DSum (..))
45+import Data.GADT.Compare
46+
47+-- | Framework implementation support class for the reflex implementation
48+-- represented by @t@.
49+class ( Reflex t
50+ , MonadReflexCreateTrigger t (HostFrame t)
51+ , MonadSample t (HostFrame t)
52+ , MonadHold t (HostFrame t)
53+ , MonadFix (HostFrame t)
54+ , MonadSubscribeEvent t (HostFrame t)
55+ ) => ReflexHost t where
56+ type EventTrigger t :: * -> *
57+ type EventHandle t :: * -> *
58+ type HostFrame t :: * -> *
59+
60+-- | Monad in which Events can be 'subscribed'. This forces all underlying
61+-- event sources to be initialized, so that the event will fire whenever it
62+-- ought to. Events must be subscribed before they are read using readEvent
63+class (Reflex t, Monad m) => MonadSubscribeEvent t m | m -> t where
64+ -- | Subscribe to an event and set it up if needed.
65+ --
66+ -- This function will create a new 'EventHandle' from an 'Event'. This handle
67+ -- may then be used via 'readEvent' in the read callback of
68+ -- 'fireEventsAndRead'.
69+ --
70+ -- If the event wasn't subscribed to before (either manually or through a
71+ -- dependent event or behavior) then this function will cause the event and
72+ -- all dependencies of this event to be set up. For example, if the event was
73+ -- created by 'newEventWithTrigger', then it's callback will be executed.
74+ --
75+ -- It's safe to call this function multiple times.
76+ subscribeEvent :: Event t a -> m (EventHandle t a)
77+
78+-- | Monad that allows to read events' values.
79+class (ReflexHost t, Applicative m, Monad m) => MonadReadEvent t m | m -> t where
80+ -- | Read the value of an 'Event' from an 'EventHandle' (created by calling
81+ -- 'subscribeEvent').
82+ --
83+ -- After event propagation is done, all events can be in two states: either
84+ -- they are firing with some value or they are not firing. In the former
85+ -- case, this function returns @Just act@, where @act@ in an action to read
86+ -- the current value of the event. In the latter case, the function returns
87+ -- @Nothing@.
88+ --
89+ -- This function is normally used in the calllback for 'fireEventsAndRead'.
90+ readEvent :: EventHandle t a -> m (Maybe (m a))
91+
92+-- | A monad where new events feed from external sources can be created.
93+class (Applicative m, Monad m) => MonadReflexCreateTrigger t m | m -> t where
94+ -- | Creates a root 'Event' (one that is not based on any other event).
95+ --
96+ -- When a subscriber first subscribes to an event (building another event that
97+ -- depends on the subscription) the given callback function is run and passed
98+ -- a trigger. The callback function can then set up the event source in IO.
99+ -- After this is done, the callback function must return an accompanying
100+ -- teardown action.
101+ --
102+ -- Any time between setup and teardown the trigger can be used to fire the
103+ -- event, by passing it to 'fireEventsAndRead'.
104+ --
105+ -- Note: An event may be set up multiple times. So after the teardown action
106+ -- is executed, the event may still be set up again in the future.
107+ newEventWithTrigger :: (EventTrigger t a -> IO (IO ())) -> m (Event t a)
108+ newFanEventWithTrigger :: GCompare k => (forall a. k a -> EventTrigger t a -> IO (IO ())) -> m (EventSelector t k)
109+
110+-- | 'MonadReflexHost' designates monads that can run reflex frames.
111+class ( ReflexHost t
112+ , MonadReflexCreateTrigger t m
113+ , MonadSubscribeEvent t m
114+ , MonadReadEvent t (ReadPhase m)
115+ , MonadSample t (ReadPhase m)
116+ , MonadHold t (ReadPhase m)
117+ ) => MonadReflexHost t m | m -> t where
118+ type ReadPhase m :: * -> *
119+ -- | Propagate some events firings and read the values of events afterwards.
120+ --
121+ -- This function will create a new frame to fire the given events. It will
122+ -- then update all dependent events and behaviors. After that is done, the
123+ -- given callback is executed which allows to read the final values of events
124+ -- and check whether they have fired in this frame or not.
125+ --
126+ -- All events that are given are fired at the same time.
127+ --
128+ -- This function is typically used in the main loop of a reflex framework
129+ -- implementation. The main loop waits for external events to happen (such as
130+ -- keyboard input or a mouse click) and then fires the corresponding events
131+ -- using this function. The read callback can be used to read output events
132+ -- and perform a corresponding response action to the external event.
133+ fireEventsAndRead :: [DSum (EventTrigger t) Identity] -> ReadPhase m a -> m a
134+
135+ -- | Run a frame without any events firing.
136+ --
137+ -- This function should be used when you want to use 'sample' and 'hold' when
138+ -- no events are currently firing. Using this function in that case can
139+ -- improve performance, since the implementation can assume that no events are
140+ -- firing when 'sample' or 'hold' are called.
141+ --
142+ -- This function is commonly used to set up the basic event network when the
143+ -- application starts up.
144+ runHostFrame :: HostFrame t a -> m a
145+
146+-- | Like 'fireEventsAndRead', but without reading any events.
147+fireEvents :: MonadReflexHost t m => [DSum (EventTrigger t) Identity] -> m ()
148+fireEvents dm = fireEventsAndRead dm $ return ()
149+{-# INLINE fireEvents #-}
150+
151+-- | Create a new event and store its trigger in an 'IORef' while it's active.
152+--
153+-- An event is only active between the set up (when it's first subscribed to)
154+-- and the teardown phases (when noboby is subscribing the event anymore). This
155+-- function returns an Event and an 'IORef'. As long as the event is active, the
156+-- 'IORef' will contain 'Just' the event trigger to trigger this event. When the
157+-- event is not active, the 'IORef' will contain 'Nothing'. This allows event
158+-- sources to be more efficient, since they don't need to produce events when
159+-- nobody is listening.
160+newEventWithTriggerRef :: (MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO) => m (Event t a, Ref m (Maybe (EventTrigger t a)))
161+newEventWithTriggerRef = do
162+ rt <- newRef Nothing
163+ e <- newEventWithTrigger $ \t -> do
164+ writeRef rt $ Just t
165+ return $ writeRef rt Nothing
166+ return (e, rt)
167+{-# INLINE newEventWithTriggerRef #-}
168+
169+-- | Fire the given trigger if it is not 'Nothing'.
170+fireEventRef :: (MonadReflexHost t m, MonadRef m, Ref m ~ Ref IO) => Ref m (Maybe (EventTrigger t a)) -> a -> m ()
171+fireEventRef mtRef input = do
172+ mt <- readRef mtRef
173+ case mt of
174+ Nothing -> return ()
175+ Just trigger -> fireEvents [trigger :=> Identity input]
176+
177+-- | Fire the given trigger if it is not 'Nothing', and read from the given
178+-- 'EventHandle'.
179+fireEventRefAndRead :: (MonadReflexHost t m, MonadRef m, Ref m ~ Ref IO) => Ref m (Maybe (EventTrigger t a)) -> a -> EventHandle t b -> m (Maybe b)
180+fireEventRefAndRead mtRef input e = do
181+ mt <- readRef mtRef
182+ case mt of
183+ Nothing -> return Nothing -- Since we aren't firing the input, the output can't fire
184+ Just trigger -> fireEventsAndRead [trigger :=> Identity input] $ do
185+ mGetValue <- readEvent e
186+ case mGetValue of
187+ Nothing -> return Nothing
188+ Just getValue -> fmap Just getValue
189+
190+
191+--------------------------------------------------------------------------------
192+-- Instances
193+--------------------------------------------------------------------------------
194+
195+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ReaderT r m) where
196+ newEventWithTrigger = lift . newEventWithTrigger
197+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
198+
199+instance MonadSubscribeEvent t m => MonadSubscribeEvent t (ReaderT r m) where
200+ subscribeEvent = lift . subscribeEvent
201+
202+instance MonadReflexHost t m => MonadReflexHost t (ReaderT r m) where
203+ type ReadPhase (ReaderT r m) = ReadPhase m
204+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
205+ runHostFrame = lift . runHostFrame
206+
207+instance (MonadReflexCreateTrigger t m, Monoid w) => MonadReflexCreateTrigger t (WriterT w m) where
208+ newEventWithTrigger = lift . newEventWithTrigger
209+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
210+
211+instance (MonadSubscribeEvent t m, Monoid w) => MonadSubscribeEvent t (WriterT w m) where
212+ subscribeEvent = lift . subscribeEvent
213+
214+instance (MonadReflexHost t m, Monoid w) => MonadReflexHost t (WriterT w m) where
215+ type ReadPhase (WriterT w m) = ReadPhase m
216+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
217+ runHostFrame = lift . runHostFrame
218+
219+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (StateT s m) where
220+ newEventWithTrigger = lift . newEventWithTrigger
221+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
222+
223+instance MonadSubscribeEvent t m => MonadSubscribeEvent t (StateT r m) where
224+ subscribeEvent = lift . subscribeEvent
225+
226+instance MonadReflexHost t m => MonadReflexHost t (StateT s m) where
227+ type ReadPhase (StateT s m) = ReadPhase m
228+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
229+ runHostFrame = lift . runHostFrame
230+
231+
232+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (Strict.StateT s m) where
233+ newEventWithTrigger = lift . newEventWithTrigger
234+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
235+
236+instance MonadSubscribeEvent t m => MonadSubscribeEvent t (Strict.StateT r m) where
237+ subscribeEvent = lift . subscribeEvent
238+
239+instance MonadReflexHost t m => MonadReflexHost t (Strict.StateT s m) where
240+ type ReadPhase (Strict.StateT s m) = ReadPhase m
241+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
242+ runHostFrame = lift . runHostFrame
243+
244+
245+
246+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ContT r m) where
247+ newEventWithTrigger = lift . newEventWithTrigger
248+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
249+
250+instance MonadSubscribeEvent t m => MonadSubscribeEvent t (ContT r m) where
251+ subscribeEvent = lift . subscribeEvent
252+
253+instance MonadReflexHost t m => MonadReflexHost t (ContT r m) where
254+ type ReadPhase (ContT r m) = ReadPhase m
255+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
256+ runHostFrame = lift . runHostFrame
257+
258+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (ExceptT e m) where
259+ newEventWithTrigger = lift . newEventWithTrigger
260+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
261+
262+instance MonadSubscribeEvent t m => MonadSubscribeEvent t (ExceptT r m) where
263+ subscribeEvent = lift . subscribeEvent
264+
265+instance MonadReflexHost t m => MonadReflexHost t (ExceptT e m) where
266+ type ReadPhase (ExceptT e m) = ReadPhase m
267+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
268+ runHostFrame = lift . runHostFrame
269+
270+instance (MonadReflexCreateTrigger t m, Monoid w) => MonadReflexCreateTrigger t (RWST r w s m) where
271+ newEventWithTrigger = lift . newEventWithTrigger
272+ newFanEventWithTrigger initializer = lift $ newFanEventWithTrigger initializer
273+
274+instance (MonadSubscribeEvent t m, Monoid w) => MonadSubscribeEvent t (RWST r w s m) where
275+ subscribeEvent = lift . subscribeEvent
276+
277+instance (MonadReflexHost t m, Monoid w) => MonadReflexHost t (RWST r w s m) where
278+ type ReadPhase (RWST r w s m) = ReadPhase m
279+ fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
280+ runHostFrame = lift . runHostFrame
src/Reflex/Network.hsnew file+39
@@ -0,0 +1,39 @@
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.Adjustable.Class
14+import Reflex.NotReady.Class
15+import Reflex.PostBuild.Class
16+
17+-- | Given a Dynamic of network-creating actions, create a network that is recreated whenever the Dynamic updates.
18+-- The returned Event of network results occurs when the Dynamic does.
19+-- 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').
20+networkView :: (NotReady t m, Adjustable t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a)
21+networkView child = do
22+ postBuild <- getPostBuild
23+ let newChild = leftmost [updated child, tagCheap (current child) postBuild]
24+ snd <$> runWithReplace notReady newChild
25+
26+-- | Given an initial network and an Event of network-creating actions, create a network that is recreated whenever the Event fires.
27+-- The returned Dynamic of network results occurs when the Event does.
28+-- Note: Often, the type 'a' is an Event, in which case the return value is a Dynamic-of-Events that would typically be flattened.
29+networkHold :: (Adjustable t m, MonadHold t m) => m a -> Event t (m a) -> m (Dynamic t a)
30+networkHold child0 newChild = do
31+ (result0, newResult) <- runWithReplace child0 newChild
32+ holdDyn result0 newResult
33+
34+-- | Render a placeholder network to be shown while another network is not yet
35+-- done building
36+untilReady :: (Adjustable t m, PostBuild t m) => m a -> m b -> m (a, Event t b)
37+untilReady a b = do
38+ postBuild <- getPostBuild
39+ 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+38−42
@@ -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
@@ -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
@@ -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+49
@@ -0,0 +1,49 @@
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 Reflex.Patch.Class
14+
15+newtype PatchIntMap a = PatchIntMap (IntMap (Maybe a)) deriving (Functor, Foldable, Traversable, Monoid)
16+
17+instance Patch (PatchIntMap a) where
18+ type PatchTarget (PatchIntMap a) = IntMap a
19+ apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $
20+ let removes = IntMap.filter isNothing p
21+ adds = IntMap.mapMaybe id p
22+ in IntMap.union adds $ v `IntMap.difference` removes
23+
24+-- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@.
25+-- If the same key is modified by both patches, the one on the left will take
26+-- precedence.
27+instance Semigroup (PatchIntMap v) where
28+ PatchIntMap a <> PatchIntMap b = PatchIntMap $ a `mappend` b --TODO: Add a semigroup instance for Map
29+ -- PatchMap is idempotent, so stimes n is id for every n
30+#if MIN_VERSION_semigroups(0,17,0)
31+ stimes = stimesIdempotentMonoid
32+#else
33+ times1p n x = case compare n 0 of
34+ LT -> error "stimesIdempotentMonoid: negative multiplier"
35+ EQ -> mempty
36+ GT -> x
37+#endif
38+
39+traverseIntMapPatchWithKey :: Applicative t => (Int -> a -> t b) -> PatchIntMap a -> t (PatchIntMap b)
40+traverseIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap <$> IntMap.traverseWithKey (\k mv -> traverse (f k) mv) m
41+
42+patchIntMapNewElements :: PatchIntMap a -> [a]
43+patchIntMapNewElements (PatchIntMap m) = catMaybes $ IntMap.elems m
44+
45+patchIntMapNewElementsMap :: PatchIntMap a -> IntMap a
46+patchIntMapNewElementsMap (PatchIntMap m) = IntMap.mapMaybe id m
47+
48+getDeletions :: PatchIntMap v -> IntMap v' -> IntMap v'
49+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+179
@@ -0,0 +1,179 @@
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.Adjustable.Class
29+import Reflex.Host.Class
30+import Reflex.PerformEvent.Class
31+import Reflex.Requester.Base
32+import Reflex.Requester.Class
33+
34+import Control.Lens
35+import Control.Monad.Exception
36+import Control.Monad.Identity
37+import Control.Monad.Primitive
38+import Control.Monad.Reader
39+import Control.Monad.Ref
40+import Data.Coerce
41+import Data.Dependent.Map (DMap)
42+import qualified Data.Dependent.Map as DMap
43+import Data.Dependent.Sum
44+import Data.IntMap.Strict (IntMap)
45+import qualified Data.IntMap.Strict as IntMap
46+import qualified Data.Semigroup as S
47+
48+-- | A function that fires events for the given 'EventTrigger's and then runs
49+-- any followup actions provided via 'PerformEvent'. The given 'ReadPhase'
50+-- action will be run once for the initial trigger execution as well as once for
51+-- each followup.
52+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?
53+
54+-- | Provides a basic implementation of 'PerformEvent'. Note that, despite the
55+-- name, 'PerformEventT' is not an instance of 'MonadTrans'.
56+newtype PerformEventT t m a = PerformEventT { unPerformEventT :: RequesterT t (HostFrame t) Identity (HostFrame t) a }
57+
58+deriving instance ReflexHost t => Functor (PerformEventT t m)
59+deriving instance ReflexHost t => Applicative (PerformEventT t m)
60+deriving instance ReflexHost t => Monad (PerformEventT t m)
61+deriving instance ReflexHost t => MonadFix (PerformEventT t m)
62+deriving instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (PerformEventT t m)
63+deriving instance (ReflexHost t, MonadException (HostFrame t)) => MonadException (PerformEventT t m)
64+deriving instance (ReflexHost t, Monoid a) => Monoid (PerformEventT t m a)
65+deriving instance (ReflexHost t, S.Semigroup a) => S.Semigroup (PerformEventT t m a)
66+
67+instance (PrimMonad (HostFrame t), ReflexHost t) => PrimMonad (PerformEventT t m) where
68+ type PrimState (PerformEventT t m) = PrimState (HostFrame t)
69+ primitive = PerformEventT . lift . primitive
70+
71+instance (ReflexHost t, Ref m ~ Ref IO) => PerformEvent t (PerformEventT t m) where
72+ type Performable (PerformEventT t m) = HostFrame t
73+ {-# INLINABLE performEvent_ #-}
74+ performEvent_ = PerformEventT . requesting_
75+ {-# INLINABLE performEvent #-}
76+ performEvent = PerformEventT . requestingIdentity
77+
78+instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT t m) where
79+ runWithReplace outerA0 outerA' = PerformEventT $ runWithReplaceRequesterTWith f (coerce outerA0) (coerceEvent outerA')
80+ where f :: HostFrame t a -> Event t (HostFrame t b) -> RequesterT t (HostFrame t) Identity (HostFrame t) (a, Event t b)
81+ f a0 a' = do
82+ result0 <- lift a0
83+ result' <- requestingIdentity a'
84+ return (result0, result')
85+ traverseIntMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseIntMapWithKeyWithAdjustRequesterTWith (defaultAdjustIntBase traverseIntMapPatchWithKey) patchIntMapNewElementsMap mergeIntIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')
86+ traverseDMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithKey) mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')
87+ traverseDMapWithKeyWithAdjustWithMove f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithMoveWithKey) mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')
88+
89+defaultAdjustBase :: forall t v v2 k' p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t)
90+ => ((forall a. k' a -> v a -> HostFrame t (v2 a)) -> p k' v -> HostFrame t (p k' v2))
91+ -> (forall a. k' a -> v a -> HostFrame t (v2 a))
92+ -> DMap k' v
93+ -> Event t (p k' v)
94+ -> RequesterT t (HostFrame t) Identity (HostFrame t) (DMap k' v2, Event t (p k' v2))
95+defaultAdjustBase traversePatchWithKey f' dm0 dm' = do
96+ result0 <- lift $ DMap.traverseWithKey f' dm0
97+ result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f'
98+ return (result0, result')
99+
100+defaultAdjustIntBase :: forall t v v2 p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t)
101+ => ((IntMap.Key -> v -> HostFrame t v2) -> p v -> HostFrame t (p v2))
102+ -> (IntMap.Key -> v -> HostFrame t v2)
103+ -> IntMap v
104+ -> Event t (p v)
105+ -> RequesterT t (HostFrame t) Identity (HostFrame t) (IntMap v2, Event t (p v2))
106+defaultAdjustIntBase traversePatchWithKey f' dm0 dm' = do
107+ result0 <- lift $ IntMap.traverseWithKey f' dm0
108+ result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f'
109+ return (result0, result')
110+
111+instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where
112+ {-# INLINABLE newEventWithTrigger #-}
113+ newEventWithTrigger = PerformEventT . lift . newEventWithTrigger
114+ {-# INLINABLE newFanEventWithTrigger #-}
115+ newFanEventWithTrigger f = PerformEventT $ lift $ newFanEventWithTrigger f
116+
117+-- | Run a 'PerformEventT' action, returning a 'FireCommand' that allows the
118+-- caller to trigger 'Event's while ensuring that 'performEvent' actions are run
119+-- at the appropriate time.
120+{-# INLINABLE hostPerformEventT #-}
121+hostPerformEventT :: forall t m a.
122+ ( Monad m
123+ , MonadSubscribeEvent t m
124+ , MonadReflexHost t m
125+ , MonadRef m
126+ , Ref m ~ Ref IO
127+ )
128+ => PerformEventT t m a
129+ -> m (a, FireCommand t m)
130+hostPerformEventT a = do
131+ (response, responseTrigger) <- newEventWithTriggerRef
132+ (result, eventToPerform) <- runHostFrame $ runRequesterT (unPerformEventT a) response
133+ eventToPerformHandle <- subscribeEvent eventToPerform
134+ return $ (,) result $ FireCommand $ \triggers (readPhase :: ReadPhase m a') -> do
135+ let go :: [DSum (EventTrigger t) Identity] -> m [a']
136+ go ts = do
137+ (result', mToPerform) <- fireEventsAndRead ts $ do
138+ mToPerform <- sequence =<< readEvent eventToPerformHandle
139+ result' <- readPhase
140+ return (result', mToPerform)
141+ case mToPerform of
142+ Nothing -> return [result']
143+ Just toPerform -> do
144+ responses <- runHostFrame $ traverseRequesterData (\v -> Identity <$> v) toPerform
145+ mrt <- readRef responseTrigger
146+ let followupEventTriggers = case mrt of
147+ Just rt -> [rt :=> Identity responses]
148+ Nothing -> []
149+ (result':) <$> go followupEventTriggers
150+ go triggers
151+
152+instance ReflexHost t => MonadSample t (PerformEventT t m) where
153+ {-# INLINABLE sample #-}
154+ sample = PerformEventT . lift . sample
155+
156+instance (ReflexHost t, MonadHold t m) => MonadHold t (PerformEventT t m) where
157+ {-# INLINABLE hold #-}
158+ hold v0 v' = PerformEventT $ lift $ hold v0 v'
159+ {-# INLINABLE holdDyn #-}
160+ holdDyn v0 v' = PerformEventT $ lift $ holdDyn v0 v'
161+ {-# INLINABLE holdIncremental #-}
162+ holdIncremental v0 v' = PerformEventT $ lift $ holdIncremental v0 v'
163+ {-# INLINABLE buildDynamic #-}
164+ buildDynamic getV0 v' = PerformEventT $ lift $ buildDynamic getV0 v'
165+ {-# INLINABLE headE #-}
166+ headE = PerformEventT . lift . headE
167+
168+instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m) where
169+ type Ref (PerformEventT t m) = Ref (HostFrame t)
170+ {-# INLINABLE newRef #-}
171+ newRef = PerformEventT . lift . newRef
172+ {-# INLINABLE readRef #-}
173+ readRef = PerformEventT . lift . readRef
174+ {-# INLINABLE writeRef #-}
175+ writeRef r = PerformEventT . lift . writeRef r
176+
177+instance (MonadAtomicRef (HostFrame t), ReflexHost t) => MonadAtomicRef (PerformEventT t m) where
178+ {-# INLINABLE atomicModifyRef #-}
179+ 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+197
@@ -0,0 +1,197 @@
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.Adjustable.Class
27+import Reflex.Host.Class
28+import Reflex.PerformEvent.Class
29+import Reflex.PostBuild.Class
30+import Reflex.TriggerEvent.Class
31+
32+import Control.Applicative (liftA2)
33+import Control.Monad.Exception
34+import Control.Monad.Identity
35+import Control.Monad.Primitive
36+import Control.Monad.Reader
37+import Control.Monad.Ref
38+import qualified Control.Monad.Trans.Control as TransControl
39+import Data.Dependent.Map (DMap)
40+import qualified Data.Dependent.Map as DMap
41+import Data.Functor.Compose
42+import Data.IntMap.Strict (IntMap)
43+import qualified Data.IntMap.Strict as IntMap
44+import qualified Data.Semigroup as S
45+
46+-- | Provides a basic implementation of 'PostBuild'.
47+newtype PostBuildT t m a = PostBuildT { unPostBuildT :: ReaderT (Event t ()) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadTrans, MonadException, MonadAsyncException)
48+
49+-- | Run a 'PostBuildT' action. An 'Event' should be provided that fires
50+-- immediately after the action is finished running; no other 'Event's should
51+-- fire first.
52+{-# INLINABLE runPostBuildT #-}
53+runPostBuildT :: PostBuildT t m a -> Event t () -> m a
54+runPostBuildT (PostBuildT a) = runReaderT a
55+
56+-- TODO: Monoid and Semigroup can likely be derived once ReaderT has them.
57+instance (Monoid a, Applicative m) => Monoid (PostBuildT t m a) where
58+ mempty = pure mempty
59+ mappend = liftA2 mappend
60+
61+instance (S.Semigroup a, Applicative m) => S.Semigroup (PostBuildT t m a) where
62+ (<>) = liftA2 (S.<>)
63+
64+instance PrimMonad m => PrimMonad (PostBuildT x m) where
65+ type PrimState (PostBuildT x m) = PrimState m
66+ primitive = lift . primitive
67+
68+instance (Reflex t, Monad m) => PostBuild t (PostBuildT t m) where
69+ {-# INLINABLE getPostBuild #-}
70+ getPostBuild = PostBuildT ask
71+
72+instance MonadSample t m => MonadSample t (PostBuildT t m) where
73+ {-# INLINABLE sample #-}
74+ sample = lift . sample
75+
76+instance MonadHold t m => MonadHold t (PostBuildT t m) where
77+ {-# INLINABLE hold #-}
78+ hold v0 = lift . hold v0
79+ {-# INLINABLE holdDyn #-}
80+ holdDyn v0 = lift . holdDyn v0
81+ {-# INLINABLE holdIncremental #-}
82+ holdIncremental v0 = lift . holdIncremental v0
83+ {-# INLINABLE buildDynamic #-}
84+ buildDynamic a0 = lift . buildDynamic a0
85+ {-# INLINABLE headE #-}
86+ headE = lift . headE
87+
88+instance PerformEvent t m => PerformEvent t (PostBuildT t m) where
89+ type Performable (PostBuildT t m) = Performable m
90+ {-# INLINABLE performEvent_ #-}
91+ performEvent_ = lift . performEvent_
92+ {-# INLINABLE performEvent #-}
93+ performEvent = lift . performEvent
94+
95+instance (ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (PostBuildT t m) where
96+ {-# INLINABLE newEventWithTrigger #-}
97+ newEventWithTrigger = PostBuildT . lift . newEventWithTrigger
98+ {-# INLINABLE newFanEventWithTrigger #-}
99+ newFanEventWithTrigger f = PostBuildT $ lift $ newFanEventWithTrigger f
100+
101+instance TriggerEvent t m => TriggerEvent t (PostBuildT t m) where
102+ {-# INLINABLE newTriggerEvent #-}
103+ newTriggerEvent = lift newTriggerEvent
104+ {-# INLINABLE newTriggerEventWithOnComplete #-}
105+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
106+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
107+
108+instance MonadRef m => MonadRef (PostBuildT t m) where
109+ type Ref (PostBuildT t m) = Ref m
110+ {-# INLINABLE newRef #-}
111+ newRef = lift . newRef
112+ {-# INLINABLE readRef #-}
113+ readRef = lift . readRef
114+ {-# INLINABLE writeRef #-}
115+ writeRef r = lift . writeRef r
116+
117+instance MonadAtomicRef m => MonadAtomicRef (PostBuildT t m) where
118+ {-# INLINABLE atomicModifyRef #-}
119+ atomicModifyRef r = lift . atomicModifyRef r
120+
121+instance (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, PerformEvent t m) => Adjustable t (PostBuildT t m) where
122+ runWithReplace a0 a' = do
123+ postBuild <- getPostBuild
124+ lift $ do
125+ rec result@(_, result') <- runWithReplace (runPostBuildT a0 postBuild) $ fmap (\v -> runPostBuildT v =<< headE voidResult') a'
126+ let voidResult' = fmapCheap (\_ -> ()) result'
127+ return result
128+ {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}
129+ traverseIntMapWithKeyWithAdjust = mapIntMapWithAdjustImpl traverseIntMapWithKeyWithAdjust
130+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
131+ traverseDMapWithKeyWithAdjust = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap
132+ traverseDMapWithKeyWithAdjustWithMove = mapDMapWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove
133+
134+{-# INLINABLE mapIntMapWithAdjustImpl #-}
135+mapIntMapWithAdjustImpl :: forall t m v v' p. (Reflex t, MonadFix m, MonadHold t m, Functor p)
136+ => ( (IntMap.Key -> (Event t (), v) -> m v')
137+ -> IntMap (Event t (), v)
138+ -> Event t (p (Event t (), v))
139+ -> m (IntMap v', Event t (p v'))
140+ )
141+ -> (IntMap.Key -> v -> PostBuildT t m v')
142+ -> IntMap v
143+ -> Event t (p v)
144+ -> PostBuildT t m (IntMap v', Event t (p v'))
145+mapIntMapWithAdjustImpl base f dm0 dm' = do
146+ postBuild <- getPostBuild
147+ let loweredDm0 = fmap ((,) postBuild) dm0
148+ f' :: IntMap.Key -> (Event t (), v) -> m v'
149+ f' k (e, v) = do
150+ runPostBuildT (f k v) e
151+ lift $ do
152+ rec (result0, result') <- base f' loweredDm0 loweredDm'
153+ cohortDone <- numberOccurrencesFrom_ 1 result'
154+ numberedDm' <- numberOccurrencesFrom 1 dm'
155+ let postBuild' = fanInt $ fmapCheap (`IntMap.singleton` ()) cohortDone
156+ loweredDm' = flip pushAlways numberedDm' $ \(n, p) -> do
157+ return $ fmap ((,) (selectInt postBuild' n)) p
158+ return (result0, result')
159+
160+{-# INLINABLE mapDMapWithAdjustImpl #-}
161+mapDMapWithAdjustImpl :: forall t m k v v' p. (Reflex t, MonadFix m, MonadHold t m)
162+ => ( (forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a))
163+ -> DMap k (Compose ((,) (Bool, Event t ())) v)
164+ -> Event t (p k (Compose ((,) (Bool, Event t ())) v))
165+ -> m (DMap k v', Event t (p k v'))
166+ )
167+ -> ((forall a. v a -> Compose ((,) (Bool, Event t ())) v a) -> p k v -> p k (Compose ((,) (Bool, Event t ())) v))
168+ -> (forall a. k a -> v a -> PostBuildT t m (v' a))
169+ -> DMap k v
170+ -> Event t (p k v)
171+ -> PostBuildT t m (DMap k v', Event t (p k v'))
172+mapDMapWithAdjustImpl base mapPatch f dm0 dm' = do
173+ postBuild <- getPostBuild
174+ let loweredDm0 = DMap.map (Compose . (,) (False, postBuild)) dm0
175+ f' :: forall a. k a -> Compose ((,) (Bool, Event t ())) v a -> m (v' a)
176+ f' k (Compose ((shouldHeadE, e), v)) = do
177+ eOnce <- if shouldHeadE
178+ 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
179+ else return e
180+ runPostBuildT (f k v) eOnce
181+ lift $ do
182+ rec (result0, result') <- base f' loweredDm0 loweredDm'
183+ let voidResult' = fmapCheap (\_ -> ()) result'
184+ let loweredDm' = ffor dm' $ mapPatch (Compose . (,) (True, voidResult'))
185+ return (result0, result')
186+
187+--------------------------------------------------------------------------------
188+-- Deprecated functionality
189+--------------------------------------------------------------------------------
190+
191+-- | Deprecated
192+instance TransControl.MonadTransControl (PostBuildT t) where
193+ type StT (PostBuildT t) a = TransControl.StT (ReaderT (Event t ())) a
194+ {-# INLINABLE liftWith #-}
195+ liftWith = TransControl.defaultLiftWith PostBuildT unPostBuildT
196+ {-# INLINABLE restoreT #-}
197+ 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+288
@@ -0,0 +1,288 @@
1+{-# LANGUAGE FlexibleInstances #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE InstanceSigs #-}
4+{-# LANGUAGE KindSignatures #-}
5+{-# LANGUAGE LambdaCase #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE RankNTypes #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE UndecidableInstances #-}
11+module Reflex.Query.Base
12+ ( QueryT (..)
13+ , runQueryT
14+ , mapQuery
15+ , mapQueryResult
16+ , dynWithQueryT
17+ , withQueryT
18+ ) where
19+
20+import Control.Applicative (liftA2)
21+import Control.Monad.Exception
22+import Control.Monad.Fix
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, DSum (..))
28+import qualified Data.Dependent.Map as DMap
29+import Data.Foldable
30+import Data.Functor.Compose
31+import Data.Functor.Misc
32+import Data.Map (Map)
33+import qualified Data.Map as Map
34+import Data.Monoid ((<>))
35+import qualified Data.Semigroup as S
36+import Data.Some (Some)
37+import qualified Data.Some as Some
38+import Data.These
39+
40+import Reflex.Class
41+import Reflex.Adjustable.Class
42+import Reflex.EventWriter.Base
43+import Reflex.EventWriter.Class
44+import Reflex.Host.Class
45+import qualified Reflex.Patch.MapWithMove as MapWithMove
46+import Reflex.PerformEvent.Class
47+import Reflex.PostBuild.Class
48+import Reflex.Query.Class
49+import Reflex.Requester.Class
50+import Reflex.TriggerEvent.Class
51+
52+newtype QueryT t q m a = QueryT { unQueryT :: StateT [Behavior t q] (EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m)) a }
53+ deriving (Functor, Applicative, Monad, MonadException, MonadFix, MonadIO, MonadHold t, MonadSample t, MonadAtomicRef)
54+
55+runQueryT :: (MonadFix m, Additive q, Group q, Reflex t) => QueryT t q m a -> Dynamic t (QueryResult q) -> m (a, Incremental t (AdditivePatch q))
56+runQueryT (QueryT a) qr = do
57+ ((r, bs), es) <- runReaderT (runEventWriterT (runStateT a mempty)) qr
58+ return (r, unsafeBuildIncremental (foldlM (\b c -> (b <>) <$> sample c) mempty bs) (fmapCheap AdditivePatch es))
59+
60+newtype QueryTLoweredResult t q v = QueryTLoweredResult (v, [Behavior t q])
61+
62+getQueryTLoweredResultValue :: QueryTLoweredResult t q v -> v
63+getQueryTLoweredResultValue (QueryTLoweredResult (v, _)) = v
64+
65+getQueryTLoweredResultWritten :: QueryTLoweredResult t q v -> [Behavior t q]
66+getQueryTLoweredResultWritten (QueryTLoweredResult (_, w)) = w
67+
68+{-
69+let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
70+ sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
71+ bs' = fmapCheap snd $ r'
72+ patches = unsafeBuildIncremental (sampleBs bs0) $
73+ flip pushCheap bs' $ \bs -> do
74+ p <- (~~) <$> sampleBs bs <*> sample (currentIncremental patches)
75+ return (Just (AdditivePatch p))
76+-}
77+
78+instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Adjustable t m) => Adjustable t (QueryT t q m) where
79+ runWithReplace (QueryT a0) a' = do
80+ ((r0, bs0), r') <- QueryT $ lift $ runWithReplace (runStateT a0 []) $ fmapCheap (flip runStateT [] . unQueryT) a'
81+ let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
82+ sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
83+ bs' = fmapCheap snd $ r'
84+ bbs <- hold bs0 bs'
85+ let patches = flip pushAlwaysCheap bs' $ \newBs -> do
86+ oldBs <- sample bbs
87+ (~~) <$> sampleBs newBs <*> sampleBs oldBs
88+ QueryT $ modify $ (:) $ pull $ sampleBs =<< sample bbs
89+ QueryT $ lift $ tellEvent patches
90+ return (r0, fmapCheap fst r')
91+ 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'))
92+ traverseDMapWithKeyWithAdjust f dm0 dm' = do
93+ let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
94+ f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
95+ (result0, result') <- QueryT $ lift $ traverseDMapWithKeyWithAdjust f' dm0 dm'
96+ let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0
97+ liftedResult' = fforCheap result' $ \(PatchDMap p) -> PatchDMap $
98+ mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mr) -> k :=> ComposeMaybe (fmap (getQueryTLoweredResultValue . getCompose) mr)) p
99+ liftedBs0 :: Map (Some k) [Behavior t q]
100+ liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0
101+ liftedBs' :: Event t (PatchMap (Some k) [Behavior t q])
102+ liftedBs' = fforCheap result' $ \(PatchDMap p) -> PatchMap $
103+ Map.fromDistinctAscList $ (\(k :=> ComposeMaybe mr) -> (Some.This k, fmap (getQueryTLoweredResultWritten . getCompose) mr)) <$> DMap.toList p
104+ sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
105+ sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
106+ accumBehaviors :: forall m'. MonadHold t m'
107+ => Map (Some k) [Behavior t q]
108+ -> PatchMap (Some k) [Behavior t q]
109+ -> m' ( Maybe (Map (Some k) [Behavior t q])
110+ , Maybe (AdditivePatch q))
111+ -- f accumulates the child behavior state we receive from running traverseDMapWithKeyWithAdjust for the underlying monad.
112+ -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.
113+ -- bs0 is a Map denoting the behaviors of the current children.
114+ -- pbs is a PatchMap denoting an update to the behaviors of the current children
115+ accumBehaviors bs0 pbs@(PatchMap bs') = do
116+ let p k bs = case Map.lookup k bs0 of
117+ Nothing -> case bs of
118+ -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
119+ Nothing -> return mempty
120+ -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.
121+ Just newBs -> sampleBs newBs
122+ Just oldBs -> case bs of
123+ -- 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
124+ Nothing -> negateG <$> sampleBs oldBs
125+ -- 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
126+ -- composed with the sampling the child's new state.
127+ Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
128+ -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
129+ -- child patches and wrap them in AdditivePatch.
130+ patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'
131+ return (apply pbs bs0, Just patch)
132+ (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs'
133+ tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
134+ return (liftedResult0, liftedResult')
135+ 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'))
136+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do
137+ let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a)
138+ f' k v = fmap (Compose . QueryTLoweredResult) $ flip runStateT [] $ unQueryT $ f k v
139+ (result0, result') <- QueryT $ lift $ traverseDMapWithKeyWithAdjustWithMove f' dm0 dm'
140+ let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0
141+ liftedResult' = fforCheap result' $ mapPatchDMapWithMove (getQueryTLoweredResultValue . getCompose)
142+ liftedBs0 :: Map (Some k) [Behavior t q]
143+ liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0
144+ liftedBs' :: Event t (PatchMapWithMove (Some k) [Behavior t q])
145+ liftedBs' = fforCheap result' $ weakenPatchDMapWithMoveWith (getQueryTLoweredResultWritten . getCompose) {- \(PatchDMap p) -> PatchMapWithMove $
146+ Map.fromDistinctAscList $ (\(k :=> mr) -> (Some.This k, fmap (fmap (getQueryTLoweredResultWritten . getCompose)) mr)) <$> DMap.toList p -}
147+ sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q
148+ sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty
149+ accumBehaviors' :: forall m'. MonadHold t m'
150+ => Map (Some k) [Behavior t q]
151+ -> PatchMapWithMove (Some k) [Behavior t q]
152+ -> m' ( Maybe (Map (Some k) [Behavior t q])
153+ , Maybe (AdditivePatch q))
154+ -- f accumulates the child behavior state we receive from running traverseDMapWithKeyWithAdjustWithMove for the underlying monad.
155+ -- When an update occurs, it also computes a patch to communicate to the parent QueryT state.
156+ -- bs0 is a Map denoting the behaviors of the current children.
157+ -- pbs is a PatchMapWithMove denoting an update to the behaviors of the current children
158+ accumBehaviors' bs0 pbs = do
159+ let bs' = unPatchMapWithMove pbs
160+ p k bs = case Map.lookup k bs0 of
161+ Nothing -> case MapWithMove._nodeInfo_from bs of
162+ -- If the update is to delete the state for a child that doesn't exist, the patch is mempty.
163+ MapWithMove.From_Delete -> return mempty
164+ -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state.
165+ MapWithMove.From_Insert newBs -> sampleBs newBs
166+ MapWithMove.From_Move k' -> case Map.lookup k' bs0 of
167+ Nothing -> return mempty
168+ Just newBs -> sampleBs newBs
169+ Just oldBs -> case MapWithMove._nodeInfo_from bs of
170+ -- 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
171+ MapWithMove.From_Delete -> negateG <$> sampleBs oldBs
172+ -- 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
173+ -- composed with the sampling the child's new state.
174+ MapWithMove.From_Insert newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
175+ MapWithMove.From_Move k'
176+ | k' == k -> return mempty
177+ | otherwise -> case Map.lookup k' bs0 of
178+ -- If we are moving from a non-existent key, that is a delete
179+ Nothing -> negateG <$> sampleBs oldBs
180+ Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs
181+ -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the
182+ -- child patches and wrap them in AdditivePatch.
183+ patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs'
184+ return (apply pbs bs0, Just patch)
185+ (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors' liftedBs0 liftedBs'
186+ tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch
187+ return (liftedResult0, liftedResult')
188+
189+instance MonadTrans (QueryT t q) where
190+ lift = QueryT . lift . lift . lift
191+
192+instance PostBuild t m => PostBuild t (QueryT t q m) where
193+ getPostBuild = lift getPostBuild
194+
195+instance (MonadAsyncException m) => MonadAsyncException (QueryT t q m) where
196+ mask f = QueryT $ mask $ \unMask -> unQueryT $ f $ QueryT . unMask . unQueryT
197+
198+instance TriggerEvent t m => TriggerEvent t (QueryT t q m) where
199+ newTriggerEvent = lift newTriggerEvent
200+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
201+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
202+
203+instance PerformEvent t m => PerformEvent t (QueryT t q m) where
204+ type Performable (QueryT t q m) = Performable m
205+ performEvent_ = lift . performEvent_
206+ performEvent = lift . performEvent
207+
208+instance MonadRef m => MonadRef (QueryT t q m) where
209+ type Ref (QueryT t q m) = Ref m
210+ newRef = QueryT . newRef
211+ readRef = QueryT . readRef
212+ writeRef r = QueryT . writeRef r
213+
214+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (QueryT t q m) where
215+ newEventWithTrigger = QueryT . newEventWithTrigger
216+ newFanEventWithTrigger a = QueryT . lift $ newFanEventWithTrigger a
217+
218+-- TODO: Monoid and Semigroup can likely be derived once StateT has them.
219+instance (Monoid a, Monad m) => Monoid (QueryT t q m a) where
220+ mempty = pure mempty
221+ mappend = (<>)
222+
223+instance (S.Semigroup a, Monad m) => S.Semigroup (QueryT t q m a) where
224+ (<>) = liftA2 (S.<>)
225+
226+
227+mapQuery :: QueryMorphism q q' -> q -> q'
228+mapQuery = _queryMorphism_mapQuery
229+
230+mapQueryResult :: QueryMorphism q q' -> QueryResult q' -> QueryResult q
231+mapQueryResult = _queryMorphism_mapQueryResult
232+
233+-- | withQueryT's QueryMorphism argument needs to be a group homomorphism in order to behave correctly
234+withQueryT :: (MonadFix m, PostBuild t m, Group q, Group q', Additive q, Additive q', Query q')
235+ => QueryMorphism q q'
236+ -> QueryT t q m a
237+ -> QueryT t q' m a
238+withQueryT f a = do
239+ r' <- askQueryResult
240+ (result, q) <- lift $ runQueryT a $ mapQueryResult f <$> r'
241+ tellQueryIncremental $ unsafeBuildIncremental
242+ (fmap (mapQuery f) (sample (currentIncremental q)))
243+ (fmapCheap (AdditivePatch . mapQuery f . unAdditivePatch) $ updatedIncremental q)
244+ return result
245+
246+-- | dynWithQueryT's (Dynamic t QueryMorphism) argument needs to be a group homomorphism at all times in order to behave correctly
247+dynWithQueryT :: (MonadFix m, PostBuild t m, Group q, Additive q, Group q', Additive q', Query q')
248+ => Dynamic t (QueryMorphism q q')
249+ -> QueryT t q m a
250+ -> QueryT t q' m a
251+dynWithQueryT f q = do
252+ r' <- askQueryResult
253+ (result, q') <- lift $ runQueryT q $ zipDynWith mapQueryResult f r'
254+ tellQueryIncremental $ zipDynIncrementalWith mapQuery f q'
255+ return result
256+ where zipDynIncrementalWith g da ib =
257+ let eab = align (updated da) (updatedIncremental ib)
258+ ec = flip push eab $ \case
259+ This a -> do
260+ aOld <- sample $ current da
261+ b <- sample $ currentIncremental ib
262+ return $ Just $ AdditivePatch (g a b ~~ g aOld b)
263+ That (AdditivePatch b) -> do
264+ a <- sample $ current da
265+ return $ Just $ AdditivePatch $ g a b
266+ These a (AdditivePatch b) -> do
267+ aOld <- sample $ current da
268+ bOld <- sample $ currentIncremental ib
269+ return $ Just $ AdditivePatch $ mconcat [ g a bOld, negateG (g aOld bOld), g a b]
270+ in unsafeBuildIncremental (g <$> sample (current da) <*> sample (currentIncremental ib)) ec
271+
272+instance (Monad m, Group q, Additive q, Query q, Reflex t) => MonadQuery t q (QueryT t q m) where
273+ tellQueryIncremental q = do
274+ QueryT (modify (currentIncremental q:))
275+ QueryT (lift (tellEvent (fmapCheap unAdditivePatch (updatedIncremental q))))
276+ askQueryResult = QueryT ask
277+ queryIncremental q = do
278+ tellQueryIncremental q
279+ zipDynWith crop (incrementalToDynamic q) <$> askQueryResult
280+
281+instance Requester t m => Requester t (QueryT t q m) where
282+ type Request (QueryT t q m) = Request m
283+ type Response (QueryT t q m) = Response m
284+ requesting = lift . requesting
285+ requesting_ = lift . requesting_
286+
287+instance EventWriter t w m => EventWriter t w (QueryT t q m) where
288+ tellEvent = lift . tellEvent
src/Reflex/Query/Class.hsnew file+76
@@ -0,0 +1,76 @@
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+ zipDynWith crop q <$> askQueryResult
src/Reflex/Requester/Base.hsnew file+429
@@ -0,0 +1,429 @@
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.Adjustable.Class
36+import Reflex.Dynamic
37+import Reflex.Host.Class
38+import Reflex.PerformEvent.Class
39+import Reflex.PostBuild.Class
40+import Reflex.Requester.Class
41+import Reflex.TriggerEvent.Class
42+
43+import Control.Applicative (liftA2)
44+import Control.Monad.Exception
45+import Control.Monad.Identity
46+import Control.Monad.Reader
47+import Control.Monad.Ref
48+import Control.Monad.State.Strict
49+import Data.Bits
50+import Data.Coerce
51+import Data.Dependent.Map (DMap, DSum (..))
52+import qualified Data.Dependent.Map as DMap
53+import Data.Functor.Compose
54+import Data.Functor.Misc
55+import Data.IntMap.Strict (IntMap)
56+import qualified Data.IntMap.Strict as IntMap
57+import Data.Map (Map)
58+import qualified Data.Map as Map
59+import Data.Monoid ((<>))
60+import Data.Proxy
61+import qualified Data.Semigroup as S
62+import Data.Some (Some)
63+import qualified Data.Some as Some
64+import Data.Type.Equality
65+import Data.Unique.Tag
66+
67+import GHC.Exts (Any)
68+import Unsafe.Coerce
69+
70+--TODO: Make this module type-safe
71+
72+newtype TagMap (f :: * -> *) = TagMap (IntMap Any)
73+
74+newtype RequesterData f = RequesterData (TagMap (Entry f))
75+
76+data RequesterDataKey a where
77+ RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a
78+ 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
79+ RequesterDataKey_Multi2 :: {-# UNPACK #-} !(MyTag (Multi2 k)) -> !(Some k) -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
80+ RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !(RequesterDataKey a) -> RequesterDataKey a
81+
82+singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f
83+singletonRequesterData rdk v = case rdk of
84+ RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v
85+ RequesterDataKey_Multi k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v
86+ RequesterDataKey_Multi2 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ Map.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
87+ RequesterDataKey_Multi3 k k' k'' k''' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ IntMap.singleton k'' $ singletonRequesterData k''' v
88+
89+requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]
90+requesterDataToList (RequesterData m) = do
91+ k :=> Entry e <- tagMapToList m
92+ case myKeyType k of
93+ MyTagType_Single -> return $ RequesterDataKey_Single k :=> e
94+ MyTagType_Multi -> do
95+ (k', e') <- IntMap.toList e
96+ k'' :=> e'' <- requesterDataToList e'
97+ return $ RequesterDataKey_Multi k k' k'' :=> e''
98+ MyTagType_Multi2 -> do
99+ (k', e') <- Map.toList e
100+ (k'', e'') <- IntMap.toList e'
101+ k''' :=> e''' <- requesterDataToList e''
102+ return $ RequesterDataKey_Multi2 k k' k'' k''' :=> e'''
103+ MyTagType_Multi3 -> do
104+ (k', e') <- IntMap.toList e
105+ (k'', e'') <- IntMap.toList e'
106+ k''' :=> e''' <- requesterDataToList e''
107+ return $ RequesterDataKey_Multi3 k k' k'' k''' :=> e'''
108+
109+singletonTagMap :: forall f a. MyTag a -> f a -> TagMap f
110+singletonTagMap (MyTag k) v = TagMap $ IntMap.singleton k $ (unsafeCoerce :: f a -> Any) v
111+
112+tagMapToList :: forall f. TagMap f -> [DSum MyTag f]
113+tagMapToList (TagMap m) = f <$> IntMap.toList m
114+ where f :: (Int, Any) -> DSum MyTag f
115+ f (k, v) = MyTag k :=> (unsafeCoerce :: Any -> f a) v
116+
117+traverseTagMapWithKey :: forall t f g. Applicative t => (forall a. MyTag a -> f a -> t (g a)) -> TagMap f -> t (TagMap g)
118+traverseTagMapWithKey f (TagMap m) = TagMap <$> IntMap.traverseWithKey g m
119+ where
120+ g :: Int -> Any -> t Any
121+ g k v = (unsafeCoerce :: g a -> Any) <$> f (MyTag k) ((unsafeCoerce :: Any -> f a) v)
122+
123+-- | Runs in reverse to accommodate for the fact that we accumulate it in reverse
124+traverseRequesterData :: forall m request response. Applicative m => (forall a. request a -> m (response a)) -> RequesterData request -> m (RequesterData response)
125+traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWithKey go m --TODO: reverse this, since our tags are in reverse order
126+ where go :: forall x. MyTag x -> Entry request x -> m (Entry response x)
127+ go k (Entry request) = Entry <$> case myKeyType k of
128+ MyTagType_Single -> f request
129+ MyTagType_Multi -> traverse (traverseRequesterData f) request
130+ MyTagType_Multi2 -> traverse (traverse (traverseRequesterData f)) request
131+ MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request
132+
133+data MyTagType :: * -> * where
134+ MyTagType_Single :: MyTagType (Single a)
135+ MyTagType_Multi :: MyTagType Multi
136+ MyTagType_Multi2 :: MyTagType (Multi2 k)
137+ MyTagType_Multi3 :: MyTagType Multi3
138+
139+myKeyType :: MyTag x -> MyTagType x
140+myKeyType (MyTag k) = case k .&. 0x3 of
141+ 0x0 -> unsafeCoerce MyTagType_Single
142+ 0x1 -> unsafeCoerce MyTagType_Multi
143+ 0x2 -> unsafeCoerce MyTagType_Multi2
144+ 0x3 -> unsafeCoerce MyTagType_Multi3
145+ t -> error $ "Reflex.Requester.Base.myKeyType: no such key type" <> show t
146+
147+data Single a
148+data Multi
149+data Multi2 (k :: * -> *)
150+data Multi3
151+
152+class MyTagTypeOffset x where
153+ myTagTypeOffset :: proxy x -> Int
154+
155+instance MyTagTypeOffset (Single a) where
156+ myTagTypeOffset _ = 0x0
157+
158+instance MyTagTypeOffset Multi where
159+ myTagTypeOffset _ = 0x1
160+
161+instance MyTagTypeOffset (Multi2 k) where
162+ myTagTypeOffset _ = 0x2
163+
164+instance MyTagTypeOffset Multi3 where
165+ myTagTypeOffset _ = 0x3
166+
167+type family EntryContents request a where
168+ EntryContents request (Single a) = request a
169+ EntryContents request Multi = IntMap (RequesterData request)
170+ EntryContents request (Multi2 k) = Map (Some k) (IntMap (RequesterData request))
171+ EntryContents request Multi3 = IntMap (IntMap (RequesterData request))
172+
173+newtype Entry request x = Entry { unEntry :: EntryContents request x }
174+
175+{-# INLINE singleEntry #-}
176+singleEntry :: f a -> Entry f (Single a)
177+singleEntry = Entry
178+
179+{-# INLINE multiEntry #-}
180+multiEntry :: IntMap (RequesterData f) -> Entry f Multi
181+multiEntry = Entry
182+
183+{-# INLINE unMultiEntry #-}
184+unMultiEntry :: Entry f Multi -> IntMap (RequesterData f)
185+unMultiEntry = unEntry
186+
187+-- | 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
188+-- 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
189+newtype MyTag x = MyTag Int deriving (Show, Eq, Ord, Enum)
190+
191+newtype MyTagWrap (f :: * -> *) x = MyTagWrap Int deriving (Show, Eq, Ord, Enum)
192+
193+{-# INLINE castMyTagWrap #-}
194+castMyTagWrap :: MyTagWrap f (Entry f x) -> MyTagWrap g (Entry g x)
195+castMyTagWrap = coerce
196+
197+instance GEq MyTag where
198+ (MyTag a) `geq` (MyTag b) =
199+ if a == b
200+ then Just $ unsafeCoerce Refl
201+ else Nothing
202+
203+instance GCompare MyTag where
204+ (MyTag a) `gcompare` (MyTag b) =
205+ case a `compare` b of
206+ LT -> GLT
207+ EQ -> unsafeCoerce GEQ
208+ GT -> GGT
209+
210+instance GEq (MyTagWrap f) where
211+ (MyTagWrap a) `geq` (MyTagWrap b) =
212+ if a == b
213+ then Just $ unsafeCoerce Refl
214+ else Nothing
215+
216+instance GCompare (MyTagWrap f) where
217+ (MyTagWrap a) `gcompare` (MyTagWrap b) =
218+ case a `compare` b of
219+ LT -> GLT
220+ EQ -> unsafeCoerce GEQ
221+ GT -> GGT
222+
223+data RequesterState t (request :: * -> *) = RequesterState
224+ { _requesterState_nextMyTag :: {-# UNPACK #-} !Int -- Starts at -4 and goes down by 4 each time, to accommodate two 'type' bits at the bottom
225+ , _requesterState_requests :: ![(Int, Event t Any)]
226+ }
227+
228+-- | A basic implementation of 'Requester'.
229+newtype RequesterT t request (response :: * -> *) m a = RequesterT { unRequesterT :: StateT (RequesterState t request) (ReaderT (EventSelectorInt t Any) m) a }
230+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException
231+-- MonadAsyncException can't be derived on ghc-8.0.1; we use base-4.9.1 as a proxy for ghc-8.0.2
232+#if MIN_VERSION_base(4,9,1)
233+ , MonadAsyncException
234+#endif
235+ )
236+
237+deriving instance MonadSample t m => MonadSample t (RequesterT t request response m)
238+deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)
239+deriving instance PostBuild t m => PostBuild t (RequesterT t request response m)
240+deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)
241+
242+-- TODO: Monoid and Semigroup can likely be derived once StateT has them.
243+instance (Monoid a, Monad m) => Monoid (RequesterT t request response m a) where
244+ mempty = pure mempty
245+ mappend = liftA2 mappend
246+
247+instance (S.Semigroup a, Monad m) => S.Semigroup (RequesterT t request response m a) where
248+ (<>) = liftA2 (S.<>)
249+
250+
251+-- | Run a 'RequesterT' action. The resulting 'Event' will fire whenever
252+-- requests are made, and responses should be provided in the input 'Event'.
253+-- The 'Tag' keys will be used to return the responses to the same place the
254+-- requests were issued.
255+
256+runRequesterT :: (Reflex t, Monad m)
257+ => RequesterT t request response m a
258+ -> Event t (RequesterData response) --TODO: This DMap will be in reverse order, so we need to make sure the caller traverses it in reverse
259+ -> m (a, Event t (RequesterData request)) --TODO: we need to hide these 'MyTag's here, because they're unsafe to mix in the wild
260+runRequesterT (RequesterT a) responses = do
261+ (result, s) <- runReaderT (runStateT a $ RequesterState (-4) []) $ fanInt $
262+ coerceEvent responses
263+ return (result, fmapCheap (RequesterData . TagMap) $ mergeInt $ IntMap.fromDistinctAscList $ _requesterState_requests s)
264+
265+instance (Reflex t, Monad m) => Requester t (RequesterT t request response m) where
266+ type Request (RequesterT t request response m) = request
267+ type Response (RequesterT t request response m) = response
268+ requesting = fmap coerceEvent . responseFromTag . castMyTagWrap <=< tagRequest . (coerceEvent :: Event t (request a) -> Event t (Entry request (Single a)))
269+ requesting_ = void . tagRequest . fmapCheap singleEntry
270+
271+{-# INLINE tagRequest #-}
272+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))
273+tagRequest req = do
274+ old <- RequesterT get
275+ let n = _requesterState_nextMyTag old .|. myTagTypeOffset (Proxy :: Proxy x)
276+ t = MyTagWrap n
277+ RequesterT $ put $ RequesterState
278+ { _requesterState_nextMyTag = _requesterState_nextMyTag old - 0x4
279+ , _requesterState_requests = (n, (unsafeCoerce :: Event t (Entry request x) -> Event t Any) req) : _requesterState_requests old
280+ }
281+ return t
282+
283+{-# INLINE responseFromTag #-}
284+responseFromTag :: Monad m => MyTagWrap response (Entry response x) -> RequesterT t request response m (Event t (Entry response x))
285+responseFromTag (MyTagWrap t) = do
286+ responses :: EventSelectorInt t Any <- RequesterT ask
287+ return $ (unsafeCoerce :: Event t Any -> Event t (Entry response x)) $ selectInt responses t
288+
289+instance MonadTrans (RequesterT t request response) where
290+ lift = RequesterT . lift . lift
291+
292+instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where
293+ type Performable (RequesterT t request response m) = Performable m
294+ performEvent_ = lift . performEvent_
295+ performEvent = lift . performEvent
296+
297+instance MonadRef m => MonadRef (RequesterT t request response m) where
298+ type Ref (RequesterT t request response m) = Ref m
299+ newRef = lift . newRef
300+ readRef = lift . readRef
301+ writeRef r = lift . writeRef r
302+
303+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT t request response m) where
304+ newEventWithTrigger = lift . newEventWithTrigger
305+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
306+
307+instance MonadReader r m => MonadReader r (RequesterT t request response m) where
308+ ask = lift ask
309+ local f (RequesterT a) = RequesterT $ mapStateT (mapReaderT $ local f) a
310+ reader = lift . reader
311+
312+instance (Reflex t, Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (RequesterT t request response m) where
313+ runWithReplace = runWithReplaceRequesterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
314+ traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElementsMap mergeIntIncremental
315+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
316+ traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental
317+ traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustRequesterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove
318+
319+requesting' :: (MyTagTypeOffset x, Monad m) => Event t (Entry request x) -> RequesterT t request response m (Event t (Entry response x))
320+requesting' = responseFromTag . castMyTagWrap <=< tagRequest
321+
322+{-# INLINABLE runWithReplaceRequesterTWith #-}
323+runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m
324+ , MonadFix m
325+ )
326+ => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))
327+ -> RequesterT t request response m a
328+ -> Event t (RequesterT t request response m b)
329+ -> RequesterT t request response m (a, Event t b)
330+runWithReplaceRequesterTWith f a0 a' = do
331+ rec na' <- numberOccurrencesFrom 1 a'
332+ responses <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here
333+ let responses' = fanInt responses
334+ ((result0, requests0), v') <- f (runRequesterT a0 (selectInt responses' 0)) $ fmapCheap (\(n, a) -> fmap ((,) n) $ runRequesterT a $ selectInt responses' n) na'
335+ requests <- holdDyn (fmapCheap (IntMap.singleton 0) requests0) $ fmapCheap (\(n, (_, reqs)) -> fmapCheap (IntMap.singleton n) reqs) v'
336+ return (result0, fmapCheap (fst . snd) v')
337+
338+{-# INLINE traverseIntMapWithKeyWithAdjustRequesterTWith #-}
339+traverseIntMapWithKeyWithAdjustRequesterTWith :: forall t request response m v v' p.
340+ ( Reflex t
341+ , MonadHold t m
342+ , PatchTarget (p (Event t (IntMap (RequesterData request)))) ~ IntMap (Event t (IntMap (RequesterData request)))
343+ , Patch (p (Event t (IntMap (RequesterData request))))
344+ , Functor p
345+ , MonadFix m
346+ )
347+ => ( (IntMap.Key -> (IntMap.Key, v) -> m (Event t (IntMap (RequesterData request)), v'))
348+ -> IntMap (IntMap.Key, v)
349+ -> Event t (p (IntMap.Key, v))
350+ -> RequesterT t request response m (IntMap (Event t (IntMap (RequesterData request)), v'), Event t (p (Event t (IntMap (RequesterData request)), v')))
351+ )
352+ -> (p (Event t (IntMap (RequesterData request))) -> IntMap (Event t (IntMap (RequesterData request))))
353+ -> (Incremental t (p (Event t (IntMap (RequesterData request)))) -> Event t (IntMap (IntMap (RequesterData request))))
354+ -> (IntMap.Key -> v -> RequesterT t request response m v')
355+ -> IntMap v
356+ -> Event t (p v)
357+ -> RequesterT t request response m (IntMap v', Event t (p v'))
358+traverseIntMapWithKeyWithAdjustRequesterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do
359+ rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here
360+ let responses :: EventSelectorInt t (IntMap (RequesterData response))
361+ responses = fanInt $ fmapCheap unpack response
362+ unpack :: Entry response Multi3 -> IntMap (IntMap (RequesterData response))
363+ unpack = unEntry
364+ pack :: IntMap (IntMap (RequesterData request)) -> Entry request Multi3
365+ pack = Entry
366+ f' :: IntMap.Key -> (Int, v) -> m (Event t (IntMap (RequesterData request)), v')
367+ f' k (n, v) = do
368+ (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?
369+ return (fmapCheap (IntMap.singleton n) myRequests, result)
370+ ndm' <- numberOccurrencesFrom 1 dm'
371+ (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
372+ let result0 = fmap snd children0
373+ result' = fforCheap children' $ fmap snd
374+ requests0 :: IntMap (Event t (IntMap (RequesterData request)))
375+ requests0 = fmap fst children0
376+ requests' :: Event t (p (Event t (IntMap (RequesterData request))))
377+ requests' = fforCheap children' $ fmap fst
378+ promptRequests :: Event t (IntMap (IntMap (RequesterData request)))
379+ promptRequests = coincidence $ fmapCheap (mergeInt . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
380+ requests <- holdIncremental requests0 requests'
381+ return (result0, result')
382+
383+{-# INLINE traverseDMapWithKeyWithAdjustRequesterTWith #-}
384+traverseDMapWithKeyWithAdjustRequesterTWith :: forall k t request response m v v' p p'.
385+ ( GCompare k
386+ , Reflex t
387+ , MonadHold t m
388+ , PatchTarget (p' (Some k) (Event t (IntMap (RequesterData request)))) ~ Map (Some k) (Event t (IntMap (RequesterData request)))
389+ , Patch (p' (Some k) (Event t (IntMap (RequesterData request))))
390+ , MonadFix m
391+ )
392+ => (forall k' v1 v2. GCompare k'
393+ => (forall a. k' a -> v1 a -> m (v2 a))
394+ -> DMap k' v1
395+ -> Event t (p k' v1)
396+ -> RequesterT t request response m (DMap k' v2, Event t (p k' v2))
397+ )
398+ -> (forall v1 v2. (forall a. v1 a -> v2 a) -> p k v1 -> p k v2)
399+ -> (forall v1 v2. (forall a. v1 a -> v2) -> p k v1 -> p' (Some k) v2)
400+ -> (forall v2. p' (Some k) v2 -> Map (Some k) v2)
401+ -> (forall a. Incremental t (p' (Some k) (Event t a)) -> Event t (Map (Some k) a))
402+ -> (forall a. k a -> v a -> RequesterT t request response m (v' a))
403+ -> DMap k v
404+ -> Event t (p k v)
405+ -> RequesterT t request response m (DMap k v', Event t (p k v'))
406+traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do
407+ rec response <- requesting' $ fmapCheap pack $ promptRequests `mappend` mergePatchIncremental requests --TODO: Investigate whether we can really get rid of the prompt stuff here
408+ let responses :: EventSelector t (Const2 (Some k) (IntMap (RequesterData response)))
409+ responses = fanMap $ fmapCheap unpack response
410+ unpack :: Entry response (Multi2 k) -> Map (Some k) (IntMap (RequesterData response))
411+ unpack = unEntry
412+ pack :: Map (Some k) (IntMap (RequesterData request)) -> Entry request (Multi2 k)
413+ pack = Entry
414+ f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a)
415+ f' k (Compose (n, v)) = do
416+ (result, myRequests) <- runRequesterT (f k v) $ fmapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some.This k))
417+ return $ Compose (fmapCheap (IntMap.singleton n) myRequests, result)
418+ ndm' <- numberOccurrencesFrom 1 dm'
419+ (children0, children') <- base f' (DMap.map (\v -> Compose (0, v)) dm0) $ fmap (\(n, dm) -> mapPatch (\v -> Compose (n, v)) dm) ndm'
420+ let result0 = DMap.map (snd . getCompose) children0
421+ result' = fforCheap children' $ mapPatch $ snd . getCompose
422+ requests0 :: Map (Some k) (Event t (IntMap (RequesterData request)))
423+ requests0 = weakenDMapWith (fst . getCompose) children0
424+ requests' :: Event t (p' (Some k) (Event t (IntMap (RequesterData request))))
425+ requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose
426+ promptRequests :: Event t (Map (Some k) (IntMap (RequesterData request)))
427+ promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence'
428+ requests <- holdIncremental requests0 requests'
429+ 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+2622
@@ -0,0 +1,2622 @@
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 MultiParamTypeClasses #-}
13+{-# LANGUAGE MultiWayIf #-}
14+{-# LANGUAGE RankNTypes #-}
15+{-# LANGUAGE RoleAnnotations #-}
16+{-# LANGUAGE ScopedTypeVariables #-}
17+{-# LANGUAGE TypeFamilies #-}
18+{-# LANGUAGE TypeOperators #-}
19+{-# LANGUAGE UndecidableInstances #-}
20+#ifdef USE_REFLEX_OPTIMIZER
21+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
22+#endif
23+-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
24+-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
25+module Reflex.Spider.Internal (module Reflex.Spider.Internal) where
26+
27+#if MIN_VERSION_base(4,10,0)
28+import Control.Applicative (liftA2)
29+#endif
30+import Control.Concurrent
31+import Control.Exception
32+import Control.Monad hiding (forM, forM_, mapM, mapM_)
33+import Control.Monad.Exception
34+import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)
35+import Control.Monad.Primitive
36+import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_)
37+import Control.Monad.Ref
38+import Data.Align
39+import Data.Coerce
40+import Data.Dependent.Map (DMap, DSum (..))
41+import qualified Data.Dependent.Map as DMap
42+import Data.FastMutableIntMap (FastMutableIntMap, PatchIntMap (..))
43+import qualified Data.FastMutableIntMap as FastMutableIntMap
44+import Data.Foldable hiding (concat, elem, sequence_)
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.Maybe
53+import Data.Monoid ((<>))
54+import Data.Proxy
55+import Data.These
56+import Data.Traversable
57+import GHC.Exts
58+import GHC.IORef (IORef (..))
59+import GHC.Stack
60+import Reflex.FastWeak
61+import Reflex.FunctorMaybe
62+import System.IO.Unsafe
63+import System.Mem.Weak
64+import Unsafe.Coerce
65+
66+#ifdef DEBUG_CYCLES
67+import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)
68+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
69+import qualified Data.List.NonEmpty as NonEmpty
70+import Data.Monoid (mempty)
71+import Data.Tree (Forest, Tree (..), drawForest)
72+#endif
73+
74+import Data.FastWeakBag (FastWeakBag)
75+import qualified Data.FastWeakBag as FastWeakBag
76+import Data.Reflection
77+import Data.Some (Some)
78+import qualified Data.Some as Some
79+import Data.Type.Coercion
80+import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)
81+import qualified Data.WeakBag as WeakBag
82+import qualified Reflex.Class
83+import qualified Reflex.Class as R
84+import qualified Reflex.Host.Class
85+import Reflex.NotReady.Class
86+import Reflex.Patch
87+import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
88+
89+#ifdef DEBUG_TRACE_EVENTS
90+import qualified Data.ByteString.Char8 as BS8
91+import System.IO (stderr)
92+#endif
93+
94+#ifdef DEBUG_TRACE_EVENTS
95+
96+withStackOneLine :: (BS8.ByteString -> a) -> a
97+withStackOneLine expr = unsafePerformIO $ do
98+ stack <- currentCallStack
99+ return (expr (BS8.pack (unwords (reverse stack))))
100+
101+#endif
102+
103+debugPropagate :: Bool
104+
105+debugInvalidateHeight :: Bool
106+
107+debugInvalidate :: Bool
108+
109+#ifdef DEBUG
110+
111+#define DEBUG_NODEIDS
112+
113+debugPropagate = True
114+
115+debugInvalidateHeight = False
116+
117+debugInvalidate = True
118+
119+class HasNodeId a where
120+ getNodeId :: a -> Int
121+
122+instance HasNodeId (Hold x p a) where
123+ getNodeId = holdNodeId
124+
125+instance HasNodeId (PushSubscribed x a b) where
126+ getNodeId = pushSubscribedNodeId
127+
128+instance HasNodeId (SwitchSubscribed x a) where
129+ getNodeId = switchSubscribedNodeId
130+
131+instance HasNodeId (FanSubscribed x a) where
132+ getNodeId = fanSubscribedNodeId
133+
134+instance HasNodeId (CoincidenceSubscribed x a) where
135+ getNodeId = coincidenceSubscribedNodeId
136+
137+instance HasNodeId (RootSubscribed x a) where
138+ getNodeId = rootSubscribedNodeId
139+
140+instance HasNodeId (Pull x a) where
141+ getNodeId = pullNodeId
142+
143+{-# INLINE showNodeId #-}
144+showNodeId :: HasNodeId a => a -> String
145+showNodeId = ("#"<>) . show . getNodeId
146+
147+showSubscriberType :: Subscriber x a -> String
148+showSubscriberType = \case
149+ SubscriberPush _ _ -> "SubscriberPush"
150+ SubscriberMerge _ _ -> "SubscriberMerge"
151+ SubscriberFan _ -> "SubscriberFan"
152+ SubscriberMergeChange _ -> "SubscriberMergeChange"
153+ SubscriberHold _ -> "SubscriberHold"
154+ SubscriberHoldIdentity _ -> "SubscriberHoldIdentity"
155+ SubscriberSwitch _ -> "SubscriberSwitch"
156+ SubscriberCoincidenceOuter _ -> "SubscriberCoincidenceOuter"
157+ SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"
158+ SubscriberHandle -> "SubscriberHandle"
159+
160+showEventType :: Event x a -> String
161+showEventType = \case
162+ EventRoot _ _ -> "EventRoot"
163+ EventNever -> "EventNever"
164+ EventPush _ -> "EventPush"
165+ EventMerge _ -> "EventMerge"
166+ EventFan _ _ -> "EventFan"
167+ EventSwitch _ -> "EventSwitch"
168+ EventCoincidence _ -> "EventCoincidence"
169+ EventHold _ -> "EventHold"
170+ EventDyn _ -> "EventDyn"
171+ EventHoldIdentity _ -> "EventHoldIdentity"
172+ EventDynIdentity _ -> "EventDynIdentity"
173+
174+#else
175+
176+debugPropagate = False
177+
178+debugInvalidateHeight = False
179+
180+debugInvalidate = False
181+
182+-- This must be inline, or error messages will cause memory leaks due to retaining the node in question
183+{-# INLINE showNodeId #-}
184+showNodeId :: a -> String
185+showNodeId _ = ""
186+
187+#endif
188+
189+#ifdef DEBUG_NODEIDS
190+{-# NOINLINE nextNodeIdRef #-}
191+nextNodeIdRef :: IORef Int
192+nextNodeIdRef = unsafePerformIO $ newIORef 1
193+
194+newNodeId :: IO Int
195+newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
196+
197+{-# NOINLINE unsafeNodeId #-}
198+unsafeNodeId :: a -> Int
199+unsafeNodeId a = unsafePerformIO $ do
200+ touch a
201+ newNodeId
202+#endif
203+
204+--------------------------------------------------------------------------------
205+-- EventSubscription
206+--------------------------------------------------------------------------------
207+
208+--NB: Once you subscribe to an Event, you must always hold on the the WHOLE EventSubscription you get back
209+-- If you do not retain the subscription, you may be prematurely unsubscribed from the parent event.
210+data EventSubscription x = EventSubscription
211+ { _eventSubscription_unsubscribe :: !(IO ())
212+ , _eventSubscription_subscribed :: {-# UNPACK #-} !(EventSubscribed x)
213+ }
214+
215+unsubscribe :: EventSubscription x -> IO ()
216+unsubscribe (EventSubscription u _) = u
217+
218+--------------------------------------------------------------------------------
219+-- Event
220+--------------------------------------------------------------------------------
221+
222+newtype Event x a = Event { unEvent :: Subscriber x a -> EventM x (EventSubscription x, Maybe a) }
223+
224+{-# INLINE subscribeAndRead #-}
225+subscribeAndRead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)
226+subscribeAndRead = unEvent
227+
228+{-# RULES
229+"cacheEvent/cacheEvent" forall e. cacheEvent (cacheEvent e) = cacheEvent e
230+"cacheEvent/pushCheap" forall f e. pushCheap f (cacheEvent e) = cacheEvent (pushCheap f e)
231+"hold/cacheEvent" forall f e. hold f (cacheEvent e) = hold f e
232+ #-}
233+
234+-- | Construct an 'Event' equivalent to that constructed by 'push', but with no
235+-- caching; if the computation function is very cheap, this is (much) more
236+-- efficient than 'push'
237+{-# INLINE [1] pushCheap #-}
238+pushCheap :: (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
239+pushCheap !f e = Event $ \sub -> do
240+ (subscription, occ) <- subscribeAndRead e $ sub
241+ { subscriberPropagate = \a -> do
242+ mb <- f a
243+ mapM_ (subscriberPropagate sub) mb
244+ }
245+ occ' <- join <$> mapM f occ
246+ return (subscription, occ')
247+
248+-- | A subscriber that never triggers other 'Event's
249+{-# INLINE terminalSubscriber #-}
250+terminalSubscriber :: (a -> EventM x ()) -> Subscriber x a
251+terminalSubscriber p = Subscriber
252+ { subscriberPropagate = p
253+ , subscriberInvalidateHeight = \_ -> return ()
254+ , subscriberRecalculateHeight = \_ -> return ()
255+ }
256+
257+-- | Subscribe to an Event only for the duration of one occurrence
258+{-# INLINE subscribeAndReadHead #-}
259+subscribeAndReadHead :: Event x a -> Subscriber x a -> EventM x (EventSubscription x, Maybe a)
260+subscribeAndReadHead e sub = do
261+ subscriptionRef <- liftIO $ newIORef $ error "subscribeAndReadHead: not initialized"
262+ (subscription, occ) <- subscribeAndRead e $ sub
263+ { subscriberPropagate = \a -> do
264+ liftIO $ unsubscribe =<< readIORef subscriptionRef
265+ subscriberPropagate sub a
266+ }
267+ liftIO $ case occ of
268+ Nothing -> writeIORef subscriptionRef $! subscription
269+ Just _ -> unsubscribe subscription
270+ return (subscription, occ)
271+
272+--TODO: Make this lazy in its input event
273+headE :: (MonadIO m, Defer (SomeMergeInit x) m) => Event x a -> m (Event x a)
274+headE originalE = do
275+ parent <- liftIO $ newIORef $ Just originalE
276+ defer $ SomeMergeInit $ do --TODO: Rename SomeMergeInit appropriately
277+ let clearParent = liftIO $ writeIORef parent Nothing
278+ (_, occ) <- subscribeAndReadHead originalE $ terminalSubscriber $ \_ -> clearParent
279+ when (isJust occ) clearParent
280+ return $ Event $ \sub -> do
281+ liftIO (readIORef parent) >>= \case
282+ Nothing -> return (EventSubscription (return ()) $ EventSubscribed zeroRef $ toAny (), Nothing)
283+ Just e -> subscribeAndReadHead e sub
284+
285+data CacheSubscribed x a
286+ = CacheSubscribed { _cacheSubscribed_subscribers :: {-# UNPACK #-} !(FastWeakBag (Subscriber x a))
287+ , _cacheSubscribed_parent :: {-# UNPACK #-} !(EventSubscription x)
288+ , _cacheSubscribed_occurrence :: {-# UNPACK #-} !(IORef (Maybe a))
289+ }
290+
291+-- | Construct an 'Event' whose value is guaranteed not to be recomputed
292+-- repeatedly
293+--
294+--TODO: Try a caching strategy where we subscribe directly to the parent when
295+--there's only one subscriber, and then build our own FastWeakBag only when a second
296+--subscriber joins
297+{-# NOINLINE [0] cacheEvent #-}
298+cacheEvent :: forall x a. HasSpiderTimeline x => Event x a -> Event x a
299+cacheEvent e =
300+#ifdef DEBUG_TRACE_EVENTS
301+ withStackOneLine $ \callSite -> Event $
302+#else
303+ Event $
304+#endif
305+ let mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))
306+ !mSubscribedRef = unsafeNewIORef e emptyFastWeak
307+ in \sub -> {-# SCC "cacheEvent" #-} do
308+#ifdef DEBUG_TRACE_EVENTS
309+ unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite
310+#endif
311+ subscribedTicket <- liftIO (readIORef mSubscribedRef >>= getFastWeakTicket) >>= \case
312+ Just subscribedTicket -> return subscribedTicket
313+ Nothing -> do
314+ subscribers <- liftIO FastWeakBag.empty
315+ occRef <- liftIO $ newIORef Nothing -- This should never be read prior to being set below
316+ (parentSub, occ) <- subscribeAndRead e $ Subscriber
317+ { subscriberPropagate = \a -> do
318+ liftIO $ writeIORef occRef $ Just a
319+ scheduleClear occRef
320+ propagateFast a subscribers
321+ , subscriberInvalidateHeight = \old -> do
322+ FastWeakBag.traverse subscribers $ invalidateSubscriberHeight old
323+ , subscriberRecalculateHeight = \new -> do
324+ FastWeakBag.traverse subscribers $ recalculateSubscriberHeight new
325+ }
326+ when (isJust occ) $ do
327+ liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing
328+ scheduleClear occRef
329+ let !subscribed = CacheSubscribed
330+ { _cacheSubscribed_subscribers = subscribers
331+ , _cacheSubscribed_parent = parentSub
332+ , _cacheSubscribed_occurrence = occRef
333+ }
334+ subscribedTicket <- liftIO $ mkFastWeakTicket subscribed
335+ liftIO $ writeIORef mSubscribedRef =<< getFastWeakTicketWeak subscribedTicket
336+ return subscribedTicket
337+ liftIO $ do
338+ subscribed <- getFastWeakTicketValue subscribedTicket
339+ ticket <- FastWeakBag.insert sub $ _cacheSubscribed_subscribers subscribed
340+ occ <- readIORef $ _cacheSubscribed_occurrence subscribed
341+ let es = EventSubscription
342+ { _eventSubscription_unsubscribe = do
343+ FastWeakBag.remove ticket
344+ isEmpty <- FastWeakBag.isEmpty $ _cacheSubscribed_subscribers subscribed
345+ when isEmpty $ do
346+ writeIORef mSubscribedRef emptyFastWeak
347+ unsubscribe $ _cacheSubscribed_parent subscribed
348+ touch ticket
349+ touch subscribedTicket
350+ , _eventSubscription_subscribed = EventSubscribed
351+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed
352+ , eventSubscribedRetained = toAny subscribedTicket
353+ }
354+ }
355+ return (es, occ)
356+
357+subscribe :: Event x a -> Subscriber x a -> EventM x (EventSubscription x)
358+subscribe e s = fst <$> subscribeAndRead e s
359+
360+{-# INLINE wrap #-}
361+wrap :: MonadIO m => (t -> EventSubscribed x) -> (Subscriber x a -> m (WeakBagTicket, t, Maybe a)) -> Subscriber x a -> m (EventSubscription x, Maybe a)
362+wrap tag getSpecificSubscribed sub = do
363+ (sln, subd, occ) <- getSpecificSubscribed sub
364+ let es = tag subd
365+ return (EventSubscription (WeakBag.remove sln >> touch sln) es, occ)
366+
367+eventRoot :: GCompare k => k a -> Root x k -> Event x a
368+eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed k r
369+
370+eventNever :: Event x a
371+eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
372+
373+eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k -> Event x a
374+eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
375+
376+eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a
377+eventSwitch !s = Event $ wrap eventSubscribedSwitch $ getSwitchSubscribed s
378+
379+eventCoincidence :: HasSpiderTimeline x => Coincidence x a -> Event x a
380+eventCoincidence !c = Event $ wrap eventSubscribedCoincidence $ getCoincidenceSubscribed c
381+
382+eventHold :: Hold x p -> Event x p
383+eventHold !h = Event $ subscribeHoldEvent h
384+
385+eventDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Event x p
386+eventDyn !j = Event $ \sub -> getDynHold j >>= \h -> subscribeHoldEvent h sub
387+
388+{-# INLINE subscribeCoincidenceInner #-}
389+subscribeCoincidenceInner :: HasSpiderTimeline x => Event x a -> Height -> CoincidenceSubscribed x a -> EventM x (Maybe a, Height, EventSubscribed x)
390+subscribeCoincidenceInner inner outerHeight subscribedUnsafe = do
391+ subInner <- liftIO $ newSubscriberCoincidenceInner subscribedUnsafe
392+ (subscription@(EventSubscription _ innerSubd), innerOcc) <- subscribeAndRead inner subInner
393+ innerHeight <- liftIO $ getEventSubscribedHeight innerSubd
394+ let height = max innerHeight outerHeight
395+ defer $ SomeResetCoincidence subscription $ if height > outerHeight then Just subscribedUnsafe else Nothing
396+ return (innerOcc, height, innerSubd)
397+
398+--------------------------------------------------------------------------------
399+-- Subscriber
400+--------------------------------------------------------------------------------
401+
402+data Subscriber x a = Subscriber
403+ { subscriberPropagate :: !(a -> EventM x ())
404+ , subscriberInvalidateHeight :: !(Height -> IO ())
405+ , subscriberRecalculateHeight :: !(Height -> IO ())
406+ }
407+
408+--TODO: Move this comment to WeakBag
409+-- These function are constructor functions that are marked NOINLINE so they are
410+-- opaque to GHC. If we do not do this, then GHC will sometimes fuse the constructor away
411+-- so any weak references that are attached to the constructors will have their
412+-- finalizer run. Using the opaque constructor, does not see the
413+-- constructor application, so it behaves like an IORef and cannot be fused away.
414+--
415+-- The result is also evaluated to WHNF, since forcing a thunk invalidates
416+-- the weak pointer to it in some cases.
417+
418+newSubscriberHold :: (HasSpiderTimeline x, Patch p) => Hold x p -> IO (Subscriber x p)
419+newSubscriberHold h = return $ Subscriber
420+ { subscriberPropagate = {-# SCC "traverseHold" #-} propagateSubscriberHold h
421+ , subscriberInvalidateHeight = \_ -> return ()
422+ , subscriberRecalculateHeight = \_ -> return ()
423+ }
424+
425+newSubscriberFan :: forall x k. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k -> IO (Subscriber x (DMap k Identity))
426+newSubscriberFan subscribed = return $ Subscriber
427+ { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
428+ subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
429+ tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
430+ liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
431+ scheduleClear $ fanSubscribedOccurrence subscribed
432+ let f _ (Pair (Identity v) subsubs) = do
433+ propagate v $ _fanSubscribedChildren_list subsubs
434+ return $ Constant ()
435+ _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
436+ return ()
437+ , subscriberInvalidateHeight = \old -> do
438+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
439+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
440+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old
441+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
442+ , subscriberRecalculateHeight = \new -> do
443+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
444+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
445+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new
446+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
447+ }
448+
449+newSubscriberSwitch :: forall x a. HasSpiderTimeline x => SwitchSubscribed x a -> IO (Subscriber x a)
450+newSubscriberSwitch subscribed = return $ Subscriber
451+ { subscriberPropagate = \a -> {-# SCC "traverseSwitch" #-} do
452+ tracePropagate (Proxy :: Proxy x) $ "SubscriberSwitch" <> showNodeId subscribed
453+ liftIO $ writeIORef (switchSubscribedOccurrence subscribed) $ Just a
454+ scheduleClear $ switchSubscribedOccurrence subscribed
455+ propagate a $ switchSubscribedSubscribers subscribed
456+ , subscriberInvalidateHeight = \_ -> do
457+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
458+ oldHeight <- readIORef $ switchSubscribedHeight subscribed
459+ when (oldHeight /= invalidHeight) $ do
460+ writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
461+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
462+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
463+ , subscriberRecalculateHeight = \new -> do
464+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
465+ updateSwitchHeight new subscribed
466+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
467+ }
468+
469+newSubscriberCoincidenceOuter :: forall x b. HasSpiderTimeline x => CoincidenceSubscribed x b -> IO (Subscriber x (Event x b))
470+newSubscriberCoincidenceOuter subscribed = return $ Subscriber
471+ { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceOuter" #-} do
472+ tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceOuter" <> showNodeId subscribed
473+ outerHeight <- liftIO $ readIORef $ coincidenceSubscribedHeight subscribed
474+ tracePropagate (Proxy :: Proxy x) $ " outerHeight = " <> show outerHeight
475+ (occ, innerHeight, innerSubd) <- subscribeCoincidenceInner a outerHeight subscribed
476+ tracePropagate (Proxy :: Proxy x) $ " isJust occ = " <> show (isJust occ)
477+ tracePropagate (Proxy :: Proxy x) $ " innerHeight = " <> show innerHeight
478+ liftIO $ writeIORef (coincidenceSubscribedInnerParent subscribed) $ Just innerSubd
479+ scheduleClear $ coincidenceSubscribedInnerParent subscribed
480+ case occ of
481+ Nothing -> do
482+ when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
483+ writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight
484+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight
485+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight
486+ Just o -> do -- Since it's already firing, no need to adjust height
487+ liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
488+ scheduleClear $ coincidenceSubscribedOccurrence subscribed
489+ propagate o $ coincidenceSubscribedSubscribers subscribed
490+ , subscriberInvalidateHeight = \_ -> do
491+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
492+ invalidateCoincidenceHeight subscribed
493+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
494+ , subscriberRecalculateHeight = \_ -> do
495+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed
496+ recalculateCoincidenceHeight subscribed
497+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceOuter" <> showNodeId subscribed <> " done"
498+ }
499+
500+newSubscriberCoincidenceInner :: forall x a. HasSpiderTimeline x => CoincidenceSubscribed x a -> IO (Subscriber x a)
501+newSubscriberCoincidenceInner subscribed = return $ Subscriber
502+ { subscriberPropagate = \a -> {-# SCC "traverseCoincidenceInner" #-} do
503+ tracePropagate (Proxy :: Proxy x) $ "SubscriberCoincidenceInner" <> showNodeId subscribed
504+ occ <- liftIO $ readIORef $ coincidenceSubscribedOccurrence subscribed
505+ case occ of
506+ Just _ -> return () -- SubscriberCoincidenceOuter must have already propagated this event
507+ Nothing -> do
508+ liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) $ Just a
509+ scheduleClear $ coincidenceSubscribedOccurrence subscribed
510+ propagate a $ coincidenceSubscribedSubscribers subscribed
511+ , subscriberInvalidateHeight = \_ -> do
512+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
513+ invalidateCoincidenceHeight subscribed
514+ when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
515+ , subscriberRecalculateHeight = \_ -> do
516+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed
517+ recalculateCoincidenceHeight subscribed
518+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberCoincidenceInner" <> showNodeId subscribed <> " done"
519+ }
520+
521+invalidateSubscriberHeight :: Height -> Subscriber x a -> IO ()
522+invalidateSubscriberHeight = flip subscriberInvalidateHeight
523+
524+recalculateSubscriberHeight :: Height -> Subscriber x a -> IO ()
525+recalculateSubscriberHeight = flip subscriberRecalculateHeight
526+
527+-- | Propagate everything at the current height
528+propagate :: a -> WeakBag (Subscriber x a) -> EventM x ()
529+propagate a subscribers = withIncreasedDepth $ do
530+ -- 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
531+ --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
532+ WeakBag.traverse subscribers $ \s -> subscriberPropagate s a
533+
534+-- | Propagate everything at the current height
535+propagateFast :: a -> FastWeakBag (Subscriber x a) -> EventM x ()
536+propagateFast a subscribers = withIncreasedDepth $ do
537+ -- 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
538+ --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
539+ FastWeakBag.traverse subscribers $ \s -> subscriberPropagate s a
540+
541+--------------------------------------------------------------------------------
542+-- EventSubscribed
543+--------------------------------------------------------------------------------
544+
545+toAny :: a -> Any
546+toAny = unsafeCoerce
547+
548+data EventSubscribed x = EventSubscribed
549+ { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
550+ , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
551+#ifdef DEBUG_CYCLES
552+ , eventSubscribedGetParents :: !(IO [Some (EventSubscribed x)]) -- For debugging loops
553+ , eventSubscribedHasOwnHeightRef :: !Bool
554+ , eventSubscribedWhoCreated :: !(IO [String])
555+#endif
556+ }
557+
558+eventSubscribedRoot :: RootSubscribed x a -> EventSubscribed x
559+eventSubscribedRoot !r = EventSubscribed
560+ { eventSubscribedHeightRef = zeroRef
561+ , eventSubscribedRetained = toAny r
562+#ifdef DEBUG_CYCLES
563+ , eventSubscribedGetParents = return []
564+ , eventSubscribedHasOwnHeightRef = False
565+ , eventSubscribedWhoCreated = return ["root"]
566+#endif
567+ }
568+
569+eventSubscribedNever :: EventSubscribed x
570+eventSubscribedNever = EventSubscribed
571+ { eventSubscribedHeightRef = zeroRef
572+ , eventSubscribedRetained = toAny ()
573+#ifdef DEBUG_CYCLES
574+ , eventSubscribedGetParents = return []
575+ , eventSubscribedHasOwnHeightRef = False
576+ , eventSubscribedWhoCreated = return ["never"]
577+#endif
578+ }
579+
580+eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x
581+eventSubscribedFan !subscribed = EventSubscribed
582+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
583+ , eventSubscribedRetained = toAny subscribed
584+#ifdef DEBUG_CYCLES
585+ , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
586+ , eventSubscribedHasOwnHeightRef = False
587+ , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
588+#endif
589+ }
590+
591+eventSubscribedSwitch :: SwitchSubscribed x a -> EventSubscribed x
592+eventSubscribedSwitch !subscribed = EventSubscribed
593+ { eventSubscribedHeightRef = switchSubscribedHeight subscribed
594+ , eventSubscribedRetained = toAny subscribed
595+#ifdef DEBUG_CYCLES
596+ , eventSubscribedGetParents = do
597+ s <- readIORef $ switchSubscribedCurrentParent subscribed
598+ return [Some.This $ _eventSubscription_subscribed s]
599+ , eventSubscribedHasOwnHeightRef = True
600+ , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
601+#endif
602+ }
603+
604+eventSubscribedCoincidence :: CoincidenceSubscribed x a -> EventSubscribed x
605+eventSubscribedCoincidence !subscribed = EventSubscribed
606+ { eventSubscribedHeightRef = coincidenceSubscribedHeight subscribed
607+ , eventSubscribedRetained = toAny subscribed
608+#ifdef DEBUG_CYCLES
609+ , eventSubscribedGetParents = do
610+ innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
611+ let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
612+ innerParents = maybeToList $ fmap Some.This innerSubscription
613+ return $ outerParent : innerParents
614+ , eventSubscribedHasOwnHeightRef = True
615+ , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
616+#endif
617+ }
618+
619+getEventSubscribedHeight :: EventSubscribed x -> IO Height
620+getEventSubscribedHeight es = readIORef $ eventSubscribedHeightRef es
621+
622+#ifdef DEBUG_CYCLES
623+whoCreatedEventSubscribed :: EventSubscribed x -> IO [String]
624+whoCreatedEventSubscribed = eventSubscribedWhoCreated
625+
626+walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)]
627+walkInvalidHeightParents s0 = do
628+ subscribers <- flip execStateT mempty $ ($ Some.This s0) $ fix $ \loop (Some.This s) -> do
629+ h <- liftIO $ readIORef $ eventSubscribedHeightRef s
630+ when (h == invalidHeight) $ do
631+ when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed
632+ modify (Some.This s :)
633+ mapM_ loop =<< liftIO (eventSubscribedGetParents s)
634+ forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
635+ return subscribers
636+#endif
637+
638+{-# INLINE subscribeHoldEvent #-}
639+subscribeHoldEvent :: Hold x p -> Subscriber x p -> EventM x (EventSubscription x, Maybe p)
640+subscribeHoldEvent = subscribeAndRead . holdEvent
641+
642+--------------------------------------------------------------------------------
643+-- Behavior
644+--------------------------------------------------------------------------------
645+
646+newtype Behavior x a = Behavior { readBehaviorTracked :: BehaviorM x a }
647+
648+behaviorHold :: Hold x p -> Behavior x (PatchTarget p)
649+behaviorHold !h = Behavior $ readHoldTracked h
650+
651+behaviorHoldIdentity :: Hold x (Identity a) -> Behavior x a
652+behaviorHoldIdentity = behaviorHold
653+
654+behaviorConst :: a -> Behavior x a
655+behaviorConst !a = Behavior $ return a
656+
657+behaviorPull :: Pull x a -> Behavior x a
658+behaviorPull !p = Behavior $ do
659+ val <- liftIO $ readIORef $ pullValue p
660+ case val of
661+ Just subscribed -> do
662+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
663+ askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))
664+ liftIO $ touch $ pullSubscribedOwnInvalidator subscribed
665+ return $ pullSubscribedValue subscribed
666+ Nothing -> do
667+ i <- liftIO $ newInvalidatorPull p
668+ wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
669+ parentsRef <- liftIO $ newIORef []
670+ holdInits <- askBehaviorHoldInits
671+ a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
672+ invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
673+ parents <- liftIO $ readIORef parentsRef
674+ let subscribed = PullSubscribed
675+ { pullSubscribedValue = a
676+ , pullSubscribedInvalidators = invsRef
677+ , pullSubscribedOwnInvalidator = i
678+ , pullSubscribedParents = parents
679+ }
680+ liftIO $ writeIORef (pullValue p) $ Just subscribed
681+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
682+ return a
683+
684+behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p)
685+behaviorDyn !d = Behavior $ readHoldTracked =<< getDynHold d
686+
687+{-# INLINE readHoldTracked #-}
688+readHoldTracked :: Hold x p -> BehaviorM x (PatchTarget p)
689+readHoldTracked h = do
690+ result <- liftIO $ readIORef $ holdValue h
691+ askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))
692+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))
693+ liftIO $ touch h -- Otherwise, if this gets inlined enough, the hold's parent reference may get collected
694+ return result
695+
696+{-# INLINABLE readBehaviorUntracked #-}
697+readBehaviorUntracked :: Defer (SomeHoldInit x) m => Behavior x a -> m a
698+readBehaviorUntracked b = do
699+ holdInits <- getDeferralQueue
700+ liftIO $ runBehaviorM (readBehaviorTracked b) Nothing holdInits --TODO: Specialize readBehaviorTracked to the Nothing and Just cases
701+
702+--------------------------------------------------------------------------------
703+-- Dynamic
704+--------------------------------------------------------------------------------
705+
706+data Dynamic x p = Dynamic
707+ { dynamicCurrent :: !(Behavior x (PatchTarget p))
708+ , dynamicUpdated :: !(Event x p)
709+ }
710+
711+dynamicHold :: Hold x p -> Dynamic x p
712+dynamicHold !h = Dynamic
713+ { dynamicCurrent = behaviorHold h
714+ , dynamicUpdated = eventHold h
715+ }
716+
717+dynamicHoldIdentity :: Hold x (Identity a) -> Dynamic x (Identity a)
718+dynamicHoldIdentity = dynamicHold
719+
720+dynamicConst :: PatchTarget p -> Dynamic x p
721+dynamicConst !a = Dynamic
722+ { dynamicCurrent = behaviorConst a
723+ , dynamicUpdated = eventNever
724+ }
725+
726+dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p
727+dynamicDyn !d = Dynamic
728+ { dynamicCurrent = behaviorDyn d
729+ , dynamicUpdated = eventDyn d
730+ }
731+
732+dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a)
733+dynamicDynIdentity = dynamicDyn
734+
735+--------------------------------------------------------------------------------
736+-- Combinators
737+--------------------------------------------------------------------------------
738+
739+--TODO: Figure out why certain things are not 'representational', then make them
740+--representational so we can use coerce
741+
742+--type role Hold representational
743+data Hold x p
744+ = Hold { holdValue :: !(IORef (PatchTarget p))
745+ , holdInvalidators :: !(IORef [Weak (Invalidator x)])
746+ , holdEvent :: Event x p -- This must be lazy, or holds cannot be defined before their input Events
747+ , holdParent :: !(IORef (Maybe (EventSubscription x))) -- Keeps its parent alive (will be undefined until the hold is initialized) --TODO: Probably shouldn't be an IORef
748+#ifdef DEBUG_NODEIDS
749+ , holdNodeId :: Int
750+#endif
751+ }
752+
753+-- | A statically allocated 'SpiderTimeline'
754+data Global
755+
756+{-# NOINLINE globalSpiderTimelineEnv #-}
757+globalSpiderTimelineEnv :: SpiderTimelineEnv Global
758+globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv
759+
760+-- | Stores all global data relevant to a particular Spider timeline; only one
761+-- value should exist for each type @x@
762+data SpiderTimelineEnv x = SpiderTimelineEnv
763+ { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
764+ , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
765+#ifdef DEBUG
766+ , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
767+#endif
768+ }
769+type role SpiderTimelineEnv nominal
770+
771+instance Eq (SpiderTimelineEnv x) where
772+ _ == _ = True -- Since only one exists of each type
773+
774+instance GEq SpiderTimelineEnv where
775+ a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b
776+ then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
777+ else Nothing
778+
779+data EventEnv x
780+ = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe
781+ , eventEnvHoldInits :: !(IORef [SomeHoldInit x]) -- Needed for Subscribe
782+ , eventEnvDynInits :: !(IORef [SomeDynInit x])
783+ , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x])
784+ , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe
785+ , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe
786+ , eventEnvIntClears :: !(IORef [SomeIntClear])
787+ , eventEnvRootClears :: !(IORef [SomeRootClear])
788+ , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe
789+ , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe
790+ , eventEnvDelayedMerges :: !(IORef (IntMap [EventM x ()]))
791+ }
792+
793+{-# INLINE runEventM #-}
794+runEventM :: EventM x a -> IO a
795+runEventM = unEventM
796+
797+asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a
798+asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
799+
800+class MonadIO m => Defer a m where
801+ getDeferralQueue :: m (IORef [a])
802+
803+{-# INLINE defer #-}
804+defer :: Defer a m => a -> m ()
805+defer a = do
806+ q <- getDeferralQueue
807+ liftIO $ modifyIORef' q (a:)
808+
809+instance HasSpiderTimeline x => Defer (SomeAssignment x) (EventM x) where
810+ {-# INLINE getDeferralQueue #-}
811+ getDeferralQueue = asksEventEnv eventEnvAssignments
812+
813+instance HasSpiderTimeline x => Defer (SomeHoldInit x) (EventM x) where
814+ {-# INLINE getDeferralQueue #-}
815+ getDeferralQueue = asksEventEnv eventEnvHoldInits
816+
817+instance HasSpiderTimeline x => Defer (SomeDynInit x) (EventM x) where
818+ {-# INLINE getDeferralQueue #-}
819+ getDeferralQueue = asksEventEnv eventEnvDynInits
820+
821+instance Defer (SomeHoldInit x) (BehaviorM x) where
822+ {-# INLINE getDeferralQueue #-}
823+ getDeferralQueue = BehaviorM $ asks snd
824+
825+instance HasSpiderTimeline x => Defer (SomeMergeUpdate x) (EventM x) where
826+ {-# INLINE getDeferralQueue #-}
827+ getDeferralQueue = asksEventEnv eventEnvMergeUpdates
828+
829+instance HasSpiderTimeline x => Defer (SomeMergeInit x) (EventM x) where
830+ {-# INLINE getDeferralQueue #-}
831+ getDeferralQueue = asksEventEnv eventEnvMergeInits
832+
833+class HasSpiderTimeline x => HasCurrentHeight x m | m -> x where
834+ getCurrentHeight :: m Height
835+ scheduleMerge :: Height -> EventM x () -> m ()
836+
837+instance HasSpiderTimeline x => HasCurrentHeight x (EventM x) where
838+ {-# INLINE getCurrentHeight #-}
839+ getCurrentHeight = do
840+ heightRef <- asksEventEnv eventEnvCurrentHeight
841+ liftIO $ readIORef heightRef
842+ {-# INLINE scheduleMerge #-}
843+ scheduleMerge height subscribed = do
844+ delayedRef <- asksEventEnv eventEnvDelayedMerges
845+ liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [subscribed]
846+
847+class HasSpiderTimeline x where
848+ -- | Retrieve the current SpiderTimelineEnv
849+ spiderTimeline :: SpiderTimelineEnv x
850+
851+instance HasSpiderTimeline Global where
852+ spiderTimeline = globalSpiderTimelineEnv
853+
854+putCurrentHeight :: HasSpiderTimeline x => Height -> EventM x ()
855+putCurrentHeight h = do
856+ heightRef <- asksEventEnv eventEnvCurrentHeight
857+ liftIO $ writeIORef heightRef $! h
858+
859+instance HasSpiderTimeline x => Defer SomeClear (EventM x) where
860+ {-# INLINE getDeferralQueue #-}
861+ getDeferralQueue = asksEventEnv eventEnvClears
862+
863+{-# INLINE scheduleClear #-}
864+scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m ()
865+scheduleClear r = defer $ SomeClear r
866+
867+instance HasSpiderTimeline x => Defer SomeIntClear (EventM x) where
868+ {-# INLINE getDeferralQueue #-}
869+ getDeferralQueue = asksEventEnv eventEnvIntClears
870+
871+{-# INLINE scheduleIntClear #-}
872+scheduleIntClear :: Defer SomeIntClear m => IORef (IntMap a) -> m ()
873+scheduleIntClear r = defer $ SomeIntClear r
874+
875+instance HasSpiderTimeline x => Defer SomeRootClear (EventM x) where
876+ {-# INLINE getDeferralQueue #-}
877+ getDeferralQueue = asksEventEnv eventEnvRootClears
878+
879+{-# INLINE scheduleRootClear #-}
880+scheduleRootClear :: Defer SomeRootClear m => IORef (DMap k Identity) -> m ()
881+scheduleRootClear r = defer $ SomeRootClear r
882+
883+instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where
884+ {-# INLINE getDeferralQueue #-}
885+ getDeferralQueue = asksEventEnv eventEnvResetCoincidences
886+
887+-- Note: hold cannot examine its event until after the phase is over
888+{-# INLINE [1] hold #-}
889+hold :: (Patch p, Defer (SomeHoldInit x) m) => PatchTarget p -> Event x p -> m (Hold x p)
890+hold v0 e = do
891+ valRef <- liftIO $ newIORef v0
892+ invsRef <- liftIO $ newIORef []
893+ parentRef <- liftIO $ newIORef Nothing
894+#ifdef DEBUG_NODEIDS
895+ nodeId <- liftIO newNodeId
896+#endif
897+ let h = Hold
898+ { holdValue = valRef
899+ , holdInvalidators = invsRef
900+ , holdEvent = e
901+ , holdParent = parentRef
902+#ifdef DEBUG_NODEIDS
903+ , holdNodeId = nodeId
904+#endif
905+ }
906+ defer $ SomeHoldInit h
907+ return h
908+
909+{-# INLINE getHoldEventSubscription #-}
910+getHoldEventSubscription :: forall p x. (HasSpiderTimeline x, Patch p) => Hold x p -> EventM x (EventSubscription x)
911+getHoldEventSubscription h = do
912+ ep <- liftIO $ readIORef $ holdParent h
913+ case ep of
914+ Just subd -> return subd
915+ Nothing -> do
916+ let e = holdEvent h
917+ subscriptionRef <- liftIO $ newIORef $ error "getHoldEventSubscription: subdRef uninitialized"
918+ (subscription@(EventSubscription _ _), occ) <- subscribeAndRead e =<< liftIO (newSubscriberHold h)
919+ liftIO $ writeIORef subscriptionRef $! subscription
920+ case occ of
921+ Nothing -> return ()
922+ Just o -> do
923+ old <- liftIO $ readIORef $ holdValue h
924+ case apply o old of
925+ Nothing -> return ()
926+ Just new -> do
927+ -- Need to evaluate these so that we don't retain the Hold itself
928+ v <- liftIO $ evaluate $ holdValue h
929+ i <- liftIO $ evaluate $ holdInvalidators h
930+ defer $ SomeAssignment v i new
931+ liftIO $ writeIORef (holdParent h) $ Just subscription
932+ return subscription
933+
934+type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
935+
936+--type role BehaviorM representational
937+-- BehaviorM can sample behaviors
938+newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderT (BehaviorEnv x) IO a } deriving (Functor, Applicative, MonadIO, MonadFix)
939+
940+instance Monad (BehaviorM x) where
941+ {-# INLINE (>>=) #-}
942+ BehaviorM x >>= f = BehaviorM $ x >>= unBehaviorM . f
943+ {-# INLINE (>>) #-}
944+ BehaviorM x >> BehaviorM y = BehaviorM $ x >> y
945+ {-# INLINE return #-}
946+ return x = BehaviorM $ return x
947+ {-# INLINE fail #-}
948+ fail s = BehaviorM $ fail s
949+
950+data BehaviorSubscribed x a
951+ = forall p. BehaviorSubscribedHold (Hold x p)
952+ | BehaviorSubscribedPull (PullSubscribed x a)
953+
954+data SomeBehaviorSubscribed x = forall a. SomeBehaviorSubscribed (BehaviorSubscribed x a)
955+
956+--type role PullSubscribed representational
957+data PullSubscribed x a
958+ = PullSubscribed { pullSubscribedValue :: !a
959+ , pullSubscribedInvalidators :: !(IORef [Weak (Invalidator x)])
960+ , pullSubscribedOwnInvalidator :: !(Invalidator x)
961+ , pullSubscribedParents :: ![SomeBehaviorSubscribed x] -- Need to keep parent behaviors alive, or they won't let us know when they're invalidated
962+ }
963+
964+--type role Pull representational
965+data Pull x a
966+ = Pull { pullValue :: !(IORef (Maybe (PullSubscribed x a)))
967+ , pullCompute :: !(BehaviorM x a)
968+#ifdef DEBUG_NODEIDS
969+ , pullNodeId :: Int
970+#endif
971+ }
972+
973+data Invalidator x
974+ = forall a. InvalidatorPull (Pull x a)
975+ | forall a. InvalidatorSwitch (SwitchSubscribed x a)
976+
977+data RootSubscribed x a = forall k. GCompare k => RootSubscribed
978+ { rootSubscribedKey :: !(k a)
979+ , rootSubscribedCachedSubscribed :: !(IORef (DMap k (RootSubscribed x))) -- From the original Root
980+ , rootSubscribedSubscribers :: !(WeakBag (Subscriber x a))
981+ , rootSubscribedOccurrence :: !(IO (Maybe a)) -- Lookup from rootOccurrence
982+ , rootSubscribedUninit :: IO ()
983+ , 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?
984+#ifdef DEBUG_NODEIDS
985+ , rootSubscribedNodeId :: Int
986+#endif
987+ }
988+
989+data Root x (k :: * -> *)
990+ = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
991+ , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))
992+ , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))
993+ }
994+
995+data SomeHoldInit x = forall p. Patch p => SomeHoldInit !(Hold x p)
996+
997+data SomeDynInit x = forall p. Patch p => SomeDynInit !(Dyn x p)
998+
999+data SomeMergeUpdate x = SomeMergeUpdate
1000+ { _someMergeUpdate_update :: !(EventM x [EventSubscription x])
1001+ , _someMergeUpdate_invalidateHeight :: !(IO ())
1002+ , _someMergeUpdate_recalculateHeight :: !(IO ())
1003+ }
1004+
1005+newtype SomeMergeInit x = SomeMergeInit { unSomeMergeInit :: EventM x () }
1006+
1007+-- EventM can do everything BehaviorM can, plus create holds
1008+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
1009+
1010+newtype MergeSubscribedParent x a = MergeSubscribedParent { unMergeSubscribedParent :: EventSubscription x }
1011+
1012+data MergeSubscribedParentWithMove x k a = MergeSubscribedParentWithMove
1013+ { _mergeSubscribedParentWithMove_subscription :: !(EventSubscription x)
1014+ , _mergeSubscribedParentWithMove_key :: !(IORef (k a))
1015+ }
1016+
1017+data HeightBag = HeightBag
1018+ { _heightBag_size :: {-# UNPACK #-} !Int
1019+ , _heightBag_contents :: !(IntMap Word) -- Number of excess in each bucket
1020+ }
1021+ deriving (Show, Read, Eq, Ord)
1022+
1023+heightBagEmpty :: HeightBag
1024+heightBagEmpty = heightBagVerify $ HeightBag 0 IntMap.empty
1025+
1026+heightBagSize :: HeightBag -> Int
1027+heightBagSize = _heightBag_size
1028+
1029+heightBagFromList :: [Height] -> HeightBag
1030+heightBagFromList heights = heightBagVerify $ foldl' (flip heightBagAdd) heightBagEmpty heights
1031+
1032+heightBagAdd :: Height -> HeightBag -> HeightBag
1033+heightBagAdd (Height h) (HeightBag s c) = heightBagVerify $ HeightBag (succ s) $ IntMap.insertWithKey (\_ _ old -> succ old) h 0 c
1034+
1035+heightBagRemove :: Height -> HeightBag -> HeightBag
1036+heightBagRemove (Height h) b@(HeightBag s c) = heightBagVerify $ case IntMap.lookup h c of
1037+ Nothing -> error $ "heightBagRemove: Height " <> show h <> " not present in bag " <> show b
1038+ Just old -> HeightBag (pred s) $ case old of
1039+ 0 -> IntMap.delete h c
1040+ _ -> IntMap.insert h (pred old) c
1041+
1042+heightBagMax :: HeightBag -> Height
1043+heightBagMax (HeightBag _ c) = case IntMap.maxViewWithKey c of
1044+ Just ((h, _), _) -> Height h
1045+ Nothing -> zeroHeight
1046+
1047+heightBagVerify :: HeightBag -> HeightBag
1048+#ifdef DEBUG
1049+heightBagVerify b@(HeightBag s c) = if
1050+ | s /= IntMap.size c + fromIntegral (sum (IntMap.elems c))
1051+ -> error $ "heightBagVerify: size doesn't match: " <> show b
1052+ | unHeight invalidHeight `IntMap.member` c
1053+ -> error $ "heightBagVerify: contains invalid height: " <> show b
1054+ | otherwise -> b
1055+#else
1056+heightBagVerify = id
1057+#endif
1058+
1059+data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren
1060+ { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a))
1061+ , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k)
1062+ , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k)))
1063+ }
1064+
1065+data FanSubscribed (x :: *) k
1066+ = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1067+ , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
1068+ , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty
1069+ , fanSubscribedParent :: !(EventSubscription x)
1070+#ifdef DEBUG_NODEIDS
1071+ , fanSubscribedNodeId :: Int
1072+#endif
1073+ }
1074+
1075+data Fan x k
1076+ = Fan { fanParent :: !(Event x (DMap k Identity))
1077+ , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1078+ }
1079+
1080+data SwitchSubscribed x a
1081+ = SwitchSubscribed { switchSubscribedCachedSubscribed :: !(IORef (Maybe (SwitchSubscribed x a)))
1082+ , switchSubscribedOccurrence :: !(IORef (Maybe a))
1083+ , switchSubscribedHeight :: !(IORef Height)
1084+ , switchSubscribedSubscribers :: !(WeakBag (Subscriber x a))
1085+ , switchSubscribedOwnInvalidator :: {-# NOUNPACK #-} !(Invalidator x)
1086+ , switchSubscribedOwnWeakInvalidator :: !(IORef (Weak (Invalidator x)))
1087+ , switchSubscribedBehaviorParents :: !(IORef [SomeBehaviorSubscribed x])
1088+ , switchSubscribedParent :: !(Behavior x (Event x a))
1089+ , switchSubscribedCurrentParent :: !(IORef (EventSubscription x))
1090+ , switchSubscribedWeakSelf :: !(IORef (Weak (SwitchSubscribed x a)))
1091+#ifdef DEBUG_NODEIDS
1092+ , switchSubscribedNodeId :: Int
1093+#endif
1094+ }
1095+
1096+data Switch x a
1097+ = Switch { switchParent :: !(Behavior x (Event x a))
1098+ , switchSubscribed :: !(IORef (Maybe (SwitchSubscribed x a)))
1099+ }
1100+
1101+#ifdef USE_TEMPLATE_HASKELL
1102+{-# ANN CoincidenceSubscribed "HLint: ignore Redundant bracket" #-}
1103+#endif
1104+data CoincidenceSubscribed x a
1105+ = CoincidenceSubscribed { coincidenceSubscribedCachedSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a)))
1106+ , coincidenceSubscribedOccurrence :: !(IORef (Maybe a))
1107+ , coincidenceSubscribedSubscribers :: !(WeakBag (Subscriber x a))
1108+ , coincidenceSubscribedHeight :: !(IORef Height)
1109+ , coincidenceSubscribedOuter :: {-# NOUNPACK #-} (Subscriber x (Event x a))
1110+ , coincidenceSubscribedOuterParent :: !(EventSubscription x)
1111+ , coincidenceSubscribedInnerParent :: !(IORef (Maybe (EventSubscribed x)))
1112+ , coincidenceSubscribedWeakSelf :: !(IORef (Weak (CoincidenceSubscribed x a)))
1113+#ifdef DEBUG_NODEIDS
1114+ , coincidenceSubscribedNodeId :: Int
1115+#endif
1116+ }
1117+
1118+data Coincidence x a
1119+ = Coincidence { coincidenceParent :: !(Event x (Event x a))
1120+ , coincidenceSubscribed :: !(IORef (Maybe (CoincidenceSubscribed x a)))
1121+ }
1122+
1123+{-# NOINLINE newInvalidatorSwitch #-}
1124+newInvalidatorSwitch :: SwitchSubscribed x a -> IO (Invalidator x)
1125+newInvalidatorSwitch subd = return $! InvalidatorSwitch subd
1126+
1127+{-# NOINLINE newInvalidatorPull #-}
1128+newInvalidatorPull :: Pull x a -> IO (Invalidator x)
1129+newInvalidatorPull p = return $! InvalidatorPull p
1130+
1131+instance HasSpiderTimeline x => FunctorMaybe (Event x) where
1132+ fmapMaybe f = push $ return . f
1133+
1134+instance HasSpiderTimeline x => Align (Event x) where
1135+ nil = eventNever
1136+ align ea eb = fmapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
1137+
1138+newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (PatchTarget p), Event x p) (Hold x p)) }
1139+
1140+newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)
1141+newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
1142+
1143+--TODO: Avoid the duplication between this and R.zipDynWith
1144+zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c)
1145+zipDynWith f da db =
1146+ let eab = align (dynamicUpdated da) (dynamicUpdated db)
1147+ ec = flip push eab $ \o -> do
1148+ (a, b) <- case o of
1149+ This (Identity a) -> do
1150+ b <- readBehaviorUntracked $ dynamicCurrent db
1151+ return (a, b)
1152+ That (Identity b) -> do
1153+ a <- readBehaviorUntracked $ dynamicCurrent da
1154+ return (a, b)
1155+ These (Identity a) (Identity b) -> return (a, b)
1156+ return $ Just $ Identity $ f a b
1157+ in dynamicDynIdentity $ unsafeBuildDynamic (f <$> readBehaviorUntracked (dynamicCurrent da) <*> readBehaviorUntracked (dynamicCurrent db)) ec
1158+
1159+buildDynamic :: (Defer (SomeDynInit x) m, Patch p) => BehaviorM x (PatchTarget p) -> Event x p -> m (Dyn x p)
1160+buildDynamic readV0 v' = do
1161+ result <- liftIO $ newIORef $ Left (readV0, v')
1162+ let !d = Dyn result
1163+ defer $ SomeDynInit d
1164+ return d
1165+
1166+unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
1167+unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ Left x
1168+ where x = (readV0, v')
1169+
1170+-- ResultM can read behaviors and events
1171+type ResultM = EventM
1172+
1173+{-# NOINLINE unsafeNewIORef #-}
1174+unsafeNewIORef :: a -> b -> IORef b
1175+unsafeNewIORef a b = unsafePerformIO $ do
1176+ touch a
1177+ newIORef b
1178+
1179+instance HasSpiderTimeline x => Functor (Event x) where
1180+ fmap f = push $ return . Just . f
1181+
1182+instance Functor (Behavior x) where
1183+ fmap f = pull . fmap f . readBehaviorTracked
1184+
1185+{-# INLINE push #-}
1186+push :: HasSpiderTimeline x => (a -> ComputeM x (Maybe b)) -> Event x a -> Event x b
1187+push f e = cacheEvent (pushCheap f e)
1188+
1189+{-# INLINABLE pull #-}
1190+pull :: BehaviorM x a -> Behavior x a
1191+pull a = behaviorPull $ Pull
1192+ { pullCompute = a
1193+ , pullValue = unsafeNewIORef a Nothing
1194+#ifdef DEBUG_NODEIDS
1195+ , pullNodeId = unsafeNodeId a
1196+#endif
1197+ }
1198+
1199+{-# INLINABLE switch #-}
1200+switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a
1201+switch a = eventSwitch $ Switch
1202+ { switchParent = a
1203+ , switchSubscribed = unsafeNewIORef a Nothing
1204+ }
1205+
1206+coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a
1207+coincidence a = eventCoincidence $ Coincidence
1208+ { coincidenceParent = a
1209+ , coincidenceSubscribed = unsafeNewIORef a Nothing
1210+ }
1211+
1212+-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
1213+run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
1214+run roots after = do
1215+ tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
1216+ t <- SpiderHost ask
1217+ result <- SpiderHost $ lift $ withMVar (_spiderTimeline_lock t) $ \_ -> flip runReaderT t $ unSpiderHost $ runFrame $ do
1218+ rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
1219+ occBefore <- liftIO $ do
1220+ occBefore <- readIORef occRef
1221+ writeIORef occRef $! DMap.insert k a occBefore
1222+ return occBefore
1223+ if DMap.null occBefore
1224+ then do scheduleRootClear occRef
1225+ return $ Just r
1226+ else return Nothing
1227+ forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, _) :=> Identity a) -> do
1228+ propagate a subscribersRef
1229+ delayedRef <- asksEventEnv eventEnvDelayedMerges
1230+ let go = do
1231+ delayed <- liftIO $ readIORef delayedRef
1232+ case IntMap.minViewWithKey delayed of
1233+ Nothing -> return ()
1234+ Just ((currentHeight, cur), future) -> do
1235+ tracePropagate (Proxy :: Proxy x) $ "Running height " ++ show currentHeight
1236+ putCurrentHeight $ Height currentHeight
1237+ liftIO $ writeIORef delayedRef $! future
1238+ sequence_ cur
1239+ go
1240+ go
1241+ putCurrentHeight maxBound
1242+ after
1243+ tracePropagate (Proxy :: Proxy x) "Done running an event frame"
1244+ return result
1245+
1246+scheduleMerge' :: HasSpiderTimeline x => Height -> IORef Height -> EventM x () -> EventM x ()
1247+scheduleMerge' initialHeight heightRef a = scheduleMerge initialHeight $ do
1248+ height <- liftIO $ readIORef heightRef
1249+ currentHeight <- getCurrentHeight
1250+ case height `compare` currentHeight of
1251+ LT -> error "Somehow a merge's height has been decreased after it was scheduled"
1252+ GT -> scheduleMerge' height heightRef a -- The height has been increased (by a coincidence event; TODO: is this the only way?)
1253+ EQ -> a
1254+
1255+data SomeClear = forall a. SomeClear {-# UNPACK #-} !(IORef (Maybe a))
1256+
1257+data SomeIntClear = forall a. SomeIntClear {-# UNPACK #-} !(IORef (IntMap a))
1258+
1259+data SomeRootClear = forall k. SomeRootClear {-# UNPACK #-} !(IORef (DMap k Identity))
1260+
1261+data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a
1262+
1263+debugFinalize :: Bool
1264+debugFinalize = False
1265+
1266+mkWeakPtrWithDebug :: a -> String -> IO (Weak a)
1267+mkWeakPtrWithDebug x debugNote = do
1268+ x' <- evaluate x
1269+ mkWeakPtr x' $
1270+ if debugFinalize
1271+ then Just $ putStrLn $ "finalizing: " ++ debugNote
1272+ else Nothing
1273+
1274+type WeakList a = [Weak a]
1275+
1276+{-# INLINE withIncreasedDepth #-}
1277+#ifdef DEBUG
1278+withIncreasedDepth :: CanTrace x m => m a -> m a
1279+withIncreasedDepth a = do
1280+ spiderTimeline <- askSpiderTimelineEnv
1281+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ
1282+ result <- a
1283+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred
1284+ return result
1285+#else
1286+withIncreasedDepth :: m a -> m a
1287+withIncreasedDepth = id
1288+#endif
1289+
1290+type CanTrace x m = (HasSpiderTimeline x, MonadIO m)
1291+
1292+{-# INLINE tracePropagate #-}
1293+tracePropagate :: (CanTrace x m) => proxy x -> String -> m ()
1294+tracePropagate p = traceWhen p debugPropagate
1295+
1296+{-# INLINE traceInvalidate #-}
1297+traceInvalidate :: String -> IO ()
1298+traceInvalidate = when debugInvalidate . liftIO . putStrLn
1299+
1300+{-# INLINE traceWhen #-}
1301+traceWhen :: (CanTrace x m) => proxy x -> Bool -> String -> m ()
1302+traceWhen p b message = traceMWhen p b $ return message
1303+
1304+{-# INLINE traceMWhen #-}
1305+traceMWhen :: (CanTrace x m) => proxy x -> Bool -> m String -> m ()
1306+traceMWhen _ b getMessage = when b $ do
1307+ message <- getMessage
1308+#ifdef DEBUG
1309+ spiderTimeline <- askSpiderTimelineEnv
1310+ d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline
1311+#else
1312+ let d = 0
1313+#endif
1314+ liftIO $ putStrLn $ replicate d ' ' <> message
1315+
1316+whoCreatedIORef :: IORef a -> IO [String]
1317+whoCreatedIORef (IORef a) = whoCreated $! a
1318+
1319+#ifdef DEBUG_CYCLES
1320+groupByHead :: Eq a => [NonEmpty a] -> [(a, NonEmpty [a])]
1321+groupByHead = \case
1322+ [] -> []
1323+ (x :| xs) : t -> case groupByHead t of
1324+ [] -> [(x, xs :| [])]
1325+ l@((y, yss) : t')
1326+ | x == y -> (x, xs `NonEmpty.cons` yss) : t'
1327+ | otherwise -> (x, xs :| []) : l
1328+
1329+listsToForest :: Eq a => [[a]] -> Forest a
1330+listsToForest l = fmap (\(a, l') -> Node a $ listsToForest $ toList l') $ groupByHead $ catMaybes $ fmap nonEmpty l
1331+#endif
1332+
1333+{-# INLINE propagateSubscriberHold #-}
1334+propagateSubscriberHold :: forall x p. (HasSpiderTimeline x, Patch p) => Hold x p -> p -> EventM x ()
1335+propagateSubscriberHold h a = do
1336+ {-# SCC "trace" #-} traceMWhen (Proxy :: Proxy x) debugPropagate $ liftIO $ do
1337+ invalidators <- liftIO $ readIORef $ holdInvalidators h
1338+ return $ "SubscriberHold" <> showNodeId h <> ": " ++ show (length invalidators)
1339+ v <- {-# SCC "read" #-} liftIO $ readIORef $ holdValue h
1340+ case {-# SCC "apply" #-} apply a v of
1341+ Nothing -> return ()
1342+ Just v' -> do
1343+ {-# SCC "trace2" #-} withIncreasedDepth $ tracePropagate (Proxy :: Proxy x) $ "propagateSubscriberHold: assigning Hold" <> showNodeId h
1344+ vRef <- {-# SCC "vRef" #-} liftIO $ evaluate $ holdValue h
1345+ iRef <- {-# SCC "iRef" #-} liftIO $ evaluate $ holdInvalidators h
1346+ defer $ {-# SCC "assignment" #-} SomeAssignment vRef iRef v'
1347+
1348+data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1349+
1350+runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a
1351+runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)
1352+
1353+askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
1354+askInvalidator = do
1355+ (!m, _) <- BehaviorM ask
1356+ case m of
1357+ Nothing -> return Nothing
1358+ Just (!wi, _) -> return $ Just wi
1359+
1360+askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
1361+askParentsRef = do
1362+ (!m, _) <- BehaviorM ask
1363+ case m of
1364+ Nothing -> return Nothing
1365+ Just (_, !p) -> return $ Just p
1366+
1367+askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
1368+askBehaviorHoldInits = do
1369+ (_, !his) <- BehaviorM ask
1370+ return his
1371+
1372+{-# INLINE getDynHold #-}
1373+getDynHold :: (Defer (SomeHoldInit x) m, Patch p) => Dyn x p -> m (Hold x p)
1374+getDynHold d = do
1375+ mh <- liftIO $ readIORef $ unDyn d
1376+ case mh of
1377+ Right h -> return h
1378+ Left (readV0, v') -> do
1379+ holdInits <- getDeferralQueue
1380+ v0 <- liftIO $ runBehaviorM readV0 Nothing holdInits
1381+ h <- hold v0 v'
1382+ liftIO $ writeIORef (unDyn d) $ Right h
1383+ return h
1384+
1385+-- Always refers to 0
1386+{-# NOINLINE zeroRef #-}
1387+zeroRef :: IORef Height
1388+zeroRef = unsafePerformIO $ newIORef zeroHeight
1389+
1390+getRootSubscribed :: GCompare k => k a -> Root x k -> Subscriber x a -> IO (WeakBagTicket, RootSubscribed x a, Maybe a)
1391+getRootSubscribed k r sub = do
1392+ mSubscribed <- readIORef $ rootSubscribed r
1393+ let getOcc = fmap (coerce . DMap.lookup k) $ readIORef $ rootOccurrence r
1394+ case DMap.lookup k mSubscribed of
1395+ Just subscribed -> {-# SCC "hitRoot" #-} do
1396+ sln <- subscribeRootSubscribed subscribed sub
1397+ occ <- getOcc
1398+ return (sln, subscribed, occ)
1399+ Nothing -> {-# SCC "missRoot" #-} do
1400+ weakSelf <- newIORef $ error "getRootSubscribed: weakSelfRef not initialized"
1401+ let !cached = rootSubscribed r
1402+ uninitRef <- newIORef $ error "getRootsubscribed: uninitRef not initialized"
1403+ (subs, sln) <- WeakBag.singleton sub weakSelf cleanupRootSubscribed
1404+ when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"
1405+ uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
1406+ writeIORef uninitRef $! uninit
1407+ let !subscribed = RootSubscribed
1408+ { rootSubscribedKey = k
1409+ , rootSubscribedCachedSubscribed = cached
1410+ , rootSubscribedOccurrence = getOcc
1411+ , rootSubscribedSubscribers = subs
1412+ , rootSubscribedUninit = uninit
1413+ , rootSubscribedWeakSelf = weakSelf
1414+#ifdef DEBUG_NODEIDS
1415+ , rootSubscribedNodeId = unsafeNodeId (k, r, subs)
1416+#endif
1417+ }
1418+ -- If we die at the same moment that all our children die, they will
1419+ -- try to clean us up but will fail because their Weak reference to us
1420+ -- will also be dead. So, if we are dying, check if there are any
1421+ -- children; since children don't bother cleaning themselves up if
1422+ -- their parents are already dead, I don't think there's a race
1423+ -- condition here. However, if there are any children, then we can
1424+ -- infer that we need to clean ourselves up, so we do.
1425+ finalCleanup = do
1426+ cs <- readIORef $ _weakBag_children subs
1427+ when (not $ IntMap.null cs) (cleanupRootSubscribed subscribed)
1428+ writeIORef weakSelf =<< evaluate =<< mkWeakPtr subscribed (Just finalCleanup)
1429+ 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
1430+ occ <- getOcc
1431+ return (sln, subscribed, occ)
1432+
1433+#ifdef USE_TEMPLATE_HASKELL
1434+{-# ANN cleanupRootSubscribed "HLint: ignore Redundant bracket" #-}
1435+#endif
1436+cleanupRootSubscribed :: RootSubscribed x a -> IO ()
1437+cleanupRootSubscribed self@RootSubscribed { rootSubscribedKey = k, rootSubscribedCachedSubscribed = cached } = do
1438+ rootSubscribedUninit self
1439+ modifyIORef' cached $ DMap.delete k
1440+
1441+{-# INLINE subscribeRootSubscribed #-}
1442+subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1443+subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed
1444+
1445+newtype EventSelectorInt x a = EventSelectorInt { selectInt :: Int -> Event x a }
1446+
1447+data FanInt x a = FanInt
1448+ { _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
1449+ , _fanInt_subscriptionRef :: {-# UNPACK #-} !(IORef (EventSubscription x)) -- This should have a valid subscription iff subscribers is non-empty
1450+ , _fanInt_occRef :: {-# UNPACK #-} !(IORef (IntMap a))
1451+ }
1452+
1453+newFanInt :: IO (FanInt x a)
1454+newFanInt = do
1455+ 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
1456+ subscriptionRef <- newIORef $ error "fanInt: no subscription"
1457+ occRef <- newIORef $ error "fanInt: no occurrence"
1458+ return $ FanInt
1459+ { _fanInt_subscribers = subscribers
1460+ , _fanInt_subscriptionRef = subscriptionRef
1461+ , _fanInt_occRef = occRef
1462+ }
1463+
1464+{-# NOINLINE unsafeNewFanInt #-}
1465+unsafeNewFanInt :: b -> FanInt x a
1466+unsafeNewFanInt b = unsafePerformIO $ do
1467+ touch b
1468+ newFanInt
1469+
1470+fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a
1471+fanInt p =
1472+ let self = unsafeNewFanInt p
1473+ in EventSelectorInt $ \k -> Event $ \sub -> do
1474+ isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)
1475+ when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input
1476+ (subscription, parentOcc) <- subscribeAndRead p $ Subscriber
1477+ { subscriberPropagate = \m -> do
1478+ liftIO $ writeIORef (_fanInt_occRef self) m
1479+ scheduleIntClear $ _fanInt_occRef self
1480+ FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> do --TODO: Do we need to know that no subscribers are being added as we traverse?
1481+ FastWeakBag.traverse b $ \s -> do
1482+ subscriberPropagate s v
1483+ , subscriberInvalidateHeight = \old -> do
1484+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1485+ FastWeakBag.traverse b $ \s -> do
1486+ subscriberInvalidateHeight s old
1487+ , subscriberRecalculateHeight = \new -> do
1488+ FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1489+ FastWeakBag.traverse b $ \s -> do
1490+ subscriberRecalculateHeight s new
1491+ }
1492+ liftIO $ do
1493+ writeIORef (_fanInt_subscriptionRef self) subscription
1494+ writeIORef (_fanInt_occRef self) $ fromMaybe IntMap.empty parentOcc
1495+ scheduleIntClear $ _fanInt_occRef self
1496+ liftIO $ do
1497+ b <- FastMutableIntMap.lookup (_fanInt_subscribers self) k >>= \case
1498+ Nothing -> do
1499+ b <- FastWeakBag.empty
1500+ FastMutableIntMap.insert (_fanInt_subscribers self) k b
1501+ return b
1502+ Just b -> return b
1503+ t <- liftIO $ FastWeakBag.insert sub b
1504+ currentOcc <- readIORef (_fanInt_occRef self)
1505+ (EventSubscription _ (EventSubscribed !heightRef _)) <- readIORef (_fanInt_subscriptionRef self)
1506+ return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)
1507+
1508+{-# INLINABLE getFanSubscribed #-}
1509+getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket, FanSubscribed x k, Maybe a)
1510+getFanSubscribed k f sub = do
1511+ mSubscribed <- liftIO $ readIORef $ fanSubscribed f
1512+ case mSubscribed of
1513+ Just subscribed -> {-# SCC "hitFan" #-} liftIO $ do
1514+ sln <- subscribeFanSubscribed k subscribed sub
1515+ occ <- readIORef $ fanSubscribedOccurrence subscribed
1516+ return (sln, subscribed, coerce $ DMap.lookup k =<< occ)
1517+ Nothing -> {-# SCC "missFan" #-} do
1518+ subscribedRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribedRef not yet initialized"
1519+ subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1520+ s <- liftIO $ newSubscriberFan subscribedUnsafe
1521+ (subscription, parentOcc) <- subscribeAndRead (fanParent f) s
1522+ weakSelf <- liftIO $ newIORef $ error "getFanSubscribed: weakSelf not yet initialized"
1523+ (subsForK, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupFanSubscribed
1524+ subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
1525+ occRef <- liftIO $ newIORef parentOcc
1526+ when (isJust parentOcc) $ scheduleClear occRef
1527+ let subscribed = FanSubscribed
1528+ { fanSubscribedCachedSubscribed = fanSubscribed f
1529+ , fanSubscribedOccurrence = occRef
1530+ , fanSubscribedParent = subscription
1531+ , fanSubscribedSubscribers = subscribersRef
1532+#ifdef DEBUG_NODEIDS
1533+ , fanSubscribedNodeId = unsafeNodeId f
1534+#endif
1535+ }
1536+ let !self = (k, subscribed)
1537+ liftIO $ writeIORef subscribersRef $! DMap.singleton k $ FanSubscribedChildren subsForK self weakSelf
1538+ liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug self "FanSubscribed"
1539+ liftIO $ writeIORef subscribedRef $! subscribed
1540+ liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
1541+ return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)
1542+
1543+cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO ()
1544+cleanupFanSubscribed (k, subscribed) = do
1545+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1546+ let reducedSubscribers = DMap.delete k subscribers
1547+ if DMap.null reducedSubscribers
1548+ then do
1549+ unsubscribe $ fanSubscribedParent subscribed
1550+ -- Not necessary in this case, because this whole FanSubscribed is dead: writeIORef (fanSubscribedSubscribers subscribed) reducedSubscribers
1551+ writeIORef (fanSubscribedCachedSubscribed subscribed) Nothing
1552+ else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
1553+
1554+{-# INLINE subscribeFanSubscribed #-}
1555+subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO WeakBagTicket
1556+subscribeFanSubscribed k subscribed sub = do
1557+ subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1558+ case DMap.lookup k subscribers of
1559+ Nothing -> {-# SCC "missSubscribeFanSubscribed" #-} do
1560+ let !self = (k, subscribed)
1561+ weakSelf <- newIORef =<< mkWeakPtrWithDebug self "FanSubscribed"
1562+ (list, sln) <- WeakBag.singleton sub weakSelf cleanupFanSubscribed
1563+ 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
1564+ return sln
1565+ Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed
1566+
1567+{-# INLINABLE getSwitchSubscribed #-}
1568+getSwitchSubscribed :: HasSpiderTimeline x => Switch x a -> Subscriber x a -> EventM x (WeakBagTicket, SwitchSubscribed x a, Maybe a)
1569+getSwitchSubscribed s sub = do
1570+ mSubscribed <- liftIO $ readIORef $ switchSubscribed s
1571+ case mSubscribed of
1572+ Just subscribed -> {-# SCC "hitSwitch" #-} liftIO $ do
1573+ sln <- subscribeSwitchSubscribed subscribed sub
1574+ occ <- readIORef $ switchSubscribedOccurrence subscribed
1575+ return (sln, subscribed, occ)
1576+ Nothing -> {-# SCC "missSwitch" #-} do
1577+ subscribedRef <- liftIO $ newIORef $ error "getSwitchSubscribed: subscribed has not yet been created"
1578+ subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1579+ i <- liftIO $ newInvalidatorSwitch subscribedUnsafe
1580+ mySub <- liftIO $ newSubscriberSwitch subscribedUnsafe
1581+ wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorSwitch"
1582+ wiRef <- liftIO $ newIORef wi
1583+ parentsRef <- liftIO $ newIORef [] --TODO: This should be unnecessary, because it will always be filled with just the single parent behavior
1584+ holdInits <- getDeferralQueue
1585+ e <- liftIO $ runBehaviorM (readBehaviorTracked (switchParent s)) (Just (wi, parentsRef)) holdInits
1586+ (subscription@(EventSubscription _ subd), parentOcc) <- subscribeAndRead e mySub
1587+ heightRef <- liftIO $ newIORef =<< getEventSubscribedHeight subd
1588+ subscriptionRef <- liftIO $ newIORef subscription
1589+ occRef <- liftIO $ newIORef parentOcc
1590+ when (isJust parentOcc) $ scheduleClear occRef
1591+ weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
1592+ (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1593+ let !subscribed = SwitchSubscribed
1594+ { switchSubscribedCachedSubscribed = switchSubscribed s
1595+ , switchSubscribedOccurrence = occRef
1596+ , switchSubscribedHeight = heightRef
1597+ , switchSubscribedSubscribers = subs
1598+ , switchSubscribedOwnInvalidator = i
1599+ , switchSubscribedOwnWeakInvalidator = wiRef
1600+ , switchSubscribedBehaviorParents = parentsRef
1601+ , switchSubscribedParent = switchParent s
1602+ , switchSubscribedCurrentParent = subscriptionRef
1603+ , switchSubscribedWeakSelf = weakSelf
1604+#ifdef DEBUG_NODEIDS
1605+ , switchSubscribedNodeId = unsafeNodeId s
1606+#endif
1607+ }
1608+ liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
1609+ liftIO $ writeIORef subscribedRef $! subscribed
1610+ liftIO $ writeIORef (switchSubscribed s) $ Just subscribed
1611+ return (slnForSub, subscribed, parentOcc)
1612+
1613+cleanupSwitchSubscribed :: SwitchSubscribed x a -> IO ()
1614+cleanupSwitchSubscribed subscribed = do
1615+ unsubscribe =<< readIORef (switchSubscribedCurrentParent subscribed)
1616+ finalize =<< readIORef (switchSubscribedOwnWeakInvalidator subscribed) -- We don't need to get invalidated if we're dead
1617+ writeIORef (switchSubscribedCachedSubscribed subscribed) Nothing
1618+
1619+{-# INLINE subscribeSwitchSubscribed #-}
1620+subscribeSwitchSubscribed :: SwitchSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1621+subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed
1622+
1623+{-# INLINABLE getCoincidenceSubscribed #-}
1624+getCoincidenceSubscribed :: forall x a. HasSpiderTimeline x => Coincidence x a -> Subscriber x a -> EventM x (WeakBagTicket, CoincidenceSubscribed x a, Maybe a)
1625+getCoincidenceSubscribed c sub = do
1626+ mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c
1627+ case mSubscribed of
1628+ Just subscribed -> {-# SCC "hitCoincidence" #-} liftIO $ do
1629+ sln <- subscribeCoincidenceSubscribed subscribed sub
1630+ occ <- readIORef $ coincidenceSubscribedOccurrence subscribed
1631+ return (sln, subscribed, occ)
1632+ Nothing -> {-# SCC "missCoincidence" #-} do
1633+ subscribedRef <- liftIO $ newIORef $ error "getCoincidenceSubscribed: subscribed has not yet been created"
1634+ subscribedUnsafe <- liftIO $ unsafeInterleaveIO $ readIORef subscribedRef
1635+ subOuter <- liftIO $ newSubscriberCoincidenceOuter subscribedUnsafe
1636+ (outerSubscription@(EventSubscription _ outerSubd), outerOcc) <- subscribeAndRead (coincidenceParent c) subOuter
1637+ outerHeight <- liftIO $ getEventSubscribedHeight outerSubd
1638+ (occ, height, mInnerSubd) <- case outerOcc of
1639+ Nothing -> return (Nothing, outerHeight, Nothing)
1640+ Just o -> do
1641+ (occ, height, innerSubd) <- subscribeCoincidenceInner o outerHeight subscribedUnsafe
1642+ return (occ, height, Just innerSubd)
1643+ occRef <- liftIO $ newIORef occ
1644+ when (isJust occ) $ scheduleClear occRef
1645+ heightRef <- liftIO $ newIORef height
1646+ innerSubdRef <- liftIO $ newIORef mInnerSubd
1647+ scheduleClear innerSubdRef
1648+ weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
1649+ (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
1650+ let subscribed = CoincidenceSubscribed
1651+ { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
1652+ , coincidenceSubscribedOccurrence = occRef
1653+ , coincidenceSubscribedHeight = heightRef
1654+ , coincidenceSubscribedSubscribers = subs
1655+ , coincidenceSubscribedOuter = subOuter
1656+ , coincidenceSubscribedOuterParent = outerSubscription
1657+ , coincidenceSubscribedInnerParent = innerSubdRef
1658+ , coincidenceSubscribedWeakSelf = weakSelf
1659+#ifdef DEBUG_NODEIDS
1660+ , coincidenceSubscribedNodeId = unsafeNodeId c
1661+#endif
1662+ }
1663+ liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
1664+ liftIO $ writeIORef subscribedRef $! subscribed
1665+ liftIO $ writeIORef (coincidenceSubscribed c) $ Just subscribed
1666+ return (slnForSub, subscribed, occ)
1667+
1668+cleanupCoincidenceSubscribed :: CoincidenceSubscribed x a -> IO ()
1669+cleanupCoincidenceSubscribed subscribed = do
1670+ unsubscribe $ coincidenceSubscribedOuterParent subscribed
1671+ writeIORef (coincidenceSubscribedCachedSubscribed subscribed) Nothing
1672+
1673+{-# INLINE subscribeCoincidenceSubscribed #-}
1674+subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1675+subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
1676+
1677+{-# INLINE merge #-}
1678+merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1679+merge d = cacheEvent (mergeCheap d)
1680+
1681+{-# INLINE mergeWithMove #-}
1682+mergeWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1683+mergeWithMove d = cacheEvent (mergeCheapWithMove d)
1684+
1685+{-# INLINE [1] mergeCheap #-}
1686+mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1687+mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy
1688+ where
1689+ updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)
1690+ updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
1691+ let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do
1692+ (mOldSubd, newPs) <- case me of
1693+ Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
1694+ Just e -> do
1695+ let s = subscriber $ return k
1696+ subscription@(EventSubscription _ subd) <- subscribe e s
1697+ newParentHeight <- liftIO $ getEventSubscribedHeight subd
1698+ let newParent = MergeSubscribedParent subscription
1699+ liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1700+ return $ DMap.insertLookupWithKey' (\_ new _ -> new) k newParent ps
1701+ forM_ mOldSubd $ \oldSubd -> do
1702+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ unMergeSubscribedParent oldSubd
1703+ liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1704+ return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
1705+ foldM f ([], oldParents) $ DMap.toList p
1706+ getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParent x)
1707+ getInitialSubscribers initialParents subscriber = do
1708+ subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1709+ let s = subscriber $ return k
1710+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1711+ height <- liftIO $ getEventSubscribedHeight parentSubd
1712+ return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription)
1713+ return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1714+ , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1715+ , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1716+ )
1717+ destroy :: MergeDestroyFunc k (MergeSubscribedParent x)
1718+ destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub
1719+
1720+{-# INLINE [1] mergeCheapWithMove #-}
1721+mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1722+mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
1723+ where
1724+ updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)
1725+ updateMe subscriber heightBagRef oldParents p = do
1726+ -- Prepare new parents for insertion
1727+ let subscribeParent :: forall a. k a -> Event x a -> EventM x (MergeSubscribedParentWithMove x k a)
1728+ subscribeParent k e = do
1729+ keyRef <- liftIO $ newIORef k
1730+ let s = subscriber $ liftIO $ readIORef keyRef
1731+ subscription@(EventSubscription _ subd) <- subscribe e s
1732+ liftIO $ do
1733+ newParentHeight <- getEventSubscribedHeight subd
1734+ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1735+ return $ MergeSubscribedParentWithMove subscription keyRef
1736+ p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey subscribeParent p
1737+ -- Collect old parents for deletion and update the keys of moved parents
1738+ let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Event x) a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
1739+ moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
1740+ Nothing -> do
1741+ oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent
1742+ liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1743+ return $ Just $ _mergeSubscribedParentWithMove_subscription parent
1744+ Just toKey -> do
1745+ liftIO $ writeIORef (_mergeSubscribedParentWithMove_key parent) $! toKey
1746+ return Nothing
1747+ toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
1748+ return (toDelete, applyAlways p' oldParents)
1749+ getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k)
1750+ getInitialSubscribers initialParents subscriber = do
1751+ subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1752+ keyRef <- liftIO $ newIORef k
1753+ let s = subscriber $ liftIO $ readIORef keyRef
1754+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1755+ height <- liftIO $ getEventSubscribedHeight parentSubd
1756+ return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
1757+ return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1758+ , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1759+ , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1760+ )
1761+ destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)
1762+ destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub
1763+
1764+type MergeUpdateFunc k x p s
1765+ = (forall a. EventM x (k a) -> Subscriber x a)
1766+ -> IORef HeightBag
1767+ -> DMap k s
1768+ -> p
1769+ -> EventM x ([EventSubscription x], DMap k s)
1770+
1771+type MergeInitFunc k x s
1772+ = DMap k (Event x)
1773+ -> (forall a. EventM x (k a) -> Subscriber x a)
1774+ -> EventM x (DMap k Identity, [Height], DMap k s)
1775+
1776+type MergeDestroyFunc k s
1777+ = DMap k s
1778+ -> IO ()
1779+
1780+data Merge x k s = Merge
1781+ { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))
1782+ , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)
1783+ , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)
1784+ , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k Identity))
1785+ , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k Identity))
1786+ }
1787+
1788+invalidateMergeHeight :: Merge x k s -> IO ()
1789+invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)
1790+
1791+invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
1792+invalidateMergeHeight' heightRef sub = do
1793+ oldHeight <- readIORef heightRef
1794+ 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
1795+ writeIORef heightRef $! invalidHeight
1796+ subscriberInvalidateHeight sub oldHeight
1797+
1798+
1799+revalidateMergeHeight :: Merge x k s -> IO ()
1800+revalidateMergeHeight m = do
1801+ currentHeight <- readIORef $ _merge_heightRef m
1802+ when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
1803+ heights <- readIORef $ _merge_heightBagRef m
1804+ parents <- readIORef $ _merge_parentsRef m
1805+ -- When the number of heights in the bag reaches the number of parents, we should have a valid height
1806+ case heightBagSize heights `compare` DMap.size parents of
1807+ LT -> return ()
1808+ EQ -> do
1809+ let height = succHeight $ heightBagMax heights
1810+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
1811+ writeIORef (_merge_heightRef m) $! height
1812+ subscriberRecalculateHeight (_merge_sub m) height
1813+ GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
1814+
1815+scheduleMergeSelf :: HasSpiderTimeline x => Merge x k s -> Height -> EventM x ()
1816+scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
1817+ vals <- liftIO $ readIORef $ _merge_accumRef m
1818+ 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
1819+ --TODO: Assert that m is not empty
1820+ subscriberPropagate (_merge_sub m) vals
1821+
1822+mergeSubscriber :: forall x k s a. (HasSpiderTimeline x, GCompare k) => Merge x k s -> EventM x (k a) -> Subscriber x a
1823+mergeSubscriber m getKey = Subscriber
1824+ { subscriberPropagate = \a -> do
1825+ oldM <- liftIO $ readIORef $ _merge_accumRef m
1826+ k <- getKey
1827+ let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM
1828+ tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
1829+ liftIO $ writeIORef (_merge_accumRef m) $! newM
1830+ when (DMap.null oldM) $ do -- Only schedule the firing once
1831+ height <- liftIO $ readIORef $ _merge_heightRef m
1832+ --TODO: assertions about height
1833+ currentHeight <- getCurrentHeight
1834+ when (height <= currentHeight) $ do
1835+ if height /= invalidHeight
1836+ then do
1837+ myStack <- liftIO $ whoCreatedIORef undefined --TODO
1838+ error $ "Height (" ++ show height ++ ") is not greater than current height (" ++ show currentHeight ++ ")\n" ++ unlines (reverse myStack)
1839+ else liftIO $ do
1840+#ifdef DEBUG_CYCLES
1841+ nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
1842+ stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es
1843+ let cycleInfo = ":\n" <> drawForest (listsToForest stacks)
1844+#else
1845+ let cycleInfo = ""
1846+#endif
1847+ error $ "Causality loop found" <> cycleInfo
1848+ scheduleMergeSelf m height
1849+ , subscriberInvalidateHeight = \old -> do --TODO: When removing a parent doesn't actually change the height, maybe we can avoid invalidating
1850+ modifyIORef' (_merge_heightBagRef m) $ heightBagRemove old
1851+ invalidateMergeHeight m
1852+ , subscriberRecalculateHeight = \new -> do
1853+ modifyIORef' (_merge_heightBagRef m) $ heightBagAdd new
1854+ revalidateMergeHeight m
1855+ }
1856+
1857+--TODO: Be able to run as much of this as possible promptly
1858+updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k s -> MergeUpdateFunc k x p s -> p -> SomeMergeUpdate x
1859+updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)
1860+ where updateMe = do
1861+ oldParents <- liftIO $ readIORef $ _merge_parentsRef m
1862+ (subscriptionsToKill, newParents) <- updateFunc (mergeSubscriber m) (_merge_heightBagRef m) oldParents p
1863+ liftIO $ writeIORef (_merge_parentsRef m) $! newParents
1864+ return subscriptionsToKill
1865+
1866+{-# INLINE mergeCheap' #-}
1867+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)
1868+mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1869+ initialParents <- readBehaviorUntracked $ dynamicCurrent d
1870+ accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
1871+ heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
1872+ heightBagRef <- liftIO $ newIORef $ error "merge: heightBagRef not yet initialized"
1873+ parentsRef :: IORef (DMap k s) <- liftIO $ newIORef $ error "merge: parentsRef not yet initialized"
1874+ let m = Merge
1875+ { _merge_parentsRef = parentsRef
1876+ , _merge_heightBagRef = heightBagRef
1877+ , _merge_heightRef = heightRef
1878+ , _merge_sub = sub
1879+ , _merge_accumRef = accumRef
1880+ }
1881+ (dm, heights, initialParentState) <- getInitialSubscribers initialParents $ mergeSubscriber m
1882+ let myHeightBag = heightBagFromList $ filter (/= invalidHeight) heights
1883+ myHeight = if invalidHeight `elem` heights
1884+ then invalidHeight
1885+ else succHeight $ heightBagMax myHeightBag
1886+ currentHeight <- getCurrentHeight
1887+ let (occ, accum) = if currentHeight >= myHeight -- If we should have fired by now
1888+ then (if DMap.null dm then Nothing else Just dm, DMap.empty)
1889+ else (Nothing, dm)
1890+ unless (DMap.null accum) $ do
1891+ scheduleMergeSelf m myHeight
1892+ liftIO $ writeIORef accumRef $! accum
1893+ liftIO $ writeIORef heightRef $! myHeight
1894+ liftIO $ writeIORef heightBagRef $! myHeightBag
1895+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
1896+ liftIO $ writeIORef parentsRef $! initialParentState
1897+ defer $ SomeMergeInit $ do
1898+ let s = Subscriber
1899+ { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
1900+ tracePropagate (Proxy :: Proxy x) $ "SubscriberMerge/Change"
1901+ defer $ updateMerge m updateFunc a
1902+ , subscriberInvalidateHeight = \_ -> return ()
1903+ , subscriberRecalculateHeight = \_ -> return ()
1904+ }
1905+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s
1906+ forM_ change $ \c -> defer $ updateMerge m updateFunc c
1907+ -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
1908+ -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
1909+ -- its subscription.
1910+ liftIO $ writeIORef changeSubdRef (s, changeSubscription)
1911+ let unsubscribeAll = destroy =<< readIORef parentsRef
1912+ return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parentsRef, changeSubdRef)
1913+ , occ
1914+ )
1915+
1916+mergeInt :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1917+mergeInt = cacheEvent . mergeIntCheap
1918+
1919+{-# INLINABLE mergeIntCheap #-}
1920+mergeIntCheap :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1921+mergeIntCheap d = Event $ \sub -> do
1922+ initialParents <- readBehaviorUntracked $ dynamicCurrent d
1923+ accum <- liftIO $ FastMutableIntMap.newEmpty
1924+ heightRef <- liftIO $ newIORef zeroHeight
1925+ heightBagRef <- liftIO $ newIORef heightBagEmpty
1926+ parents <- liftIO $ FastMutableIntMap.newEmpty
1927+ let scheduleSelf = do
1928+ height <- liftIO $ readIORef $ heightRef
1929+ scheduleMerge' height heightRef $ do
1930+ vals <- liftIO $ FastMutableIntMap.getFrozenAndClear accum
1931+ subscriberPropagate sub vals
1932+ invalidateMyHeight = do
1933+ invalidateMergeHeight' heightRef sub
1934+ recalculateMyHeight = do
1935+ currentHeight <- readIORef heightRef
1936+ 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?
1937+ heights <- readIORef heightBagRef
1938+ numParents <- FastMutableIntMap.size parents
1939+ case heightBagSize heights `compare` numParents of
1940+ LT -> return ()
1941+ EQ -> do
1942+ let height = succHeight $ heightBagMax heights
1943+ when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: height: " <> show height
1944+ writeIORef heightRef $! height
1945+ subscriberRecalculateHeight sub height
1946+ GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show numParents <> ") for Merge"
1947+ mySubscriber k = Subscriber
1948+ { subscriberPropagate = \a -> do
1949+ wasEmpty <- liftIO $ FastMutableIntMap.isEmpty accum
1950+ liftIO $ FastMutableIntMap.insert accum k a
1951+ when wasEmpty scheduleSelf
1952+ , subscriberInvalidateHeight = \old -> do
1953+ modifyIORef' heightBagRef $ heightBagRemove old
1954+ invalidateMyHeight
1955+ , subscriberRecalculateHeight = \new -> do
1956+ modifyIORef' heightBagRef $ heightBagAdd new
1957+ recalculateMyHeight
1958+ }
1959+ forM_ (IntMap.toList initialParents) $ \(k, p) -> do
1960+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead p $ mySubscriber k
1961+ liftIO $ do
1962+ forM_ parentOcc $ FastMutableIntMap.insert accum k
1963+ FastMutableIntMap.insert parents k subscription
1964+ height <- getEventSubscribedHeight parentSubd
1965+ if height == invalidHeight
1966+ then writeIORef heightRef invalidHeight
1967+ else do
1968+ modifyIORef' heightBagRef $ heightBagAdd height
1969+ modifyIORef' heightRef $ \oldHeight ->
1970+ if oldHeight == invalidHeight
1971+ then invalidHeight
1972+ else max (succHeight height) oldHeight
1973+ myHeight <- liftIO $ readIORef heightRef
1974+ currentHeight <- getCurrentHeight
1975+ isEmpty <- liftIO $ FastMutableIntMap.isEmpty accum
1976+ occ <- if currentHeight >= myHeight -- If we should have fired by now
1977+ then if isEmpty
1978+ then return Nothing
1979+ else liftIO $ Just <$> FastMutableIntMap.getFrozenAndClear accum
1980+ else do when (not isEmpty) scheduleSelf -- We have things accumulated, but we shouldn't have fired them yet
1981+ return Nothing
1982+ changeSubdRef <- liftIO $ newIORef $ error "getMergeSubscribed: changeSubdRef not yet initialized"
1983+ defer $ SomeMergeInit $ do
1984+ let updateMe a = SomeMergeUpdate u invalidateMyHeight recalculateMyHeight
1985+ where
1986+ u = do
1987+ let f k newParent = do
1988+ subscription@(EventSubscription _ subd) <- subscribe newParent $ mySubscriber k
1989+ newParentHeight <- liftIO $ getEventSubscribedHeight subd
1990+ liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1991+ return subscription
1992+ newSubscriptions <- FastMutableIntMap.traverseIntMapPatchWithKey f a
1993+ oldParents <- liftIO $ FastMutableIntMap.applyPatch parents newSubscriptions
1994+ liftIO $ for_ oldParents $ \oldParent -> do
1995+ oldParentHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed oldParent
1996+ modifyIORef' heightBagRef $ heightBagRemove oldParentHeight
1997+ return $ IntMap.elems oldParents
1998+ let s = Subscriber
1999+ { subscriberPropagate = \a -> {-# SCC "traverseMergeChange" #-} do
2000+ tracePropagate (Proxy :: Proxy x) $ "SubscriberMergeInt/Change"
2001+ defer $ updateMe a
2002+ , subscriberInvalidateHeight = \_ -> return ()
2003+ , subscriberRecalculateHeight = \_ -> return ()
2004+ }
2005+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s
2006+ forM_ change $ \c -> defer $ updateMe c
2007+ -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
2008+ -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
2009+ -- its subscription.
2010+ liftIO $ writeIORef changeSubdRef (s, changeSubscription)
2011+ let unsubscribeAll = traverse_ unsubscribe =<< FastMutableIntMap.getFrozenAndClear parents
2012+ return ( EventSubscription unsubscribeAll $ EventSubscribed heightRef $ toAny (parents, changeSubdRef)
2013+ , occ
2014+ )
2015+
2016+newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
2017+
2018+fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k
2019+fan e =
2020+ let f = Fan
2021+ { fanParent = e
2022+ , fanSubscribed = unsafeNewIORef e Nothing
2023+ }
2024+ in EventSelector $ \k -> eventFan k f
2025+
2026+runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()
2027+runHoldInits holdInitRef dynInitRef mergeInitRef = do
2028+ holdInits <- liftIO $ readIORef holdInitRef
2029+ dynInits <- liftIO $ readIORef dynInitRef
2030+ mergeInits <- liftIO $ readIORef mergeInitRef
2031+ unless (null holdInits && null dynInits && null mergeInits) $ do
2032+ liftIO $ writeIORef holdInitRef []
2033+ liftIO $ writeIORef dynInitRef []
2034+ liftIO $ writeIORef mergeInitRef []
2035+ mapM_ initHold holdInits
2036+ mapM_ initDyn dynInits
2037+ mapM_ unSomeMergeInit mergeInits
2038+ runHoldInits holdInitRef dynInitRef mergeInitRef
2039+
2040+initHold :: HasSpiderTimeline x => SomeHoldInit x -> EventM x ()
2041+initHold (SomeHoldInit h) = void $ getHoldEventSubscription h
2042+
2043+initDyn :: HasSpiderTimeline x => SomeDynInit x -> EventM x ()
2044+initDyn (SomeDynInit d) = void $ getDynHold d
2045+
2046+newEventEnv :: IO (EventEnv x)
2047+newEventEnv = do
2048+ toAssignRef <- newIORef [] -- This should only actually get used when events are firing
2049+ holdInitRef <- newIORef []
2050+ dynInitRef <- newIORef []
2051+ mergeUpdateRef <- newIORef []
2052+ mergeInitRef <- newIORef []
2053+ heightRef <- newIORef zeroHeight
2054+ toClearRef <- newIORef []
2055+ toClearIntRef <- newIORef []
2056+ toClearRootRef <- newIORef []
2057+ coincidenceInfosRef <- newIORef []
2058+ delayedRef <- newIORef IntMap.empty
2059+ return $ EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef
2060+
2061+clearEventEnv :: EventEnv x -> IO ()
2062+clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeInitRef toClearRef toClearIntRef toClearRootRef heightRef coincidenceInfosRef delayedRef) = do
2063+ writeIORef toAssignRef []
2064+ writeIORef holdInitRef []
2065+ writeIORef dynInitRef []
2066+ writeIORef mergeUpdateRef []
2067+ writeIORef mergeInitRef []
2068+ writeIORef heightRef zeroHeight
2069+ writeIORef toClearRef []
2070+ writeIORef toClearIntRef []
2071+ writeIORef toClearRootRef []
2072+ writeIORef coincidenceInfosRef []
2073+ writeIORef delayedRef IntMap.empty
2074+
2075+-- | Run an event action outside of a frame
2076+runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
2077+runFrame a = SpiderHost $ ask >>= \_ -> lift $ do
2078+ let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
2079+ let go = do
2080+ result <- a
2081+ 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
2082+ return result
2083+ result <- runEventM go
2084+ toClear <- readIORef $ eventEnvClears env
2085+ forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing
2086+ toClearInt <- readIORef $ eventEnvIntClears env
2087+ forM_ toClearInt $ \(SomeIntClear ref) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty
2088+ toClearRoot <- readIORef $ eventEnvRootClears env
2089+ forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty
2090+ toAssign <- readIORef $ eventEnvAssignments env
2091+ toReconnectRef <- newIORef []
2092+ coincidenceInfos <- readIORef $ eventEnvResetCoincidences env
2093+ forM_ toAssign $ \(SomeAssignment vRef iRef v) -> {-# SCC "assignment" #-} do
2094+ writeIORef vRef v
2095+ when debugInvalidate $ putStrLn $ "Invalidating Hold"
2096+ writeIORef iRef =<< evaluate =<< invalidate toReconnectRef =<< readIORef iRef
2097+ mergeUpdates <- readIORef $ eventEnvMergeUpdates env
2098+ writeIORef (eventEnvMergeUpdates env) []
2099+ when debugPropagate $ putStrLn "Updating merges"
2100+ mergeSubscriptionsToKill <- runEventM $ concat <$> mapM _someMergeUpdate_update mergeUpdates
2101+ when debugPropagate $ putStrLn "Updating merges done"
2102+ toReconnect <- readIORef toReconnectRef
2103+ clearEventEnv env
2104+ switchSubscriptionsToKill <- forM toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
2105+ oldSubscription <- readIORef $ switchSubscribedCurrentParent subscribed
2106+ wi <- readIORef $ switchSubscribedOwnWeakInvalidator subscribed
2107+ when debugInvalidate $ putStrLn $ "Finalizing invalidator for Switch" <> showNodeId subscribed
2108+ finalize wi
2109+ i <- evaluate $ switchSubscribedOwnInvalidator subscribed
2110+ wi' <- mkWeakPtrWithDebug i "wi'"
2111+ writeIORef (switchSubscribedOwnWeakInvalidator subscribed) $! wi'
2112+ writeIORef (switchSubscribedBehaviorParents subscribed) []
2113+ writeIORef (eventEnvHoldInits env) [] --TODO: Should we reuse this?
2114+ e <- runBehaviorM (readBehaviorTracked (switchSubscribedParent subscribed)) (Just (wi', switchSubscribedBehaviorParents subscribed)) $ eventEnvHoldInits env
2115+ 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
2116+ --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times
2117+ sub <- newSubscriberSwitch subscribed
2118+ 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
2119+ {-
2120+ stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed)
2121+ liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of
2122+ EventRoot _ -> "EventRoot"
2123+ EventNever -> "EventNever"
2124+ _ -> "something else"
2125+ -}
2126+ writeIORef (switchSubscribedCurrentParent subscribed) $! subscription
2127+ return oldSubscription
2128+ liftIO $ mapM_ unsubscribe mergeSubscriptionsToKill
2129+ liftIO $ mapM_ unsubscribe switchSubscriptionsToKill
2130+ forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> {-# SCC "switchSubscribed" #-} do
2131+ EventSubscription _ subd' <- readIORef $ switchSubscribedCurrentParent subscribed
2132+ parentHeight <- getEventSubscribedHeight subd'
2133+ myHeight <- readIORef $ switchSubscribedHeight subscribed
2134+ when (parentHeight /= myHeight) $ do
2135+ writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
2136+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight
2137+ 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
2138+ forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
2139+ unsubscribe subscription
2140+ mapM_ invalidateCoincidenceHeight mcs
2141+ forM_ coincidenceInfos $ \(SomeResetCoincidence _ mcs) -> mapM_ recalculateCoincidenceHeight mcs
2142+ mapM_ _someMergeUpdate_recalculateHeight mergeUpdates
2143+ forM_ toReconnect $ \(SomeSwitchSubscribed subscribed) -> do
2144+ height <- calculateSwitchHeight subscribed
2145+ updateSwitchHeight height subscribed
2146+ return result
2147+
2148+newtype Height = Height { unHeight :: Int } deriving (Show, Read, Eq, Ord, Bounded)
2149+
2150+{-# INLINE zeroHeight #-}
2151+zeroHeight :: Height
2152+zeroHeight = Height 0
2153+
2154+{-# INLINE invalidHeight #-}
2155+invalidHeight :: Height
2156+invalidHeight = Height (-1000)
2157+
2158+#ifdef DEBUG_CYCLES
2159+-- | An invalid height that is currently being traversed, e.g. by walkInvalidHeightParents
2160+{-# INLINE invalidHeightBeingTraversed #-}
2161+invalidHeightBeingTraversed :: Height
2162+invalidHeightBeingTraversed = Height (-1001)
2163+#endif
2164+
2165+{-# INLINE succHeight #-}
2166+succHeight :: Height -> Height
2167+succHeight h@(Height a) =
2168+ if h == invalidHeight
2169+ then invalidHeight
2170+ else Height $ succ a
2171+
2172+invalidateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
2173+invalidateCoincidenceHeight subscribed = do
2174+ oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
2175+ when (oldHeight /= invalidHeight) $ do
2176+ writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight
2177+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
2178+
2179+updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()
2180+updateSwitchHeight new subscribed = do
2181+ oldHeight <- readIORef $ switchSubscribedHeight subscribed
2182+ when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2183+ when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2184+ writeIORef (switchSubscribedHeight subscribed) $! new
2185+ WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new
2186+
2187+recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
2188+recalculateCoincidenceHeight subscribed = do
2189+ oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
2190+ when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2191+ height <- calculateCoincidenceHeight subscribed
2192+ when (height /= invalidHeight) $ do
2193+ writeIORef (coincidenceSubscribedHeight subscribed) $! height
2194+ WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
2195+
2196+calculateSwitchHeight :: SwitchSubscribed x a -> IO Height
2197+calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)
2198+
2199+calculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO Height
2200+calculateCoincidenceHeight subscribed = do
2201+ outerHeight <- getEventSubscribedHeight $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
2202+ innerHeight <- maybe (return zeroHeight) getEventSubscribedHeight =<< readIORef (coincidenceSubscribedInnerParent subscribed)
2203+ return $ if outerHeight == invalidHeight || innerHeight == invalidHeight then invalidHeight else max outerHeight innerHeight
2204+
2205+data SomeSwitchSubscribed x = forall a. SomeSwitchSubscribed {-# NOUNPACK #-} (SwitchSubscribed x a)
2206+
2207+invalidate :: IORef [SomeSwitchSubscribed x] -> WeakList (Invalidator x) -> IO (WeakList (Invalidator x))
2208+invalidate toReconnectRef wis = do
2209+ forM_ wis $ \wi -> do
2210+ mi <- deRefWeak wi
2211+ case mi of
2212+ Nothing -> do
2213+ traceInvalidate "invalidate Dead"
2214+ return () --TODO: Should we clean this up here?
2215+ Just i -> do
2216+ finalize wi -- Once something's invalidated, it doesn't need to hang around; this will change when some things are strict
2217+ case i of
2218+ InvalidatorPull p -> do
2219+ traceInvalidate $ "invalidate: Pull" <> showNodeId p
2220+ mVal <- readIORef $ pullValue p
2221+ forM_ mVal $ \val -> do
2222+ writeIORef (pullValue p) Nothing
2223+ writeIORef (pullSubscribedInvalidators val) =<< evaluate =<< invalidate toReconnectRef =<< readIORef (pullSubscribedInvalidators val)
2224+ InvalidatorSwitch subscribed -> do
2225+ traceInvalidate $ "invalidate: Switch" <> showNodeId subscribed
2226+ modifyIORef' toReconnectRef (SomeSwitchSubscribed subscribed :)
2227+ 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
2228+
2229+--------------------------------------------------------------------------------
2230+-- Reflex integration
2231+--------------------------------------------------------------------------------
2232+
2233+-- | Designates the default, global Spider timeline
2234+data SpiderTimeline x
2235+type role SpiderTimeline nominal
2236+
2237+-- | The default, global Spider environment
2238+type Spider = SpiderTimeline Global
2239+
2240+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (EventM x) where
2241+ {-# INLINABLE sample #-}
2242+ sample (SpiderBehavior b) = readBehaviorUntracked b
2243+
2244+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (EventM x) where
2245+ {-# INLINABLE hold #-}
2246+ hold = holdSpiderEventM
2247+ {-# INLINABLE holdDyn #-}
2248+ holdDyn = holdDynSpiderEventM
2249+ {-# INLINABLE holdIncremental #-}
2250+ holdIncremental = holdIncrementalSpiderEventM
2251+ {-# INLINABLE buildDynamic #-}
2252+ buildDynamic = buildDynamicSpiderEventM
2253+ {-# INLINABLE headE #-}
2254+ headE = R.slowHeadE
2255+-- headE (SpiderEvent e) = SpiderEvent <$> Reflex.Spider.Internal.headE e
2256+
2257+instance Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where
2258+ {-# INLINABLE sample #-}
2259+ sample = coerce . readBehaviorTracked . unSpiderBehavior
2260+
2261+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPushM x) where
2262+ {-# INLINABLE sample #-}
2263+ sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b
2264+
2265+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderPushM x) where
2266+ {-# INLINABLE hold #-}
2267+ hold v0 e = Reflex.Class.current <$> Reflex.Class.holdDyn v0 e
2268+ {-# INLINABLE holdDyn #-}
2269+ holdDyn v0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce e
2270+ {-# INLINABLE holdIncremental #-}
2271+ holdIncremental v0 (SpiderEvent e) = SpiderPushM $ SpiderIncremental . dynamicHold <$> Reflex.Spider.Internal.hold v0 e
2272+ {-# INLINABLE buildDynamic #-}
2273+ buildDynamic getV0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce e
2274+ {-# INLINABLE headE #-}
2275+ headE = R.slowHeadE
2276+-- headE (SpiderEvent e) = SpiderPushM $ SpiderEvent <$> Reflex.Spider.Internal.headE e
2277+
2278+instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where
2279+ {-# INLINE return #-}
2280+ return = pure
2281+ {-# INLINE (>>=) #-}
2282+ x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x
2283+ {-# INLINE (>>) #-}
2284+ (>>) = (*>)
2285+ {-# INLINE fail #-}
2286+ fail _ = error "Dynamic does not support 'fail'"
2287+
2288+{-# INLINABLE newJoinDyn #-}
2289+newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)
2290+newJoinDyn d =
2291+ let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)
2292+ eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d
2293+ eInner = Reflex.Spider.Internal.switch $ dynamicUpdated <$> dynamicCurrent d
2294+ eBoth = Reflex.Spider.Internal.coincidence $ dynamicUpdated . runIdentity <$> dynamicUpdated d
2295+ v' = unSpiderEvent $ Reflex.Class.leftmost $ map SpiderEvent [eBoth, eOuter, eInner]
2296+ in Reflex.Spider.Internal.unsafeBuildDynamic readV0 v'
2297+
2298+instance HasSpiderTimeline x => Functor (Reflex.Class.Dynamic (SpiderTimeline x)) where
2299+ fmap f = SpiderDynamic . newMapDyn f . unSpiderDynamic
2300+ x <$ d = R.unsafeBuildDynamic (return x) $ x <$ R.updated d
2301+
2302+instance HasSpiderTimeline x => Applicative (Reflex.Class.Dynamic (SpiderTimeline x)) where
2303+ pure = SpiderDynamic . dynamicConst
2304+#if MIN_VERSION_base(4,10,0)
2305+ liftA2 f a b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith f (unSpiderDynamic a) (unSpiderDynamic b)
2306+#endif
2307+ SpiderDynamic a <*> SpiderDynamic b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith ($) a b
2308+ a *> b = R.unsafeBuildDynamic (R.sample $ R.current b) $ R.leftmost [R.updated b, R.tag (R.current b) $ R.updated a]
2309+ (<*) = flip (*>) -- There are no effects, so order doesn't matter
2310+
2311+holdSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Behavior (SpiderTimeline x) a)
2312+holdSpiderEventM v0 e = fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e
2313+
2314+holdDynSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)
2315+holdDynSpiderEventM v0 e = fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e
2316+
2317+holdIncrementalSpiderEventM :: (HasSpiderTimeline x, Patch p) => PatchTarget p -> Reflex.Class.Event (SpiderTimeline x) p -> EventM x (Reflex.Class.Incremental (SpiderTimeline x) p)
2318+holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e
2319+
2320+buildDynamicSpiderEventM :: HasSpiderTimeline x => SpiderPullM x a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)
2321+buildDynamicSpiderEventM getV0 e = fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e
2322+
2323+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHost x) where
2324+ {-# INLINABLE hold #-}
2325+ hold v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.hold v0 e
2326+ {-# INLINABLE holdDyn #-}
2327+ holdDyn v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdDyn v0 e
2328+ {-# INLINABLE holdIncremental #-}
2329+ holdIncremental v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdIncremental v0 e
2330+ {-# INLINABLE buildDynamic #-}
2331+ buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e
2332+ {-# INLINABLE headE #-}
2333+ headE e = runFrame . runSpiderHostFrame $ Reflex.Class.headE e
2334+
2335+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where
2336+ sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can
2337+
2338+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHostFrame x) where
2339+ {-# INLINABLE hold #-}
2340+ hold v0 e = SpiderHostFrame $ fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e
2341+ {-# INLINABLE holdDyn #-}
2342+ holdDyn v0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e
2343+ {-# INLINABLE holdIncremental #-}
2344+ holdIncremental v0 e = SpiderHostFrame $ fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e
2345+ {-# INLINABLE buildDynamic #-}
2346+ buildDynamic getV0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e
2347+ {-# INLINABLE headE #-}
2348+ headE = R.slowHeadE
2349+-- headE (SpiderEvent e) = SpiderHostFrame $ SpiderEvent <$> Reflex.Spider.Internal.headE e
2350+
2351+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where
2352+ {-# INLINABLE sample #-}
2353+ sample = runFrame . readBehaviorUntracked . unSpiderBehavior
2354+
2355+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where
2356+ {-# INLINABLE sample #-}
2357+ sample = Reflex.Spider.Internal.ReadPhase . Reflex.Class.sample
2358+
2359+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where
2360+ {-# INLINABLE hold #-}
2361+ hold v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.hold v0 e
2362+ {-# INLINABLE holdDyn #-}
2363+ holdDyn v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdDyn v0 e
2364+ {-# INLINABLE holdIncremental #-}
2365+ holdIncremental v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdIncremental v0 e
2366+ {-# INLINABLE buildDynamic #-}
2367+ buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e
2368+ {-# INLINABLE headE #-}
2369+ headE e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.headE e
2370+
2371+--------------------------------------------------------------------------------
2372+-- Deprecated items
2373+--------------------------------------------------------------------------------
2374+
2375+-- | 'SpiderEnv' is the old name for 'SpiderTimeline'
2376+{-# DEPRECATED SpiderEnv "Use 'SpiderTimelineEnv' instead" #-}
2377+type SpiderEnv = SpiderTimeline
2378+instance HasSpiderTimeline x => Reflex.Host.Class.MonadSubscribeEvent (SpiderTimeline x) (SpiderHostFrame x) where
2379+ {-# INLINABLE subscribeEvent #-}
2380+ subscribeEvent e = SpiderHostFrame $ do
2381+ --TODO: Unsubscribe eventually (manually and/or with weak ref)
2382+ val <- liftIO $ newIORef Nothing
2383+ subscription <- subscribe (unSpiderEvent e) $ Subscriber
2384+ { subscriberPropagate = \a -> do
2385+ liftIO $ writeIORef val $ Just a
2386+ scheduleClear val
2387+ , subscriberInvalidateHeight = \_ -> return ()
2388+ , subscriberRecalculateHeight = \_ -> return ()
2389+ }
2390+ return $ SpiderEventHandle
2391+ { spiderEventHandleSubscription = subscription
2392+ , spiderEventHandleValue = val
2393+ }
2394+
2395+instance HasSpiderTimeline x => Reflex.Host.Class.ReflexHost (SpiderTimeline x) where
2396+ type EventTrigger (SpiderTimeline x) = RootTrigger x
2397+ type EventHandle (SpiderTimeline x) = SpiderEventHandle x
2398+ type HostFrame (SpiderTimeline x) = SpiderHostFrame x
2399+
2400+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReadEvent (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where
2401+ {-# NOINLINE readEvent #-}
2402+ readEvent h = Reflex.Spider.Internal.ReadPhase $ fmap (fmap return) $ liftIO $ do
2403+ result <- readIORef $ spiderEventHandleValue h
2404+ touch h
2405+ return result
2406+
2407+instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where
2408+ newEventWithTrigger = SpiderHost . lift . fmap SpiderEvent . newEventWithTriggerIO
2409+ newFanEventWithTrigger f = SpiderHost $ lift $ do
2410+ es <- newFanEventWithTriggerIO f
2411+ return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es
2412+
2413+instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where
2414+ newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO
2415+ newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do
2416+ es <- newFanEventWithTriggerIO f
2417+ return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es
2418+
2419+instance HasSpiderTimeline x => Reflex.Host.Class.MonadSubscribeEvent (SpiderTimeline x) (SpiderHost x) where
2420+ {-# INLINABLE subscribeEvent #-}
2421+ subscribeEvent = runFrame . runSpiderHostFrame . Reflex.Host.Class.subscribeEvent
2422+
2423+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexHost (SpiderTimeline x) (SpiderHost x) where
2424+ type ReadPhase (SpiderHost x) = Reflex.Spider.Internal.ReadPhase x
2425+ fireEventsAndRead es (Reflex.Spider.Internal.ReadPhase a) = run es a
2426+ runHostFrame = runFrame . runSpiderHostFrame
2427+
2428+unsafeNewSpiderTimelineEnv :: forall x. IO (SpiderTimelineEnv x)
2429+unsafeNewSpiderTimelineEnv = do
2430+ lock <- newMVar ()
2431+ env <- newEventEnv
2432+#ifdef DEBUG
2433+ depthRef <- newIORef 0
2434+#endif
2435+ return $ SpiderTimelineEnv
2436+ { _spiderTimeline_lock = lock
2437+ , _spiderTimeline_eventEnv = env
2438+#ifdef DEBUG
2439+ , _spiderTimeline_depth = depthRef
2440+#endif
2441+ }
2442+
2443+-- | Create a new SpiderTimelineEnv
2444+newSpiderTimeline :: IO (Some SpiderTimelineEnv)
2445+newSpiderTimeline = withSpiderTimeline (pure . Some.This)
2446+
2447+data LocalSpiderTimeline x s
2448+
2449+instance Reifies s (SpiderTimelineEnv x) =>
2450+ HasSpiderTimeline (LocalSpiderTimeline x s) where
2451+ spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s)
2452+
2453+localSpiderTimeline
2454+ :: Proxy s
2455+ -> SpiderTimelineEnv x
2456+ -> SpiderTimelineEnv (LocalSpiderTimeline x s)
2457+localSpiderTimeline _ = unsafeCoerce
2458+
2459+-- | Pass a new timeline to the given function.
2460+withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r
2461+withSpiderTimeline k = do
2462+ env <- unsafeNewSpiderTimelineEnv
2463+ reify env $ \s -> k $ localSpiderTimeline s env
2464+
2465+newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2466+
2467+type ComputeM = EventM
2468+
2469+newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2470+
2471+instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2472+ {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
2473+ newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
2474+ newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }
2475+ newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad)
2476+ newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }
2477+ type PullM (SpiderTimeline x) = SpiderPullM x
2478+ type PushM (SpiderTimeline x) = SpiderPushM x
2479+ {-# INLINABLE never #-}
2480+ never = SpiderEvent eventNever
2481+ {-# INLINABLE constant #-}
2482+ constant = SpiderBehavior . behaviorConst
2483+ {-# INLINE push #-}
2484+ push f = SpiderEvent . push (coerce f) . unSpiderEvent
2485+ {-# INLINE pushCheap #-}
2486+ pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
2487+ {-# INLINABLE pull #-}
2488+ pull = SpiderBehavior . pull . coerce
2489+ {-# INLINABLE merge #-}
2490+ merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x))
2491+ {-# INLINABLE fan #-}
2492+ fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
2493+ {-# INLINABLE switch #-}
2494+ switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior
2495+ {-# INLINABLE coincidence #-}
2496+ coincidence = SpiderEvent . coincidence . (coerce :: Event x (R.Event (SpiderTimeline x) a) -> Event x (Event x a)) . unSpiderEvent
2497+ {-# INLINABLE current #-}
2498+ current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
2499+ {-# INLINABLE updated #-}
2500+ updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic
2501+ {-# INLINABLE unsafeBuildDynamic #-}
2502+ unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
2503+ {-# INLINABLE unsafeBuildIncremental #-}
2504+ unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv
2505+ {-# INLINABLE mergeIncremental #-}
2506+ mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental
2507+ {-# INLINABLE mergeIncrementalWithMove #-}
2508+ mergeIncrementalWithMove = SpiderEvent . mergeWithMove . (unsafeCoerce :: Dynamic x (PatchDMapWithMove k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMapWithMove k (Event x))) . unSpiderIncremental
2509+ {-# INLINABLE currentIncremental #-}
2510+ currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
2511+ {-# INLINABLE updatedIncremental #-}
2512+ updatedIncremental = SpiderEvent . dynamicUpdated . unSpiderIncremental
2513+ {-# INLINABLE incrementalToDynamic #-}
2514+ incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (readBehaviorUntracked $ dynamicCurrent i) $ flip push (dynamicUpdated i) $ \p -> do
2515+ c <- readBehaviorUntracked $ dynamicCurrent i
2516+ return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'
2517+ eventCoercion Coercion = Coercion
2518+ behaviorCoercion Coercion = Coercion
2519+ dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance
2520+ {-# INLINABLE mergeIntIncremental #-}
2521+ mergeIntIncremental = SpiderEvent . mergeInt . (unsafeCoerce :: Dynamic x (PatchIntMap (R.Event (SpiderTimeline x) a)) -> Dynamic x (PatchIntMap (Event x a))) . unSpiderIncremental
2522+ {-# INLINABLE fanInt #-}
2523+ fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))
2524+
2525+data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)
2526+
2527+data SpiderEventHandle x a = SpiderEventHandle
2528+ { spiderEventHandleSubscription :: EventSubscription x
2529+ , spiderEventHandleValue :: IORef (Maybe a)
2530+ }
2531+
2532+instance MonadRef (EventM x) where
2533+ type Ref (EventM x) = Ref IO
2534+ {-# INLINABLE newRef #-}
2535+ {-# INLINABLE readRef #-}
2536+ {-# INLINABLE writeRef #-}
2537+ newRef = liftIO . newRef
2538+ readRef = liftIO . readRef
2539+ writeRef r a = liftIO $ writeRef r a
2540+
2541+instance MonadAtomicRef (EventM x) where
2542+ {-# INLINABLE atomicModifyRef #-}
2543+ atomicModifyRef r f = liftIO $ atomicModifyRef r f
2544+
2545+-- | The monad for actions that manipulate a Spider timeline identified by @x@
2546+newtype SpiderHost x a = SpiderHost { unSpiderHost :: ReaderT (SpiderTimelineEnv x) IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2547+
2548+instance Monad (SpiderHost x) where
2549+ {-# INLINABLE (>>=) #-}
2550+ SpiderHost x >>= f = SpiderHost $ x >>= unSpiderHost . f
2551+ {-# INLINABLE (>>) #-}
2552+ SpiderHost x >> SpiderHost y = SpiderHost $ x >> y
2553+ {-# INLINABLE return #-}
2554+ return x = SpiderHost $ return x
2555+ {-# INLINABLE fail #-}
2556+ fail s = SpiderHost $ fail s
2557+
2558+-- | Run an action affecting the global Spider timeline; this will be guarded by
2559+-- a mutex for that timeline
2560+runSpiderHost :: SpiderHost Global a -> IO a
2561+runSpiderHost (SpiderHost a) = runReaderT a globalSpiderTimelineEnv
2562+
2563+-- | Run an action affecting a given Spider timeline; this will be guarded by a
2564+-- mutex for that timeline
2565+runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
2566+runSpiderHostForTimeline (SpiderHost a) = runReaderT a
2567+
2568+newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2569+
2570+instance Monad (SpiderHostFrame x) where
2571+ {-# INLINABLE (>>=) #-}
2572+ SpiderHostFrame x >>= f = SpiderHostFrame $ x >>= runSpiderHostFrame . f
2573+ {-# INLINABLE (>>) #-}
2574+ SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y
2575+ {-# INLINABLE return #-}
2576+ return x = SpiderHostFrame $ return x
2577+ {-# INLINABLE fail #-}
2578+ fail s = SpiderHostFrame $ fail s
2579+
2580+instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where
2581+ notReadyUntil _ = pure ()
2582+ notReady = pure ()
2583+
2584+newEventWithTriggerIO :: (RootTrigger x a -> IO (IO ())) -> IO (Event x a)
2585+newEventWithTriggerIO f = do
2586+ es <- newFanEventWithTriggerIO $ \Refl -> f
2587+ return $ select es Refl
2588+
2589+newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger x a -> IO (IO ())) -> IO (EventSelector x k)
2590+newFanEventWithTriggerIO f = do
2591+ occRef <- newIORef DMap.empty
2592+ subscribedRef <- newIORef DMap.empty
2593+ let !r = Root
2594+ { rootOccurrence = occRef
2595+ , rootSubscribed = subscribedRef
2596+ , rootInit = f
2597+ }
2598+ return $ EventSelector $ \k -> eventRoot k r
2599+
2600+newtype ReadPhase x a = ReadPhase (ResultM x a) deriving (Functor, Applicative, Monad, MonadFix)
2601+
2602+instance MonadRef (SpiderHost x) where
2603+ type Ref (SpiderHost x) = Ref IO
2604+ newRef = SpiderHost . newRef
2605+ readRef = SpiderHost . readRef
2606+ writeRef r = SpiderHost . writeRef r
2607+
2608+instance MonadAtomicRef (SpiderHost x) where
2609+ atomicModifyRef r = SpiderHost . atomicModifyRef r
2610+
2611+instance MonadRef (SpiderHostFrame x) where
2612+ type Ref (SpiderHostFrame x) = Ref IO
2613+ newRef = SpiderHostFrame . newRef
2614+ readRef = SpiderHostFrame . readRef
2615+ writeRef r = SpiderHostFrame . writeRef r
2616+
2617+instance MonadAtomicRef (SpiderHostFrame x) where
2618+ atomicModifyRef r = SpiderHostFrame . atomicModifyRef r
2619+
2620+instance PrimMonad (SpiderHostFrame x) where
2621+ type PrimState (SpiderHostFrame x) = PrimState IO
2622+ 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 occurrence 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 occurrence 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+148
@@ -0,0 +1,148 @@
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.Adjustable.Class
29+import Reflex.Host.Class
30+import Reflex.PerformEvent.Class
31+import Reflex.PostBuild.Class
32+import Reflex.TriggerEvent.Class
33+
34+-- | A value with which to fire an 'Event', as well as a callback to invoke
35+-- after its propagation has completed.
36+data TriggerInvocation a = TriggerInvocation a (IO ())
37+
38+-- | A reference to an 'EventTrigger' suitable for firing with 'TriggerEventT'.
39+newtype EventTriggerRef t a = EventTriggerRef { unEventTriggerRef :: IORef (Maybe (EventTrigger t a)) }
40+
41+-- | A basic implementation of 'TriggerEvent'.
42+newtype TriggerEventT t m a = TriggerEventT { unTriggerEventT :: ReaderT (Chan [DSum (EventTriggerRef t) TriggerInvocation]) m a }
43+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
44+
45+-- | Run a 'TriggerEventT' action. The argument should be a 'Chan' into which
46+-- 'TriggerInvocation's can be passed; it is expected that some other thread
47+-- will be responsible for popping values out of the 'Chan' and firing their
48+-- 'EventTrigger's.
49+runTriggerEventT :: TriggerEventT t m a -> Chan [DSum (EventTriggerRef t) TriggerInvocation] -> m a
50+runTriggerEventT = runReaderT . unTriggerEventT
51+
52+instance MonadTrans (TriggerEventT t) where
53+ {-# INLINABLE lift #-}
54+ lift = TriggerEventT . lift
55+
56+instance PrimMonad m => PrimMonad (TriggerEventT t m) where
57+ type PrimState (TriggerEventT t m) = PrimState m
58+ {-# INLINABLE primitive #-}
59+ primitive = lift . primitive
60+
61+instance PerformEvent t m => PerformEvent t (TriggerEventT t m) where
62+ type Performable (TriggerEventT t m) = Performable m
63+ {-# INLINABLE performEvent_ #-}
64+ performEvent_ e = lift $ performEvent_ e
65+ {-# INLINABLE performEvent #-}
66+ performEvent e = lift $ performEvent e
67+
68+instance PostBuild t m => PostBuild t (TriggerEventT t m) where
69+ {-# INLINABLE getPostBuild #-}
70+ getPostBuild = lift getPostBuild
71+
72+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (TriggerEventT t m) where
73+ {-# INLINABLE newEventWithTrigger #-}
74+ newEventWithTrigger = lift . newEventWithTrigger
75+ {-# INLINABLE newFanEventWithTrigger #-}
76+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
77+
78+instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) => TriggerEvent t (TriggerEventT t m) where
79+ {-# INLINABLE newTriggerEvent #-}
80+ newTriggerEvent = do
81+ (e, t) <- newTriggerEventWithOnComplete
82+ return (e, \a -> t a $ return ())
83+ {-# INLINABLE newTriggerEventWithOnComplete #-}
84+ newTriggerEventWithOnComplete = do
85+ events <- askEvents
86+ (eResult, reResultTrigger) <- lift newEventWithTriggerRef
87+ return . (,) eResult $ \a cb ->
88+ writeChan events [EventTriggerRef reResultTrigger :=> TriggerInvocation a cb]
89+ {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
90+ newEventWithLazyTriggerWithOnComplete f = do
91+ events <- askEvents
92+ lift . newEventWithTrigger $ \t ->
93+ f $ \a cb -> do
94+ reResultTrigger <- newRef $ Just t
95+ writeChan events [EventTriggerRef reResultTrigger :=> TriggerInvocation a cb]
96+
97+instance MonadRef m => MonadRef (TriggerEventT t m) where
98+ type Ref (TriggerEventT t m) = Ref m
99+ {-# INLINABLE newRef #-}
100+ newRef = lift . newRef
101+ {-# INLINABLE readRef #-}
102+ readRef = lift . readRef
103+ {-# INLINABLE writeRef #-}
104+ writeRef r = lift . writeRef r
105+
106+instance MonadAtomicRef m => MonadAtomicRef (TriggerEventT t m) where
107+ {-# INLINABLE atomicModifyRef #-}
108+ atomicModifyRef r = lift . atomicModifyRef r
109+
110+instance MonadSample t m => MonadSample t (TriggerEventT t m) where
111+ {-# INLINABLE sample #-}
112+ sample = lift . sample
113+
114+instance MonadHold t m => MonadHold t (TriggerEventT t m) where
115+ {-# INLINABLE hold #-}
116+ hold v0 v' = lift $ hold v0 v'
117+ {-# INLINABLE holdDyn #-}
118+ holdDyn v0 v' = lift $ holdDyn v0 v'
119+ {-# INLINABLE holdIncremental #-}
120+ holdIncremental v0 v' = lift $ holdIncremental v0 v'
121+ {-# INLINABLE buildDynamic #-}
122+ buildDynamic a0 = lift . buildDynamic a0
123+ {-# INLINABLE headE #-}
124+ headE = lift . headE
125+
126+instance Adjustable t m => Adjustable t (TriggerEventT t m) where
127+ {-# INLINABLE runWithReplace #-}
128+ runWithReplace (TriggerEventT a0) a' = TriggerEventT $ runWithReplace a0 (coerceEvent a')
129+ {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}
130+ traverseIntMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseIntMapWithKeyWithAdjust (coerce . f) dm0 dm'
131+ {-# INLINABLE traverseDMapWithKeyWithAdjust #-}
132+ traverseDMapWithKeyWithAdjust f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjust (coerce . f) dm0 dm'
133+ {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}
134+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = TriggerEventT $ traverseDMapWithKeyWithAdjustWithMove (coerce . f) dm0 dm'
135+
136+-- TODO: Monoid and Semigroup can likely be derived once ReaderT has them.
137+instance (Monoid a, Applicative m) => Monoid (TriggerEventT t m a) where
138+ mempty = pure mempty
139+ mappend = (<>)
140+
141+instance (S.Semigroup a, Applicative m) => S.Semigroup (TriggerEventT t m a) where
142+ (<>) = liftA2 (S.<>)
143+
144+
145+-- | Retrieve the current 'Chan'; event trigger invocations pushed into it will
146+-- be fired.
147+askEvents :: Monad m => TriggerEventT t m (Chan [DSum (EventTriggerRef t) TriggerInvocation])
148+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+44
@@ -0,0 +1,44 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ExplicitForAll #-}
3+{-# LANGUAGE MultiParamTypeClasses #-}
4+{-# LANGUAGE RecursiveDo #-}
5+#ifdef USE_REFLEX_OPTIMIZER
6+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
7+#endif
8+
9+module Reflex.Widget.Basic where
10+
11+import Control.Monad.Fix (MonadFix)
12+import Data.Map (Map)
13+
14+import Reflex.Class
15+import Reflex.Adjustable.Class
16+import Reflex.Patch.MapWithMove
17+
18+
19+-- | Build sortable content in such a way that re-sorting it can cause minimal
20+-- disruption to an existing context.
21+--
22+-- Naively re-sorting a list of images would destroy every image and add them back
23+-- in the new order. This framework is able to avoid that by preserving the
24+-- identity of each image and simply moving it to the new location.
25+--
26+-- Example:
27+--
28+-- > let sortByFst = buttonA $> comparing fst
29+-- > sortBySnd = buttonB $> comparing snd
30+-- > sortEvent = leftmost [sortByFst, sortBySnd]
31+-- > sortableList
32+-- > (\k v -> text $ "\n" ++ show k ++ " " ++ v) -- show each element on a new line
33+-- > (Map.fromList $ zip [0..] [(3, "a"), (2, "b"), (1, "c")])
34+-- > sortEvent
35+sortableList :: forall t m k v a. (MonadHold t m, MonadFix m, Adjustable t m, Ord k)
36+ => (k -> v -> m a) -- ^ Function to render the content for each key/value pair
37+ -> Map k v -- ^ The sortable list with an initial ordering determined by the @Map@ keys in ascending order
38+ -> Event t (v -> v -> Ordering) -- ^ An event carrying a sort function for the list
39+ -> m (Map k a)
40+sortableList f m0 reSortFunc = do
41+ rec let reSortPatch = attachWith (flip patchThatSortsMapWith) (currentIncremental m) reSortFunc
42+ m <- holdIncremental m0 reSortPatch
43+ (results, _) <- mapMapWithAdjustWithMove f m0 reSortPatch
44+ pure results
src/Reflex/Workflow.hsnew file+38
@@ -0,0 +1,38 @@
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.Adjustable.Class
17+import Reflex.Network
18+import Reflex.NotReady.Class
19+import Reflex.PostBuild.Class
20+
21+newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }
22+
23+workflow :: forall t m a. (Reflex t, Adjustable t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a)
24+workflow w0 = do
25+ rec eResult <- networkHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult
26+ return $ fmap fst eResult
27+
28+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)
29+workflowView w0 = do
30+ rec eResult <- networkView . fmap unWorkflow =<< holdDyn w0 eReplace
31+ eReplace <- fmap switch $ hold never $ fmap snd eResult
32+ return $ fmap fst eResult
33+
34+mapWorkflow :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b
35+mapWorkflow f (Workflow x) = Workflow (fmap (f *** fmap (mapWorkflow f)) x)
36+
37+mapWorkflowCheap :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b
38+mapWorkflowCheap f (Workflow x) = Workflow (fmap (f *** fmapCheap (mapWorkflowCheap f)) x)
test/EventWriterT.hsnew file+65
@@ -0,0 +1,65 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE RecursiveDo #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+module Main where
5+
6+import Control.Lens
7+import Control.Monad
8+import Control.Monad.Fix
9+import Data.These
10+
11+import Reflex
12+import Reflex.EventWriter.Base
13+import Test.Run
14+
15+main :: IO ()
16+main = do
17+ os1@[[Just [10,9,8,7,6,5,4,3,2,1]]] <- runApp' (unwrapApp testOrdering) $
18+ [ Just ()
19+ ]
20+ print os1
21+ os2@[[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]]
22+ <- runApp' (unwrapApp testSimultaneous) $ map Just $
23+ [ This ()
24+ , That ()
25+ , This ()
26+ , These () ()
27+ ]
28+ print os2
29+ os3@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEvent) [Just ()]
30+ print os3
31+ return ()
32+
33+unwrapApp :: (Reflex t, Monad m) => (a -> EventWriterT t [Int] m ()) -> a -> m (Event t [Int])
34+unwrapApp x appIn = do
35+ ((), e) <- runEventWriterT $ x appIn
36+ return e
37+
38+testOrdering :: (Reflex t, Monad m) => Event t () -> EventWriterT t [Int] m ()
39+testOrdering pulse = do
40+ forM_ [10,9..1] $ \i -> tellEvent ([i] <$ pulse)
41+ return ()
42+
43+testSimultaneous :: (Reflex t, Adjustable t m, MonadHold t m) => Event t (These () ()) -> EventWriterT t [Int] m ()
44+testSimultaneous pulse = do
45+ let e0 = fmapMaybe (^? here) pulse
46+ e1 = fmapMaybe (^? there) pulse
47+ forM_ [1,3..9] $ \i -> runWithReplace (tellEvent ([i] <$ e0)) $ ffor e1 $ \_ -> tellEvent ([i+1] <$ e0)
48+ return ()
49+
50+-- | Test that a widget telling and event which fires at the same time it has been replaced
51+-- doesn't count along with the new widget.
52+testMoribundTellEvent
53+ :: forall t m
54+ . ( Reflex t
55+ , Adjustable t m
56+ , MonadHold t m
57+ , MonadFix m
58+ )
59+ => Event t ()
60+ -> EventWriterT t [Int] m ()
61+testMoribundTellEvent pulse = do
62+ rec let tellIntOnReplce :: Int -> EventWriterT t [Int] m ()
63+ tellIntOnReplce x = tellEvent $ [x] <$ rwrFinished
64+ (_, rwrFinished) <- runWithReplace (tellIntOnReplce 1) $ tellIntOnReplce 2 <$ pulse
65+ return ()
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+132
@@ -0,0 +1,132 @@
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 () -- for the Align instance
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.Map.Monoidal (MonoidalMap)
17+import Data.Semigroup
18+import Data.These
19+
20+import Reflex
21+import Reflex.Patch.MapWithMove
22+import Test.Run
23+
24+newtype MyQuery = MyQuery SelectedCount
25+ deriving (Show, Read, Eq, Ord, Monoid, Semigroup, Additive, Group)
26+
27+instance Query MyQuery where
28+ type QueryResult MyQuery = ()
29+ crop _ _ = ()
30+
31+instance (Ord k, Query a, Eq (QueryResult a)) => Query (Selector k a) where
32+ type QueryResult (Selector k a) = Selector k (QueryResult a)
33+ crop q r = undefined
34+
35+newtype Selector k a = Selector { unSelector :: MonoidalMap k a }
36+ deriving (Show, Read, Eq, Ord, Functor)
37+
38+instance (Ord k, Eq a, Monoid a) => Semigroup (Selector k a) where
39+ (Selector a) <> (Selector b) = Selector $ fmapMaybe id $ f a b
40+ where
41+ f = alignWith $ \case
42+ This x -> Just x
43+ That y -> Just y
44+ These x y ->
45+ let z = x `mappend` y
46+ in if z == mempty then Nothing else Just z
47+
48+instance (Ord k, Eq a, Monoid a) => Monoid (Selector k a) where
49+ mempty = Selector AMap.empty
50+ mappend = (<>)
51+
52+instance (Eq a, Ord k, Group a) => Group (Selector k a) where
53+ negateG = fmap negateG
54+
55+instance (Eq a, Ord k, Group a) => Additive (Selector k a)
56+
57+main :: IO ()
58+main = do
59+ [0, 1, 1, 0] <- fmap (map fst . concat) $
60+ runApp (testQueryT testRunWithReplace) () $ map (Just . That) $
61+ [ That (), This (), That () ]
62+ [0, 1, 1, 0] <- fmap (map fst . concat) $
63+ runApp (testQueryT testSequenceDMapWithAdjust) () $ map (Just . That) $
64+ [ That (), This (), That () ]
65+ [0, 1, 1, 0] <- fmap (map fst . concat) $
66+ runApp (testQueryT testSequenceDMapWithAdjustWithMove) () $ map (Just . That) $
67+ [ That (), This (), That () ]
68+ return ()
69+
70+testQueryT :: (Reflex t, MonadFix m)
71+ => (Event t () -> Event t () -> QueryT t (Selector Int MyQuery) m ())
72+ -> AppIn t () (These () ())
73+ -> m (AppOut t Int Int)
74+testQueryT w (AppIn _ pulse) = do
75+ let replace = fmapMaybe (^? here) pulse
76+ increment = fmapMaybe (^? there) pulse
77+ (_, q) <- runQueryT (w replace increment) $ pure mempty
78+ let qDyn = head . AMap.keys . unSelector <$> incrementalToDynamic q
79+ return $ AppOut
80+ { _appOut_behavior = current qDyn
81+ , _appOut_event = updated qDyn
82+ }
83+
84+testRunWithReplace :: ( Reflex t
85+ , Adjustable t m
86+ , MonadHold t m
87+ , MonadFix m
88+ , MonadQuery t (Selector Int MyQuery) m)
89+ => Event t ()
90+ -> Event t ()
91+ -> m ()
92+testRunWithReplace replace increment = do
93+ let w = do
94+ n <- count increment
95+ queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1
96+ _ <- runWithReplace w $ w <$ replace
97+ return ()
98+
99+testSequenceDMapWithAdjust :: ( Reflex t
100+ , Adjustable t m
101+ , MonadHold t m
102+ , MonadFix m
103+ , MonadQuery t (Selector Int MyQuery) m)
104+ => Event t ()
105+ -> Event t ()
106+ -> m ()
107+testSequenceDMapWithAdjust replace increment = do
108+ _ <- listHoldWithKey (Map.singleton () ()) (Map.singleton () (Just ()) <$ replace) $ \_ _ -> do
109+ n <- count increment
110+ queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1
111+ return ()
112+
113+testSequenceDMapWithAdjustWithMove :: ( Reflex t
114+ , Adjustable t m
115+ , MonadHold t m
116+ , MonadFix m
117+ , MonadQuery t (Selector Int MyQuery) m)
118+ => Event t ()
119+ -> Event t ()
120+ -> m ()
121+testSequenceDMapWithAdjustWithMove replace increment = do
122+ _ <- listHoldWithKeyWithMove (Map.singleton () ()) (Map.singleton () (Just ()) <$ replace) $ \_ _ -> do
123+ n <- count increment
124+ queryDyn $ zipDynWith (\x y -> Selector (AMap.singleton (x :: Int) y)) n $ pure $ MyQuery $ SelectedCount 1
125+ return ()
126+
127+-- scam it out to test traverseDMapWithAdjustWithMove
128+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))
129+listHoldWithKeyWithMove m0 m' f = do
130+ (n0, n') <- mapMapWithAdjustWithMove f m0 $ ffor m' $ PatchMapWithMove . Map.map (\v -> NodeInfo (maybe From_Delete From_Insert v) Nothing)
131+ incrementalToDynamic <$> holdIncremental n0 n'
132+-- -}
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 occurrences = 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 <$> occurrences)
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+255
@@ -0,0 +1,255 @@
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.Pure as P
24+import qualified Reflex.Spider.Internal as S
25+
26+import Control.Arrow (second, (&&&))
27+import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
28+import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
29+import Control.Monad.Writer hiding (forM, forM_, mapM, mapM_, sequence, sequence_)
30+import Data.Dependent.Map (DSum (..))
31+import Data.Foldable
32+import Data.Map.Strict (Map)
33+import qualified Data.Map.Strict as Map
34+import qualified Data.Set as Set
35+import Data.Traversable
36+import System.Exit
37+import System.Mem
38+
39+import System.IO.Unsafe
40+
41+mapToPureBehavior :: Map Int a -> Behavior PureReflexDomain a
42+mapToPureBehavior m = P.Behavior $ \t -> case Map.lookupLE t m of
43+ Nothing -> error $ "mapToPureBehavior: no value for time " <> show t
44+ Just (_, v) -> v
45+
46+mapToPureEvent :: Map Int a -> Event PureReflexDomain a
47+mapToPureEvent m = P.Event $ flip Map.lookup m
48+
49+relevantTestingTimes :: (Map Int a, Map Int b) -> [Int]
50+relevantTestingTimes (b, e) = case Set.minView &&& Set.maxView $ Map.keysSet b `Set.union` Map.keysSet e of
51+ (Just (t0, _), Just (t1, _)) -> [t0..t1+1] -- We need to go to b+1 to see the result of the final event
52+ _ -> [] -- Doesn't actually make much sense
53+
54+type PureReflexDomain = P.Pure Int
55+type TimeM = (->) Int
56+
57+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)
58+testPure builder (b, e) =
59+ let (P.Behavior b', P.Event e') = ($ 0) $ builder (mapToPureBehavior b, mapToPureEvent e)
60+ relevantTimes = relevantTestingTimes (b, e)
61+ e'' = Map.mapMaybe id $ Map.fromList $ map (id &&& e') relevantTimes
62+ b'' = Map.fromList $ map (id &&& b') relevantTimes
63+ in (b'', e'')
64+
65+class MapMSignals a a' t t' | a -> t, a' -> t', a t' -> a', a' t -> a where
66+ mapMSignals :: Monad m => (forall b. Behavior t b -> m (Behavior t' b)) -> (forall b. Event t b -> m (Event t' b)) -> a -> m a'
67+
68+instance MapMSignals (Behavior t a) (Behavior t' a) t t' where
69+ mapMSignals fb _ = fb
70+
71+instance MapMSignals (Event t a) (Event t' a) t t' where
72+ mapMSignals _ fe = fe
73+
74+instance (MapMSignals a a' t t', MapMSignals b b' t t') => MapMSignals (a, b) (a', b') t t' where
75+ mapMSignals fb fe (a, b) = liftM2 (,) (mapMSignals fb fe a) (mapMSignals fb fe b)
76+
77+testSpider :: (forall m t. TestCaseConstraint t m => (Behavior t a, Event t b) -> m (Behavior t c, Event t d)) -> (Map Int a, Map Int b) -> (Map Int c, Map Int d)
78+testSpider builder (bMap, eMap) = unsafePerformIO $ S.runSpiderHost $ do
79+ (re, reTrigger) <- newEventWithTriggerRef
80+ (rb, rbTrigger) <- newEventWithTriggerRef
81+ b <- runHostFrame $ hold (error "testSpider: No value for input behavior yet") rb
82+ (b', e') <- runHostFrame $ builder (b, re)
83+ e'Handle <- subscribeEvent e' --TODO: This should be unnecessary
84+ let times = relevantTestingTimes (bMap, eMap)
85+ liftIO performGC
86+ outputs <- forM times $ \t -> do
87+ forM_ (Map.lookup t bMap) $ \val -> mapM_ (\ rbt -> fireEvents [rbt :=> Identity val]) =<< readRef rbTrigger
88+ bOutput <- sample b'
89+ eOutput <- fmap join $ forM (Map.lookup t eMap) $ \val -> do
90+ mret <- readRef reTrigger
91+ let firing = case mret of
92+ Just ret -> [ret :=> Identity val]
93+ Nothing -> []
94+ fireEventsAndRead firing $ sequence =<< readEvent e'Handle
95+ liftIO performGC
96+ return (t, (bOutput, eOutput))
97+ return (Map.fromList $ map (second fst) outputs, Map.mapMaybe id $ Map.fromList $ map (second snd) outputs)
98+
99+tracePerf :: Show a => a -> b -> b
100+tracePerf = flip const
101+
102+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
103+testAgreement builder inputs = do
104+ let identityResult = testPure builder inputs
105+ tracePerf "---------" $ return ()
106+ let spiderResult = testSpider builder inputs
107+ tracePerf "---------" $ return ()
108+ let resultsAgree = identityResult == spiderResult
109+ if resultsAgree
110+ then do --putStrLn "Success:"
111+ --print identityResult
112+ return ()
113+ else do putStrLn "Failure:"
114+ putStrLn $ "Pure result: " <> show identityResult
115+ putStrLn $ "Spider result: " <> show spiderResult
116+ return resultsAgree
117+
118+type TestCaseConstraint t m = (Reflex t, MonadSample t m, MonadHold t m, MonadFix m, MonadFix (PushM t))
119+
120+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))
121+
122+testCases :: [(String, TestCase)]
123+testCases =
124+ [ (,) "hold" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(_, e) -> do
125+ b' <- hold "123" e
126+ return (b', e)
127+ , (,) "count" $ TestCase (Map.singleton 0 (), Map.fromList [(1, ()), (2, ()), (3, ())]) $ \(_, e) -> do
128+ e' <- updated <$> count e
129+ b' <- hold (0 :: Int) e'
130+ return (b', e')
131+ , (,) "headE-1" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
132+ e' <- headE $ leftmost [e, e]
133+ return (b, e')
134+ , (,) "switch-1" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
135+ let e' = fmap (const e) e
136+ b' <- hold never e'
137+ let e'' = switch b'
138+ return (b, e'')
139+ , (,) "switch-2" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
140+ let e' = flip pushAlways e $ const $ do
141+ let eab = splitRecombineEvent e
142+ switch <$> hold eab never
143+ e'' = coincidence e'
144+ return (b, e'')
145+ , (,) "switch-3" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
146+ let e' = flip pushAlways e $ const $ do
147+ let eab = splitRecombineEvent e
148+ switch <$> hold eab (fmap (const e) e)
149+ e'' = coincidence e'
150+ return (b, e'')
151+ , (,) "switch-4" $ TestCase (Map.singleton 0 "asdf", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
152+ let e' = leftmost [e, e]
153+ e'' <- switch <$> hold e' (fmap (const e) e)
154+ return (b, e'')
155+ , (,) "switchHoldPromptly-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
156+ let e' = fmap (const e) e
157+ e'' <- switchHoldPromptly never e'
158+ return (b, e'')
159+ , (,) "switchHoldPromptly-2" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
160+ let e' = fmap (const e) e
161+ e'' <- switchHoldPromptly never $ leftmost [e', e']
162+ return (b, e'')
163+ , (,) "switchHoldPromptly-3" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
164+ let e' = leftmost [e, e]
165+ e'' <- switchHoldPromptly never (fmap (const e) e')
166+ return (b, e'')
167+ , (,) "switchHoldPromptly-4" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do
168+ let e' = leftmost [e, e]
169+ e'' <- switchHoldPromptly never (fmap (const e') e)
170+ return (b, e'')
171+ , (,) "switch-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
172+ let e' = leftmost [e, e]
173+ e'' <- switch <$> hold never (fmap (const e') e)
174+ return (b, e'')
175+ , (,) "switchHoldPromptly-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
176+ let e' = flip push e $ \_ -> do
177+ Just <$> headE e
178+ e'' <- switchHoldPromptly never e'
179+ return (b, e'')
180+ , (,) "switchHoldPromptly-6" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
181+ let e' = flip pushAlways e $ \_ -> do
182+ switchHoldPromptly e never
183+ e'' <- switchHoldPromptly never e'
184+ return (b, e'')
185+ , (,) "coincidence-1" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
186+ let e' = flip pushAlways e $ \_ -> return e
187+ e'' = coincidence e'
188+ return (b, e'')
189+ , (,) "coincidence-2" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
190+ let e' = flip pushAlways e $ \_ -> return $ leftmost [e, e]
191+ e'' = coincidence e'
192+ return (b, e'')
193+ , (,) "coincidence-3" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
194+ let e' = flip pushAlways e $ \_ -> return $ coincidence $ fmap (const e) e
195+ e'' = coincidence e'
196+ return (b, e'')
197+ , (,) "coincidence-4" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do
198+ let e' = flip pushAlways e $ \_ -> headE e
199+ e'' = coincidence e'
200+ return (b, e'')
201+ , (,) "coincidence-5" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer")]) $ \(b, e) -> do
202+ let eChild = flip pushAlways e $ const $ do
203+ let eNewValues = leftmost [e, e]
204+ return $ coincidence $ fmap (const eNewValues) eNewValues
205+ e' = coincidence eChild
206+ return (b, e')
207+ , (,) "coincidence-6" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer")]) $ \(b, e) -> do
208+ let eChild = flip pushAlways e $ const $ do
209+ let e' = coincidence $ fmap (const e) e
210+ return $ leftmost [e', e']
211+ e'' = coincidence eChild
212+ return (b, e'')
213+ , (,) "coincidence-7" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj"), (3, "asdf")]) $ \(b, e) -> do
214+ let e' = leftmost [e, e]
215+ eCoincidences = coincidence $ fmap (const e') e
216+ return (b, eCoincidences)
217+ , (,) "holdWhileFiring" $ TestCase (Map.singleton 0 "zxc", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
218+ eo <- headE e
219+ bb <- hold b $ pushAlways (const $ hold "asdf" eo) eo
220+ let b' = pull $ sample =<< sample bb
221+ return (b', e)
222+ , (,) "joinDyn" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do
223+ bb <- hold "b" e
224+ bd <- hold never . fmap (const e) =<< headE e
225+ eOuter <- pushAlways sample . fmap (const bb) <$> headE e
226+ let eInner = switch bd
227+ e' = leftmost [eOuter, eInner]
228+ return (b, e')
229+ , (,) "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
230+ rec result <- holdUniqDyn d
231+ d <- holdDyn (0 :: Int) e
232+ return (current result, updated result)
233+ {-
234+ , (,) "mergeIncrementalWithMove" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, PatchDMapWithMove.moveDMapKey LeftTag RightTag), (2, mempty)]) $ \(b, e :: Event t (PatchDMapWithMove (EitherTag () ()) (Const2 () ()))) -> do
235+ x <- holdIncremental (DMap.singleton LeftTag $ void e) $ PatchDMapWithMove.mapPatchDMapWithMove (\(Const2 _) -> void e) <$> e
236+ let e' = mergeIncrementalWithMove x :: Event t (DMap (EitherTag () ()) Identity)
237+ return (b, e')
238+ -}
239+ ]
240+
241+splitRecombineEvent :: Reflex t => Event t a -> Event t String
242+splitRecombineEvent e =
243+ let ea = "a" <$ e
244+ eb = "b" <$ e
245+ in leftmost [ea, eb]
246+
247+
248+test :: IO ()
249+test = do
250+ results <- forM testCases $ \(name, TestCase inputs builder) -> do
251+ putStrLn $ "Test: " <> name
252+ testAgreement builder inputs
253+ exitWith $ if and results
254+ then ExitSuccess
255+ 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+67
@@ -0,0 +1,67 @@
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 = forM_ [10,9..1] $ \i ->
55+ requestingIdentity (RequestInt i <$ pulse)
56+
57+testSimultaneous :: ( Response m ~ Identity
58+ , Request m ~ RequestInt
59+ , Requester t m
60+ , Adjustable t m)
61+ => Event t (These () ())
62+ -> m ()
63+testSimultaneous pulse = do
64+ let tellE = fmapMaybe (^? here) pulse
65+ switchE = fmapMaybe (^? there) pulse
66+ forM_ [1,3..9] $ \i -> runWithReplace (requestingIdentity (RequestInt i <$ tellE)) $ ffor switchE $ \_ ->
67+ 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+8−4
@@ -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 </> "src") --TODO: Someday fix all hints in tests, etc.
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